{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-x-partial #-}

-- | Fast imperative lexers over "ByteString".
--
-- These are complementary to the parser-combinator approach in
-- "Circuit.Parser": they trade compositionality for raw speed
-- (zero-copy slices, "unsafeIndex" loops). The markup lexer can
-- also be viewed as a state machine (see 'oAccumStep' / 'stepMarkupS')
-- which morphs cleanly into a 'Circuit' when composition is needed.
module Circuit.Parser.Lexer
  ( -- * Word lexing
    runWordLexerBS,
    wordFreqBS,

    -- * Markup lexing
    MarkupCtx (..),
    MarkupToken (..),
    runMarkupLexerBS,
    runMarkupStateBS,

    -- * Byte classification
    ByteClass (..),
    classifyByte,

    -- * Accumulator state
    AccState (..),
    accumStep,

    -- * Traced / state-machine interface
    WI (..),
    OAccState (..),
    initOAccState,
    oAccumStep,
    stepMarkupS,
  )
where

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BSU
import Data.Word (Word8)
import Prelude hiding (id, (.))
import Prelude qualified as P

-- $setup
-- >>> import Data.ByteString.Char8 qualified as C

-- | Strict unboxed pair of byte and index.
data WI = WI {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int

isAlphaW :: Word8 -> Bool
isAlphaW :: Word8 -> Bool
isAlphaW Word8
w = (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90) Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122)

toLowerW :: Word8 -> Word8
toLowerW :: Word8 -> Word8
toLowerW Word8
w
  | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90 = Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
32
  | Bool
otherwise = Word8
w

-- * Word lexing

-- | Run word lexer directly over a ByteString.
--
-- >>> runWordLexerBS (C.pack "Hello, world!")
-- ["hello","world"]
runWordLexerBS :: ByteString -> [ByteString]
runWordLexerBS :: ByteString -> [ByteString]
runWordLexerBS ByteString
bs = Int -> Bool -> Int -> [ByteString]
go Int
0 Bool
False Int
0
  where
    !len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    go :: Int -> Bool -> Int -> [ByteString]
go !Int
i !Bool
inWord !Int
start
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = [Int -> Int -> ByteString
lowerSlice Int
start (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) | Bool
inWord]
      | Bool
otherwise =
          let !w :: Word8
w = ByteString -> Int -> Word8
BSU.unsafeIndex ByteString
bs Int
i
           in if Word8 -> Bool
isAlphaW Word8
w
                then Int -> Bool -> Int -> [ByteString]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
True (if Bool
inWord then Int
start else Int
i)
                else
                  if Bool
inWord
                    then Int -> Int -> ByteString
lowerSlice Int
start (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> Bool -> Int -> [ByteString]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
False Int
0
                    else Int -> Bool -> Int -> [ByteString]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
False Int
0
    lowerSlice :: Int -> Int -> ByteString
lowerSlice Int
s Int
l = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
toLowerW (Int -> ByteString -> ByteString
BSU.unsafeTake Int
l (Int -> ByteString -> ByteString
BSU.unsafeDrop Int
s ByteString
bs))

-- | Word frequency list — single pass, accumulate (word, count) pairs.
wordFreqBS :: ByteString -> [(ByteString, Int)]
wordFreqBS :: ByteString -> [(ByteString, Int)]
wordFreqBS ByteString
bs = Int -> Bool -> Int -> [(ByteString, Int)] -> [(ByteString, Int)]
go Int
0 Bool
False Int
0 []
  where
    !len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    go :: Int -> Bool -> Int -> [(ByteString, Int)] -> [(ByteString, Int)]
go !Int
i !Bool
inWord !Int
start ![(ByteString, Int)]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len =
          if Bool
inWord
            then ByteString -> [(ByteString, Int)] -> [(ByteString, Int)]
forall {b} {t}. (Num b, Eq t) => t -> [(t, b)] -> [(t, b)]
insertFreq (Int -> Int -> ByteString
lowerSlice Int
start (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)) [(ByteString, Int)]
acc
            else [(ByteString, Int)]
acc
      | Bool
otherwise =
          let !w :: Word8
w = ByteString -> Int -> Word8
BSU.unsafeIndex ByteString
bs Int
i
           in if Word8 -> Bool
isAlphaW Word8
w
                then Int -> Bool -> Int -> [(ByteString, Int)] -> [(ByteString, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
True (if Bool
inWord then Int
start else Int
i) [(ByteString, Int)]
acc
                else
                  if Bool
inWord
                    then Int -> Bool -> Int -> [(ByteString, Int)] -> [(ByteString, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
False Int
0 (ByteString -> [(ByteString, Int)] -> [(ByteString, Int)]
forall {b} {t}. (Num b, Eq t) => t -> [(t, b)] -> [(t, b)]
insertFreq (Int -> Int -> ByteString
lowerSlice Int
start (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)) [(ByteString, Int)]
acc)
                    else Int -> Bool -> Int -> [(ByteString, Int)] -> [(ByteString, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
False Int
0 [(ByteString, Int)]
acc
    lowerSlice :: Int -> Int -> ByteString
lowerSlice Int
s Int
l = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
toLowerW (Int -> ByteString -> ByteString
BSU.unsafeTake Int
l (Int -> ByteString -> ByteString
BSU.unsafeDrop Int
s ByteString
bs))
    insertFreq :: t -> [(t, b)] -> [(t, b)]
insertFreq t
word [] = [(t
word, b
1)]
    insertFreq t
word ((t
w, b
c) : [(t, b)]
rest)
      | t
word t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
w = (t
w, b
c b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (t, b) -> [(t, b)] -> [(t, b)]
forall a. a -> [a] -> [a]
: [(t, b)]
rest
      | Bool
otherwise = (t
w, b
c) (t, b) -> [(t, b)] -> [(t, b)]
forall a. a -> [a] -> [a]
: t -> [(t, b)] -> [(t, b)]
insertFreq t
word [(t, b)]
rest

data MarkupCtx
  = InContent
  | InTagName
  | InAttr
  | InAttrVal Char
  | InClose
  | InComment
  deriving (MarkupCtx -> MarkupCtx -> Bool
(MarkupCtx -> MarkupCtx -> Bool)
-> (MarkupCtx -> MarkupCtx -> Bool) -> Eq MarkupCtx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MarkupCtx -> MarkupCtx -> Bool
== :: MarkupCtx -> MarkupCtx -> Bool
$c/= :: MarkupCtx -> MarkupCtx -> Bool
/= :: MarkupCtx -> MarkupCtx -> Bool
Eq, Int -> MarkupCtx -> ShowS
[MarkupCtx] -> ShowS
MarkupCtx -> String
(Int -> MarkupCtx -> ShowS)
-> (MarkupCtx -> String)
-> ([MarkupCtx] -> ShowS)
-> Show MarkupCtx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkupCtx -> ShowS
showsPrec :: Int -> MarkupCtx -> ShowS
$cshow :: MarkupCtx -> String
show :: MarkupCtx -> String
$cshowList :: [MarkupCtx] -> ShowS
showList :: [MarkupCtx] -> ShowS
Show)

-- | Markup token. ByteString fields are zero-copy slices of the input.
data MarkupToken
  = TOpenTag ByteString
  | TCloseTag ByteString
  | TContent ByteString
  | TSelfClose
  | TTagEnd
  | TAttrName ByteString
  | TAttrVal ByteString
  | TComment ByteString
  deriving (MarkupToken -> MarkupToken -> Bool
(MarkupToken -> MarkupToken -> Bool)
-> (MarkupToken -> MarkupToken -> Bool) -> Eq MarkupToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MarkupToken -> MarkupToken -> Bool
== :: MarkupToken -> MarkupToken -> Bool
$c/= :: MarkupToken -> MarkupToken -> Bool
/= :: MarkupToken -> MarkupToken -> Bool
Eq, Int -> MarkupToken -> ShowS
[MarkupToken] -> ShowS
MarkupToken -> String
(Int -> MarkupToken -> ShowS)
-> (MarkupToken -> String)
-> ([MarkupToken] -> ShowS)
-> Show MarkupToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkupToken -> ShowS
showsPrec :: Int -> MarkupToken -> ShowS
$cshow :: MarkupToken -> String
show :: MarkupToken -> String
$cshowList :: [MarkupToken] -> ShowS
showList :: [MarkupToken] -> ShowS
Show)

data ByteClass
  = BLt
  | BGt
  | BSlash
  | BEquals
  | BQuote Char
  | BSpace
  | BAlpha Word8
  | BDash
  | BBang
  | BQuestion
  deriving (ByteClass -> ByteClass -> Bool
(ByteClass -> ByteClass -> Bool)
-> (ByteClass -> ByteClass -> Bool) -> Eq ByteClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ByteClass -> ByteClass -> Bool
== :: ByteClass -> ByteClass -> Bool
$c/= :: ByteClass -> ByteClass -> Bool
/= :: ByteClass -> ByteClass -> Bool
Eq, Int -> ByteClass -> ShowS
[ByteClass] -> ShowS
ByteClass -> String
(Int -> ByteClass -> ShowS)
-> (ByteClass -> String)
-> ([ByteClass] -> ShowS)
-> Show ByteClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByteClass -> ShowS
showsPrec :: Int -> ByteClass -> ShowS
$cshow :: ByteClass -> String
show :: ByteClass -> String
$cshowList :: [ByteClass] -> ShowS
showList :: [ByteClass] -> ShowS
Show)

classifyByte :: MarkupCtx -> Word8 -> ByteClass
classifyByte :: MarkupCtx -> Word8 -> ByteClass
classifyByte MarkupCtx
_ Word8
w = case Word8
w of
  Word8
60 -> ByteClass
BLt
  Word8
62 -> ByteClass
BGt
  Word8
47 -> ByteClass
BSlash
  Word8
61 -> ByteClass
BEquals
  Word8
39 -> Char -> ByteClass
BQuote Char
'\''
  Word8
34 -> Char -> ByteClass
BQuote Char
'"'
  Word8
32 -> ByteClass
BSpace
  Word8
9 -> ByteClass
BSpace
  Word8
10 -> ByteClass
BSpace
  Word8
13 -> ByteClass
BSpace
  Word8
45 -> ByteClass
BDash
  Word8
33 -> ByteClass
BBang
  Word8
63 -> ByteClass
BQuestion
  Word8
_ -> Word8 -> ByteClass
BAlpha Word8
w

-- | Accumulator: track start offset and length of current token being built.
data AccState = AccState
  { AccState -> Int
accStart :: {-# UNPACK #-} !Int,
    AccState -> Int
accLen :: {-# UNPACK #-} !Int,
    AccState -> MarkupCtx
accCtx :: !MarkupCtx
  }

-- | Step the accumulator given a byte class, current context, and byte index.
accumStep ::
  AccState ->
  ByteClass ->
  Int ->
  (Maybe (ByteString -> MarkupToken, Int, Int), AccState)
accumStep :: AccState
-> ByteClass
-> Int
-> (Maybe (ByteString -> MarkupToken, Int, Int), AccState)
accumStep (AccState !Int
s !Int
l !MarkupCtx
ctx) ByteClass
bc !Int
i = case (MarkupCtx
ctx, ByteClass
bc) of
  (MarkupCtx
InContent, ByteClass
BLt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TContent, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InTagName
    )
  (MarkupCtx
InContent, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InContent)
  (MarkupCtx
InTagName, ByteClass
BSpace) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TOpenTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InAttr
    )
  (MarkupCtx
InTagName, ByteClass
BGt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TOpenTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InContent
    )
  (MarkupCtx
InTagName, ByteClass
BSlash) ->
    if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InClose)
      else (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState Int
s (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InTagName)
  (MarkupCtx
InTagName, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InTagName)
  (MarkupCtx
InAttr, ByteClass
BGt) ->
    ((ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (MarkupToken -> ByteString -> MarkupToken
forall a b. a -> b -> a
P.const MarkupToken
TTagEnd, Int
0, Int
0), Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InContent)
  (MarkupCtx
InAttr, ByteClass
BSlash) ->
    ((ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (MarkupToken -> ByteString -> MarkupToken
forall a b. a -> b -> a
P.const MarkupToken
TSelfClose, Int
0, Int
0), Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InContent)
  (MarkupCtx
InAttr, ByteClass
BSpace) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InAttr)
  (MarkupCtx
InAttr, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InAttr)
  (MarkupCtx
InClose, ByteClass
BGt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TCloseTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> AccState
AccState Int
i Int
0 MarkupCtx
InContent
    )
  (MarkupCtx
InClose, ByteClass
BSpace) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState Int
s Int
l MarkupCtx
InClose)
  (MarkupCtx
InClose, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InClose)
  (MarkupCtx, ByteClass)
_ ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> AccState
AccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
ctx)

-- * Markup lexing

-- | Run markup lexer directly over a ByteString.
--
-- >>> runMarkupLexerBS (C.pack "<p>hi</p>")
-- [TOpenTag "p",TContent "hi",TCloseTag "p"]
runMarkupLexerBS :: ByteString -> [MarkupToken]
runMarkupLexerBS :: ByteString -> [MarkupToken]
runMarkupLexerBS ByteString
bs = Int -> AccState -> [MarkupToken]
go Int
0 (Int -> Int -> MarkupCtx -> AccState
AccState Int
0 Int
0 MarkupCtx
InContent)
  where
    !len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    go :: Int -> AccState -> [MarkupToken]
go !Int
i !AccState
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = []
      | Bool
otherwise =
          let !w :: Word8
w = ByteString -> Int -> Word8
BSU.unsafeIndex ByteString
bs Int
i
              !bc :: ByteClass
bc = MarkupCtx -> Word8 -> ByteClass
classifyByte (AccState -> MarkupCtx
accCtx AccState
acc) Word8
w
              (Maybe (ByteString -> MarkupToken, Int, Int)
emit, !AccState
acc') = AccState
-> ByteClass
-> Int
-> (Maybe (ByteString -> MarkupToken, Int, Int), AccState)
accumStep AccState
acc ByteClass
bc Int
i
           in case Maybe (ByteString -> MarkupToken, Int, Int)
emit of
                Maybe (ByteString -> MarkupToken, Int, Int)
Nothing -> Int -> AccState -> [MarkupToken]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) AccState
acc'
                Just (ByteString -> MarkupToken
con, Int
s, Int
l) ->
                  let !tok :: MarkupToken
tok =
                        if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                          then ByteString -> MarkupToken
con ByteString
BS.empty
                          else ByteString -> MarkupToken
con (Int -> ByteString -> ByteString
BSU.unsafeTake Int
l (Int -> ByteString -> ByteString
BSU.unsafeDrop Int
s ByteString
bs))
                   in MarkupToken
tok MarkupToken -> [MarkupToken] -> [MarkupToken]
forall a. a -> [a] -> [a]
: Int -> AccState -> [MarkupToken]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) AccState
acc'

-- | Offset-tracking accumulator state for the Traced pipeline.
data OAccState = OAccState
  { OAccState -> Int
_oStart :: {-# UNPACK #-} !Int,
    OAccState -> Int
_oLen :: {-# UNPACK #-} !Int,
    OAccState -> MarkupCtx
oCtx :: !MarkupCtx
  }

-- | Step the offset accumulator.
oAccumStep ::
  OAccState ->
  (ByteClass, Int, MarkupCtx) ->
  (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
oAccumStep :: OAccState
-> (ByteClass, Int, MarkupCtx)
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
oAccumStep (OAccState !Int
s !Int
l !MarkupCtx
ctx) (ByteClass
bc, !Int
i, MarkupCtx
_) = case (MarkupCtx
ctx, ByteClass
bc) of
  (MarkupCtx
InContent, ByteClass
BLt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TContent, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InTagName
    )
  (MarkupCtx
InContent, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InContent)
  (MarkupCtx
InTagName, ByteClass
BSpace) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TOpenTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InAttr
    )
  (MarkupCtx
InTagName, ByteClass
BGt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TOpenTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InContent
    )
  (MarkupCtx
InTagName, ByteClass
BSlash) ->
    if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InClose)
      else (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState Int
s (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InTagName)
  (MarkupCtx
InTagName, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InTagName)
  (MarkupCtx
InAttr, ByteClass
BGt) ->
    ((ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (MarkupToken -> ByteString -> MarkupToken
forall a b. a -> b -> a
P.const MarkupToken
TTagEnd, Int
0, Int
0), Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InContent)
  (MarkupCtx
InAttr, ByteClass
BSlash) ->
    ((ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (MarkupToken -> ByteString -> MarkupToken
forall a b. a -> b -> a
P.const MarkupToken
TSelfClose, Int
0, Int
0), Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InContent)
  (MarkupCtx
InAttr, ByteClass
BSpace) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InAttr)
  (MarkupCtx
InAttr, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InAttr)
  (MarkupCtx
InClose, ByteClass
BGt) ->
    ( if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing else (ByteString -> MarkupToken, Int, Int)
-> Maybe (ByteString -> MarkupToken, Int, Int)
forall a. a -> Maybe a
Just (ByteString -> MarkupToken
TCloseTag, Int
s, Int
l),
      Int -> Int -> MarkupCtx -> OAccState
OAccState Int
i Int
0 MarkupCtx
InContent
    )
  (MarkupCtx
InClose, ByteClass
BSpace) -> (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState Int
s Int
l MarkupCtx
InClose)
  (MarkupCtx
InClose, ByteClass
_) ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
InClose)
  (MarkupCtx, ByteClass)
_ ->
    (Maybe (ByteString -> MarkupToken, Int, Int)
forall a. Maybe a
Nothing, Int -> Int -> MarkupCtx -> OAccState
OAccState (if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
i else Int
s) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MarkupCtx
ctx)

stage1S :: (WI, OAccState) -> ((ByteClass, Int), OAccState)
stage1S :: (WI, OAccState) -> ((ByteClass, Int), OAccState)
stage1S (WI Word8
w Int
i, OAccState
acc) = ((MarkupCtx -> Word8 -> ByteClass
classifyByte (OAccState -> MarkupCtx
oCtx OAccState
acc) Word8
w, Int
i), OAccState
acc)

stage2S :: ((ByteClass, Int), OAccState) -> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stage2S :: ((ByteClass, Int), OAccState)
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stage2S ((ByteClass
bc, Int
i), OAccState
acc) = OAccState
-> (ByteClass, Int, MarkupCtx)
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
oAccumStep OAccState
acc (ByteClass
bc, Int
i, OAccState -> MarkupCtx
oCtx OAccState
acc)

-- | Compiled step function.
stepMarkupS :: WI -> OAccState -> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stepMarkupS :: WI
-> OAccState
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stepMarkupS WI
wi OAccState
acc = ((ByteClass, Int), OAccState)
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stage2S ((WI, OAccState) -> ((ByteClass, Int), OAccState)
stage1S (WI
wi, OAccState
acc))

-- | Initial accumulator state.
initOAccState :: OAccState
initOAccState :: OAccState
initOAccState = Int -> Int -> MarkupCtx -> OAccState
OAccState Int
0 Int
0 MarkupCtx
InContent

-- | Run via Traced (->) State pipeline.
--
-- The state-machine view is: each input byte is classified ('classifyByte'),
-- paired with its offset and the current context, and fed to 'oAccumStep'.
-- 'stepMarkupS' compiles this to @WI -> OAccState -> (Maybe ..., OAccState)@,
-- the shape of a single step in a traced iteration. 'runMarkupStateBS'
-- unwinds that step over the input.
runMarkupStateBS :: ByteString -> [MarkupToken]
runMarkupStateBS :: ByteString -> [MarkupToken]
runMarkupStateBS ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = []
  | Bool
otherwise =
      let !w0 :: Word8
w0 = ByteString -> Word8
BSU.unsafeHead ByteString
bs
          (Maybe (ByteString -> MarkupToken, Int, Int)
mEmit, !OAccState
s0) = WI
-> OAccState
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stepMarkupS (Word8 -> Int -> WI
WI Word8
w0 Int
0) OAccState
initOAccState
          toks0 :: [MarkupToken]
toks0 = case Maybe (ByteString -> MarkupToken, Int, Int)
mEmit of
            Maybe (ByteString -> MarkupToken, Int, Int)
Nothing -> []
            Just (ByteString -> MarkupToken
con, Int
start, Int
len) -> [(ByteString -> MarkupToken) -> Int -> Int -> MarkupToken
mkTok ByteString -> MarkupToken
con Int
start Int
len]
       in [MarkupToken]
toks0 [MarkupToken] -> [MarkupToken] -> [MarkupToken]
forall a. [a] -> [a] -> [a]
++ OAccState -> Int -> ByteString -> [MarkupToken]
go OAccState
s0 Int
1 (ByteString -> ByteString
BSU.unsafeTail ByteString
bs)
  where
    go :: OAccState -> Int -> ByteString -> [MarkupToken]
go !OAccState
acc !Int
i ByteString
bs'
      | ByteString -> Bool
BS.null ByteString
bs' = []
      | Bool
otherwise =
          let !w :: Word8
w = ByteString -> Word8
BSU.unsafeHead ByteString
bs'
              (Maybe (ByteString -> MarkupToken, Int, Int)
mEmit, !OAccState
acc') = WI
-> OAccState
-> (Maybe (ByteString -> MarkupToken, Int, Int), OAccState)
stepMarkupS (Word8 -> Int -> WI
WI Word8
w Int
i) OAccState
acc
           in case Maybe (ByteString -> MarkupToken, Int, Int)
mEmit of
                Maybe (ByteString -> MarkupToken, Int, Int)
Nothing ->
                  OAccState -> Int -> ByteString -> [MarkupToken]
go OAccState
acc' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (ByteString -> ByteString
BSU.unsafeTail ByteString
bs')
                Just (ByteString -> MarkupToken
con, Int
start, Int
len) ->
                  (ByteString -> MarkupToken) -> Int -> Int -> MarkupToken
mkTok ByteString -> MarkupToken
con Int
start Int
len MarkupToken -> [MarkupToken] -> [MarkupToken]
forall a. a -> [a] -> [a]
: OAccState -> Int -> ByteString -> [MarkupToken]
go OAccState
acc' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (ByteString -> ByteString
BSU.unsafeTail ByteString
bs')
    mkTok :: (ByteString -> MarkupToken) -> Int -> Int -> MarkupToken
mkTok ByteString -> MarkupToken
con Int
start Int
len
      | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ByteString -> MarkupToken
con ByteString
BS.empty
      | Bool
otherwise = ByteString -> MarkupToken
con (Int -> ByteString -> ByteString
BSU.unsafeTake Int
len (Int -> ByteString -> ByteString
BSU.unsafeDrop Int
start ByteString
bs))