{-|
This module implements a `Parser` supporting a reader environment and custom error types.  If you
need efficient indentation parsing, use "FlatParse.Stateful" instead.
-}

module FlatParse.Basic (
  -- * Parser types and constructors
    type Parser(..)
  , type Res#
  , pattern OK#
  , pattern Fail#
  , pattern Err#
  , Result(..)

  -- * Running parsers
  , runParser
  , runParserS

  -- * Reader environment
  , ask
  , local

  -- * Errors and failures
  , empty
  , err
  , lookahead
  , fails
  , try
  , optional
  , optioned
  , cut
  , cutting

  -- * Basic lexing and parsing
  , eof
  , char
  , byte
  , bytes
  , string
  , switch
  , switchWithPost
  , rawSwitchWithPost
  , satisfy
  , satisfyASCII
  , satisfyASCII_
  , fusedSatisfy
  , anyWord8
  , anyWord16
  , anyWord32
  , anyWord
  , anyChar
  , anyChar_
  , anyCharASCII
  , anyCharASCII_
  , isDigit
  , isGreekLetter
  , isLatinLetter

  -- * Combinators
  , (<|>)
  , branch
  , chainl
  , chainr
  , many
  , many_
  , some
  , some_
  , notFollowedBy

  -- * Positions and spans
  , Pos(..)
  , Span(..)
  , getPos
  , setPos
  , endPos
  , spanOf
  , spanned
  , byteStringOf
  , byteStringed
  , inSpan

  -- ** Position and span conversions
  , validPos
  , posLineCols
  , unsafeSpanToByteString
  , mkPos
  , FlatParse.Basic.lines

  -- * Getting the rest of the input
  , takeLine
  , traceLine
  , takeRest
  , traceRest

  -- * Internal functions
  , ensureBytes#
  , scan8#
  , scan16#
  , scan32#
  , scan64#
  , scanAny8#
  , scanBytes#
  , setBack#
  , packUTF8

  ) where

import Control.Monad
import Data.Bits
import Data.Char (ord)
import Data.Foldable
import Data.List (sortBy)
import Data.Map (Map)
import Data.Ord (comparing)
import Data.Word
import GHC.Exts
import GHC.Word
import GHC.ForeignPtr
import Language.Haskell.TH
import System.IO.Unsafe

import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Internal as B
import qualified Data.Map.Strict as M


--------------------------------------------------------------------------------

-- | Primitive result of a parser. Possible results are given by `OK#`, `Err#` and `Fail#`
--   pattern synonyms.
type Res# e a =
  (#
    (# a, Addr# #)
  | (# #)
  | (# e #)
  #)

-- | Contains return value and a pointer to the rest of the input buffer.
pattern OK# :: a -> Addr# -> Res# e a
pattern $bOK# :: a -> Addr# -> Res# e a
$mOK# :: forall r a e. Res# e a -> (a -> Addr# -> r) -> (Void# -> r) -> r
OK# a s = (# (# a, s #) | | #)

-- | Constructor for errors which are by default non-recoverable.
pattern Err# :: e -> Res# e a
pattern $bErr# :: e -> Res# e a
$mErr# :: forall r e a. Res# e a -> (e -> r) -> (Void# -> r) -> r
Err# e = (# | | (# e #) #)

-- | Constructor for recoverable failure.
pattern Fail# :: Res# e a
pattern $bFail# :: Void# -> forall e a. Res# e a
$mFail# :: forall r e a. Res# e a -> (Void# -> r) -> (Void# -> r) -> r
Fail# = (# | (# #) | #)
{-# complete OK#, Err#, Fail# #-}

-- | @Parser r e a@ has a reader environment @r@, an error type @e@ and a return type @a@.
newtype Parser r e a = Parser {Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# :: ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a}

instance Functor (Parser r e) where
  fmap :: (a -> b) -> Parser r e a -> Parser r e b
fmap a -> b
f (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s -> let !b :: b
b = a -> b
f a
a in b -> Addr# -> Res# e b
forall a e. a -> Addr# -> Res# e a
OK# b
b Addr#
s
    Res# e a
x       -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
  {-# inline fmap #-}

  <$ :: a -> Parser r e b -> Parser r e a
(<$) a
a' (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
g) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
g ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# b
a Addr#
s -> a -> Addr# -> Res# e a
forall a e. a -> Addr# -> Res# e a
OK# a
a' Addr#
s
    Res# e b
x       -> Res# e b -> Res# e a
unsafeCoerce# Res# e b
x
  {-# inline (<$) #-}

instance Applicative (Parser r e) where
  pure :: a -> Parser r e a
pure a
a = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> a -> Addr# -> Res# e a
forall a e. a -> Addr# -> Res# e a
OK# a
a Addr#
s
  {-# inline pure #-}
  Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e (a -> b)
ff <*> :: Parser r e (a -> b) -> Parser r e a -> Parser r e b
<*> Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e (a -> b)
ff ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a -> b
f Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
      OK# a
a Addr#
s  -> let !b :: b
b = a -> b
f a
a in b -> Addr# -> Res# e b
forall a e. a -> Addr# -> Res# e a
OK# b
b Addr#
s
      Res# e a
x        -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
    Res# e (a -> b)
x -> Res# e (a -> b) -> Res# e b
unsafeCoerce# Res# e (a -> b)
x
  {-# inline (<*>) #-}
  Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa <* :: Parser r e a -> Parser r e b -> Parser r e a
<* Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s   -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
      OK# b
b Addr#
s -> a -> Addr# -> Res# e a
forall a e. a -> Addr# -> Res# e a
OK# a
a Addr#
s
      Res# e b
x -> Res# e b -> Res# e a
unsafeCoerce# Res# e b
x
    Res# e a
x -> Res# e a -> Res# e a
unsafeCoerce# Res# e a
x
  {-# inline (<*) #-}
  Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa *> :: Parser r e a -> Parser r e b -> Parser r e b
*> Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s -> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb ForeignPtrContents
fp r
r Addr#
eob Addr#
s
    Res# e a
x       -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
  {-# inline (*>) #-}

instance Monad (Parser r e) where
  return :: a -> Parser r e a
return = a -> Parser r e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# inline return #-}
  Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa >>= :: Parser r e a -> (a -> Parser r e b) -> Parser r e b
>>= a -> Parser r e b
f = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# (a -> Parser r e b
f a
a) ForeignPtrContents
fp r
r Addr#
eob Addr#
s
    Res# e a
x       -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
  {-# inline (>>=) #-}
  Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa >> :: Parser r e a -> Parser r e b -> Parser r e b
>> Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
fa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s -> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
fb ForeignPtrContents
fp r
r Addr#
eob Addr#
s
    Res# e a
x       -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
  {-# inline (>>) #-}

-- | Higher-level boxed data type for parsing results.
data Result e a =
    OK a !(B.ByteString)  -- ^ Contains return value and unconsumed input.
  | Fail                  -- ^ Recoverable-by-default failure.
  | Err !e                -- ^ Unrecoverble-by-default error.
  deriving Int -> Result e a -> ShowS
[Result e a] -> ShowS
Result e a -> String
(Int -> Result e a -> ShowS)
-> (Result e a -> String)
-> ([Result e a] -> ShowS)
-> Show (Result e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show a, Show e) => Int -> Result e a -> ShowS
forall e a. (Show a, Show e) => [Result e a] -> ShowS
forall e a. (Show a, Show e) => Result e a -> String
showList :: [Result e a] -> ShowS
$cshowList :: forall e a. (Show a, Show e) => [Result e a] -> ShowS
show :: Result e a -> String
$cshow :: forall e a. (Show a, Show e) => Result e a -> String
showsPrec :: Int -> Result e a -> ShowS
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> Result e a -> ShowS
Show

instance Functor (Result e) where
  fmap :: (a -> b) -> Result e a -> Result e b
fmap a -> b
f (OK a
a ByteString
s) = let !b :: b
b = a -> b
f a
a in b -> ByteString -> Result e b
forall e a. a -> ByteString -> Result e a
OK b
b ByteString
s
  fmap a -> b
f Result e a
Fail     = Result e b
forall e a. Result e a
Fail
  fmap a -> b
f (Err e
e)  = e -> Result e b
forall e a. e -> Result e a
Err e
e
  {-# inline fmap #-}

--------------------------------------------------------------------------------

-- | Run a parser.
runParser :: Parser r e a -> r -> B.ByteString -> Result e a
runParser :: Parser r e a -> r -> ByteString -> Result e a
runParser (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) r
r b :: ByteString
b@(B.PS (ForeignPtr Addr#
_ ForeignPtrContents
fp) Int
_ (I# Int#
len)) = IO (Result e a) -> Result e a
forall a. IO a -> a
unsafeDupablePerformIO do
  ByteString -> (CString -> IO (Result e a)) -> IO (Result e a)
forall a. ByteString -> (CString -> IO a) -> IO a
B.unsafeUseAsCString ByteString
b \(Ptr Addr#
buf) -> do
    let end :: Addr#
end = Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
len
    case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
end Addr#
buf of
      Err# e
e ->
        Result e a -> IO (Result e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Result e a
forall e a. e -> Result e a
Err e
e)
      OK# a
a Addr#
s -> do
        let offset :: Int#
offset = Addr# -> Addr# -> Int#
minusAddr# Addr#
s Addr#
buf
        Result e a -> IO (Result e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ByteString -> Result e a
forall e a. a -> ByteString -> Result e a
OK a
a (Int -> ByteString -> ByteString
B.drop (Int# -> Int
I# Int#
offset) ByteString
b))
      Res# e a
Fail# ->
        Result e a -> IO (Result e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result e a
forall e a. Result e a
Fail
{-# noinline runParser #-}

-- | Run a parser on a `String` input. Reminder: @OverloadedStrings@ for `B.ByteString` does not
--   yield a valid UTF-8 encoding! For non-ASCII `B.ByteString` literal input, use `runParserS` or
--   `packUTF8` for testing.
runParserS :: Parser r e a -> r -> String -> Result e a
runParserS :: Parser r e a -> r -> String -> Result e a
runParserS Parser r e a
pa r
r String
s = Parser r e a -> r -> ByteString -> Result e a
forall r e a. Parser r e a -> r -> ByteString -> Result e a
runParser Parser r e a
pa r
r (String -> ByteString
packUTF8 String
s)

--------------------------------------------------------------------------------

-- | Query the read-only environment.
ask :: Parser r e r
ask :: Parser r e r
ask = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e r)
-> Parser r e r
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> r -> Addr# -> Res# e r
forall a e. a -> Addr# -> Res# e a
OK# r
r Addr#
s
{-# inline ask #-}

-- | Run a parser in a modified environment.
local :: (r' -> r) -> Parser r e a -> Parser r' e a
local :: (r' -> r) -> Parser r e a -> Parser r' e a
local r' -> r
f (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g) = (ForeignPtrContents -> r' -> Addr# -> Addr# -> Res# e a)
-> Parser r' e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r'
r Addr#
eob Addr#
s -> let!r' :: r
r' = r' -> r
f r'
r in ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g ForeignPtrContents
fp r
r' Addr#
eob Addr#
s
{-# inline local #-}


--------------------------------------------------------------------------------

-- | The failing parser. By default, parser choice `(<|>)` arbitrarily backtracks
--   on parser failure.
empty :: Parser r e a
empty :: Parser r e a
empty = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> Res# e a
forall e a. Res# e a
Fail#
{-# inline empty #-}

-- | Throw a parsing error. By default, parser choice `(<|>)` can't backtrack
--   on parser error. Use `try` to convert an error to a recoverable failure.
err :: e -> Parser r e a
err :: e -> Parser r e a
err e
e = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> e -> Res# e a
forall e a. e -> Res# e a
Err# e
e
{-# inline err #-}

-- | Save the parsing state, then run a parser, then restore the state.
lookahead :: Parser r e a -> Parser r e a
lookahead :: Parser r e a -> Parser r e a
lookahead (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
_ -> a -> Addr# -> Res# e a
forall a e. a -> Addr# -> Res# e a
OK# a
a Addr#
s
    Res# e a
x       -> Res# e a
x
{-# inline lookahead #-}

-- | Convert a parsing failure to a success.
fails :: Parser r e a -> Parser r e ()
fails :: Parser r e a -> Parser r e ()
fails (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
_ Addr#
_ -> Res# e ()
forall e a. Res# e a
Fail#
    Res# e a
Fail#   -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () Addr#
s
    Err# e
e  -> e -> Res# e ()
forall e a. e -> Res# e a
Err# e
e
{-# inline fails #-}

-- | Convert a parsing error into failure.
try :: Parser r e a -> Parser r e a
try :: Parser r e a -> Parser r e a
try (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  Err# e
_ -> Res# e a
forall e a. Res# e a
Fail#
  Res# e a
x      -> Res# e a
x
{-# inline try #-}

-- | Convert a parsing failure to a `Maybe`. If possible, use `optioned` instead.
optional :: Parser r e a -> Parser r e (Maybe a)
optional :: Parser r e a -> Parser r e (Maybe a)
optional Parser r e a
p = (a -> Maybe a
forall k1. k1 -> Maybe k1
Just (a -> Maybe a) -> Parser r e a -> Parser r e (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e a
p) Parser r e (Maybe a)
-> Parser r e (Maybe a) -> Parser r e (Maybe a)
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> Maybe a -> Parser r e (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall k1. Maybe k1
Nothing
{-# inline optional #-}

-- | CPS'd version of `optional`. This is usually more efficient, since it gets rid of the
--   extra `Maybe` allocation.
optioned :: Parser r e a -> (a -> Parser r e b) -> Parser r e b -> Parser r e b
optioned :: Parser r e a -> (a -> Parser r e b) -> Parser r e b -> Parser r e b
optioned (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) a -> Parser r e b
just (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
nothing) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
a Addr#
s -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# (a -> Parser r e b
just a
a) ForeignPtrContents
fp r
r Addr#
eob Addr#
s
  Res# e a
Fail#   -> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
nothing ForeignPtrContents
fp r
r Addr#
eob Addr#
s
  Err# e
e  -> e -> Res# e b
forall e a. e -> Res# e a
Err# e
e
{-# inline optioned #-}

-- | Convert a parsing failure to an error.
cut :: Parser r e a -> e -> Parser r e a
cut :: Parser r e a -> e -> Parser r e a
cut (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) e
e = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  Res# e a
Fail# -> e -> Res# e a
forall e a. e -> Res# e a
Err# e
e
  Res# e a
x     -> Res# e a
x
{-# inline cut #-}

-- | Run the parser, if we get a failure, throw the given error, but if we get an error, merge the
--   inner and the newly given errors using the @e -> e -> e@ function. This can be useful for
--   implementing parsing errors which may propagate hints or accummulate contextual information.
cutting :: Parser r e a -> e -> (e -> e -> e) -> Parser r e a
cutting :: Parser r e a -> e -> (e -> e -> e) -> Parser r e a
cutting (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) e
e e -> e -> e
merge = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  Res# e a
Fail#   -> e -> Res# e a
forall e a. e -> Res# e a
Err# e
e
  Err# e
e' -> let !e'' :: e
e'' = e -> e -> e
merge e
e' e
e in e -> Res# e a
forall e a. e -> Res# e a
Err# e
e''
  Res# e a
x       -> Res# e a
x
{-# inline cutting #-}

--------------------------------------------------------------------------------


-- | Succeed if the input is empty.
eof :: Parser r e ()
eof :: Parser r e ()
eof = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
s of
  Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () Addr#
s
  Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline eof #-}

-- | Parse a UTF-8 character literal. This is a template function, you can use it as
--   @$(char \'x\')@, for example, and the splice in this case has type @Parser r e ()@.
char :: Char -> Q Exp
char :: Char -> Q Exp
char Char
c = String -> Q Exp
string [Char
c]

-- | Read a `Word8`.
byte :: Word8 -> Parser r e ()
byte :: Word8 -> Parser r e ()
byte (W8# Word#
w) = Int -> Parser r e ()
forall r e. Int -> Parser r e ()
ensureBytes# Int
1 Parser r e () -> Parser r e () -> Parser r e ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word -> Parser r e ()
forall r e. Word -> Parser r e ()
scan8# (Word# -> Word
W# Word#
w)
{-# inline byte #-}

-- | Read a sequence of bytes. This is a template function, you can use it as @$(bytes [3, 4, 5])@,
--   for example, and the splice has type @Parser r e ()@.
bytes :: [Word8] -> Q Exp
bytes :: [Word8] -> Q Exp
bytes [Word8]
bytes = do
  let !len :: Int
len = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
bytes
  [| ensureBytes# len >> $(scanBytes# bytes) |]

-- | Parse a UTF-8 string literal. This is a template function, you can use it as @$(string "foo")@,
--   for example, and the splice has type @Parser r e ()@.
string :: String -> Q Exp
string :: String -> Q Exp
string String
str = [Word8] -> Q Exp
bytes (String -> [Word8]
strToBytes String
str)

{-|
This is a template function which makes it possible to branch on a collection of string literals in
an efficient way. By using `switch`, such branching is compiled to a trie of primitive parsing
operations, which has optimized control flow, vectorized reads and grouped checking for needed input
bytes.

The syntax is slightly magical, it overloads the usual @case@ expression. An example:

@
    $(switch [| case _ of
        "foo" -> pure True
        "bar" -> pure False |])
@

The underscore is mandatory in @case _ of@. Each branch must be a string literal, but optionally
we may have a default case, like in

@
    $(switch [| case _ of
        "foo" -> pure 10
        "bar" -> pure 20
        _     -> pure 30 |])
@

All case right hand sides must be parsers with the same type. That type is also the type
of the whole `switch` expression.

A `switch` has longest match semantics, and the order of cases does not matter, except for
the default case, which may only appear as the last case.

If a `switch` does not have a default case, and no case matches the input, then it returns with
failure, \without\ having consumed any input. A fallthrough to the default case also does not
consume any input.
-}
switch :: Q Exp -> Q Exp
switch :: Q Exp -> Q Exp
switch = Maybe (Q Exp) -> Q Exp -> Q Exp
switchWithPost Maybe (Q Exp)
forall k1. Maybe k1
Nothing

{-|
Switch expression with an optional first argument for performing a post-processing action after
every successful branch matching. For example, if we have @ws :: Parser r e ()@ for a
whitespace parser, we might want to consume whitespace after matching on any of the switch
cases. For that case, we can define a "lexeme" version of `switch` as follows.

@
  switch' :: Q Exp -> Q Exp
  switch' = switchWithPost (Just [| ws |])
@

Note that this @switch'@ function cannot be used in the same module it's defined in, because of the
stage restriction of Template Haskell.
-}
switchWithPost :: Maybe (Q Exp) -> Q Exp -> Q Exp
switchWithPost :: Maybe (Q Exp) -> Q Exp -> Q Exp
switchWithPost Maybe (Q Exp)
postAction Q Exp
exp = do
  !Maybe Exp
postAction <- Maybe (Q Exp) -> Q (Maybe Exp)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Maybe (Q Exp)
postAction
  (![(String, Exp)]
cases, !Maybe Exp
fallback) <- Q Exp -> Q ([(String, Exp)], Maybe Exp)
parseSwitch Q Exp
exp
  (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int)) -> Q Exp
genTrie ((Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int)) -> Q Exp)
-> (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int))
-> Q Exp
forall a b. (a -> b) -> a -> b
$! Maybe Exp
-> [(String, Exp)]
-> Maybe Exp
-> (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int))
genSwitchTrie' Maybe Exp
postAction [(String, Exp)]
cases Maybe Exp
fallback

-- | Version of `switchWithPost` without syntactic sugar. The second argument is the
--   list of cases, the third is the default case.
rawSwitchWithPost :: Maybe (Q Exp) -> [(String, Q Exp)] -> Maybe (Q Exp) -> Q Exp
rawSwitchWithPost :: Maybe (Q Exp) -> [(String, Q Exp)] -> Maybe (Q Exp) -> Q Exp
rawSwitchWithPost Maybe (Q Exp)
postAction [(String, Q Exp)]
cases Maybe (Q Exp)
fallback = do
  !Maybe Exp
postAction <- Maybe (Q Exp) -> Q (Maybe Exp)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Maybe (Q Exp)
postAction
  ![(String, Exp)]
cases <- [(String, Q Exp)]
-> ((String, Q Exp) -> Q (String, Exp)) -> Q [(String, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Q Exp)]
cases \(String
str, Q Exp
rhs) -> (String
str,) (Exp -> (String, Exp)) -> Q Exp -> Q (String, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
rhs
  !Maybe Exp
fallback <- Maybe (Q Exp) -> Q (Maybe Exp)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Maybe (Q Exp)
fallback
  (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int)) -> Q Exp
genTrie ((Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int)) -> Q Exp)
-> (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int))
-> Q Exp
forall a b. (a -> b) -> a -> b
$! Maybe Exp
-> [(String, Exp)]
-> Maybe Exp
-> (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int))
genSwitchTrie' Maybe Exp
postAction [(String, Exp)]
cases Maybe Exp
fallback

-- | Parse a UTF-8 `Char` for which a predicate holds.
satisfy :: (Char -> Bool) -> Parser r e Char
satisfy :: (Char -> Bool) -> Parser r e Char
satisfy Char -> Bool
f = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Char)
-> Parser r e Char
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case Parser r Any Char
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# Any Char
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# Parser r Any Char
forall r e. Parser r e Char
anyChar ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# Char
c Addr#
s | Char -> Bool
f Char
c -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# Char
c Addr#
s
  Res# Any Char
_             -> Res# e Char
forall e a. Res# e a
Fail#
{-#  inline satisfy #-}

-- | Parse an ASCII `Char` for which a predicate holds. Assumption: the predicate must only return
--   `True` for ASCII-range characters. Otherwise this function might read a 128-255 range byte,
--   thereby breaking UTF-8 decoding.
satisfyASCII :: (Char -> Bool) -> Parser r e Char
satisfyASCII :: (Char -> Bool) -> Parser r e Char
satisfyASCII Char -> Bool
f = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Char)
-> Parser r e Char
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
s of
  Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Char#
derefChar8# Addr#
s of
    Char#
c1 | Char -> Bool
f (Char# -> Char
C# Char#
c1) -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# Char#
c1) (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
1#)
       | Bool
otherwise -> Res# e Char
forall e a. Res# e a
Fail#
{-#  inline satisfyASCII #-}

-- | Parse an ASCII `Char` for which a predicate holds.
satisfyASCII_ :: (Char -> Bool) -> Parser r e ()
satisfyASCII_ :: (Char -> Bool) -> Parser r e ()
satisfyASCII_ Char -> Bool
f = () () -> Parser r e Char -> Parser r e ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser r e Char
forall r e. (Char -> Bool) -> Parser r e Char
satisfyASCII Char -> Bool
f
{-# inline satisfyASCII_ #-}

-- | This is a variant of `satisfy` which allows more optimization. We can pick four testing
--   functions for the four cases for the possible number of bytes in the UTF-8 character. So in
--   @fusedSatisfy f1 f2 f3 f4@, if we read a one-byte character, the result is scrutinized with
--   @f1@, for two-bytes, with @f2@, and so on. This can result in dramatic lexing speedups.
--
--   For example, if we want to accept any letter, the naive solution would be to use
--   `Data.Char.isLetter`, but this accesses a large lookup table of Unicode character classes. We
--   can do better with @fusedSatisfy isLatinLetter isLetter isLetter isLetter@, since here the
--   `isLatinLetter` is inlined into the UTF-8 decoding, and it probably handles a great majority of
--   all cases without accessing the character table.
fusedSatisfy :: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool) -> Parser r e Char
fusedSatisfy :: (Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> Parser r e Char
fusedSatisfy Char -> Bool
f1 Char -> Bool
f2 Char -> Bool
f3 Char -> Bool
f4 = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Char)
-> Parser r e Char
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Char#
derefChar8# Addr#
buf of
    Char#
c1 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\x7F'# of
      Int#
1# | Char -> Bool
f1 (Char# -> Char
C# Char#
c1) -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# Char#
c1) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#)
         | Bool
otherwise  -> Res# e Char
forall e a. Res# e a
Fail#
      Int#
_  -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#) of
        Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
        Int#
_ -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
1# of
          Char#
c2 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xDF'# of
            Int#
1# ->
              let resc :: Char
resc = Char# -> Char
C# (Int# -> Char#
chr# (((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xC0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
6#) Int# -> Int# -> Int#
`orI#`
                                   (Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#)))
              in case Char -> Bool
f2 Char
resc of
                   Bool
True -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# Char
resc (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#)
                   Bool
_    -> Res# e Char
forall e a. Res# e a
Fail#
            Int#
_ -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#) of
              Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
              Int#
_  -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
2# of
                Char#
c3 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xEF'# of
                  Int#
1# ->
                    let resc :: Char
resc = Char# -> Char
C# (Int# -> Char#
chr# (((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xE0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
`orI#`
                                         ((Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#`  Int#
6#) Int# -> Int# -> Int#
`orI#`
                                         (Char# -> Int#
ord# Char#
c3 Int# -> Int# -> Int#
-# Int#
0x80#)))
                    in case Char -> Bool
f3 Char
resc of
                         Bool
True -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# Char
resc (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
3#)
                         Bool
_    -> Res# e Char
forall e a. Res# e a
Fail#
                  Int#
_ -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
3#) of
                    Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
                    Int#
_  -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
3# of
                      Char#
c4 ->
                        let resc :: Char
resc = Char# -> Char
C# (Int# -> Char#
chr# (((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xF0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
18#) Int# -> Int# -> Int#
`orI#`
                                             ((Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
`orI#`
                                             ((Char# -> Int#
ord# Char#
c3 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#`  Int#
6#) Int# -> Int# -> Int#
`orI#`
                                              (Char# -> Int#
ord# Char#
c4 Int# -> Int# -> Int#
-# Int#
0x80#)))
                        in case Char -> Bool
f4 Char
resc of
                             Bool
True -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# Char
resc (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
4#)
                             Bool
_    -> Res# e Char
forall e a. Res# e a
Fail#
{-# inline fusedSatisfy #-}

-- | Parse any `Word8`.
anyWord8 :: Parser r e Word8
anyWord8 :: Parser r e Word8
anyWord8 = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Word8)
-> Parser r e Word8
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Word8
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
buf Int#
0# of
    Word#
w -> Word8 -> Addr# -> Res# e Word8
forall a e. a -> Addr# -> Res# e a
OK# (Word# -> Word8
W8# Word#
w) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#)
{-# inline anyWord8 #-}

-- | Parse any `Word16`.
anyWord16 :: Parser r e Word16
anyWord16 :: Parser r e Word16
anyWord16 = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Word16)
-> Parser r e Word16
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Word16
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Int# -> Word#
indexWord16OffAddr# Addr#
buf Int#
0# of
    Word#
w -> Word16 -> Addr# -> Res# e Word16
forall a e. a -> Addr# -> Res# e a
OK# (Word# -> Word16
W16# Word#
w) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#)
{-# inline anyWord16 #-}

-- | Parse any `Word32`.
anyWord32 :: Parser r e Word32
anyWord32 :: Parser r e Word32
anyWord32 = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Word32)
-> Parser r e Word32
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Word32
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Int# -> Word#
indexWord32OffAddr# Addr#
buf Int#
0# of
    Word#
w -> Word32 -> Addr# -> Res# e Word32
forall a e. a -> Addr# -> Res# e a
OK# (Word# -> Word32
W32# Word#
w) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
4#)
{-# inline anyWord32 #-}

-- | Parse any `Word`.
anyWord :: Parser r e Word
anyWord :: Parser r e Word
anyWord = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Word)
-> Parser r e Word
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Word
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Int# -> Word#
indexWordOffAddr# Addr#
buf Int#
0# of
    Word#
w -> Word -> Addr# -> Res# e Word
forall a e. a -> Addr# -> Res# e a
OK# (Word# -> Word
W# Word#
w) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
8#)
{-# inline anyWord #-}

-- | Parse any UTF-8-encoded `Char`.
anyChar :: Parser r e Char
anyChar :: Parser r e Char
anyChar = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Char)
-> Parser r e Char
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Char#
derefChar8# Addr#
buf of
    Char#
c1 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\x7F'# of
      Int#
1# -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# Char#
c1) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#)
      Int#
_  -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#) of
        Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
        Int#
_ -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
1# of
          Char#
c2 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xDF'# of
            Int#
1# ->
              let resc :: Int#
resc = ((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xC0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
6#) Int# -> Int# -> Int#
`orI#`
                          (Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#)
              in Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# (Int# -> Char#
chr# Int#
resc)) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#)
            Int#
_ -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#) of
              Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
              Int#
_  -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
2# of
                Char#
c3 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xEF'# of
                  Int#
1# ->
                    let resc :: Int#
resc = ((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xE0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
`orI#`
                               ((Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#`  Int#
6#) Int# -> Int# -> Int#
`orI#`
                                (Char# -> Int#
ord# Char#
c3 Int# -> Int# -> Int#
-# Int#
0x80#)
                    in Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# (Int# -> Char#
chr# Int#
resc)) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
3#)
                  Int#
_ -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
3#) of
                    Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
                    Int#
_  -> case Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
buf Int#
3# of
                      Char#
c4 ->
                        let resc :: Int#
resc = ((Char# -> Int#
ord# Char#
c1 Int# -> Int# -> Int#
-# Int#
0xF0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
18#) Int# -> Int# -> Int#
`orI#`
                                   ((Char# -> Int#
ord# Char#
c2 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
`orI#`
                                   ((Char# -> Int#
ord# Char#
c3 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#`  Int#
6#) Int# -> Int# -> Int#
`orI#`
                                    (Char# -> Int#
ord# Char#
c4 Int# -> Int# -> Int#
-# Int#
0x80#)
                        in Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# (Int# -> Char#
chr# Int#
resc)) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
4#)
{-# inline anyChar #-}

-- | Skip any UTF-8-encoded `Char`.
anyChar_ :: Parser r e ()
anyChar_ :: Parser r e ()
anyChar_ = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e ()
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Char#
derefChar8# Addr#
buf of
    Char#
c1 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\x7F'# of
      Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#)
      Int#
_  ->
        let buf' :: Addr#
buf' =
              case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xDF'# of
                Int#
1# -> Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
2#
                Int#
_  -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\xEF'# of
                    Int#
1# -> Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
3#
                    Int#
_ ->  Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
4#
        in case Addr# -> Addr# -> Int#
leAddr# Addr#
buf' Addr#
eob of
             Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () Addr#
buf'
             Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline anyChar_ #-}


-- | Parse any `Char` in the ASCII range, fail if the next input character is not in the range.
--   This is more efficient than `anyChar` if we are only working with ASCII.
anyCharASCII :: Parser r e Char
anyCharASCII :: Parser r e Char
anyCharASCII = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Char)
-> Parser r e Char
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
buf -> case Addr# -> Addr# -> Int#
eqAddr# Addr#
eob Addr#
buf of
  Int#
1# -> Res# e Char
forall e a. Res# e a
Fail#
  Int#
_  -> case Addr# -> Char#
derefChar8# Addr#
buf of
    Char#
c1 -> case Char#
c1 Char# -> Char# -> Int#
`leChar#` Char#
'\x7F'# of
      Int#
1# -> Char -> Addr# -> Res# e Char
forall a e. a -> Addr# -> Res# e a
OK# (Char# -> Char
C# Char#
c1) (Addr# -> Int# -> Addr#
plusAddr# Addr#
buf Int#
1#)
      Int#
_  -> Res# e Char
forall e a. Res# e a
Fail#
{-# inline anyCharASCII #-}

-- | Skip any `Char` in the ASCII range. More efficient than `anyChar_` if we're working only with
--   ASCII.
anyCharASCII_ :: Parser r e ()
anyCharASCII_ :: Parser r e ()
anyCharASCII_ = () () -> Parser r e Char -> Parser r e ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser r e Char
forall r e. Parser r e Char
anyCharASCII
{-# inline anyCharASCII_ #-}

-- | @isDigit c = \'0\' <= c && c <= \'9\'@
isDigit :: Char -> Bool
isDigit :: Char -> Bool
isDigit Char
c = Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'
{-# inline isDigit #-}

-- | @isLatinLetter c = (\'A\' <= c && c <= \'Z\') || (\'a\' <= c && c <= \'z\')@
isLatinLetter :: Char -> Bool
isLatinLetter :: Char -> Bool
isLatinLetter Char
c = (Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
|| (Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
{-# inline isLatinLetter #-}

-- | @isGreekLetter c = (\'Α\' <= c && c <= \'Ω\') || (\'α\' <= c && c <= \'ω\')@
isGreekLetter :: Char -> Bool
isGreekLetter :: Char -> Bool
isGreekLetter Char
c = (Char
'Α' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Ω') Bool -> Bool -> Bool
|| (Char
'α' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'ω')
{-# inline isGreekLetter #-}


--------------------------------------------------------------------------------

-- | Choose between two parsers. If the first parser fails, try the second one, but if the first one
--   throws an error, propagate the error.
infixr 6 <|>
(<|>) :: Parser r e a -> Parser r e a -> Parser r e a
<|> :: Parser r e a -> Parser r e a -> Parser r e a
(<|>) (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    Res# e a
Fail# -> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
g ForeignPtrContents
fp r
r Addr#
eob Addr#
s
    Res# e a
x     -> Res# e a
x
{-# inline (<|>) #-}

-- | Branch on a parser: if the first argument fails, continue with the second, else with the third.
--   This can produce slightly more efficient code than `(<|>)`. Moreover, `ḃranch` does not
--   backtrack from the true/false cases.
branch :: Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch :: Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch Parser r e a
pa Parser r e b
pt Parser r e b
pf = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# Parser r e a
pa ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
_ Addr#
s -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# Parser r e b
pt ForeignPtrContents
fp r
r Addr#
eob Addr#
s
  Res# e a
Fail#   -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# Parser r e b
pf ForeignPtrContents
fp r
r Addr#
eob Addr#
s
  Err# e
e  -> e -> Res# e b
forall e a. e -> Res# e a
Err# e
e
{-# inline branch #-}

-- | An analogue of the list `foldl` function: first parse a @b@, then parse zero or more @a@-s,
--   and combine the results in a left-nested way by the @b -> a -> b@ function. Note: this is not
--   the usual `chainl` function from the parsec libraries!
chainl :: (b -> a -> b) -> Parser r e b -> Parser r e a -> Parser r e b
chainl :: (b -> a -> b) -> Parser r e b -> Parser r e a -> Parser r e b
chainl b -> a -> b
f Parser r e b
start Parser r e a
elem = Parser r e b
start Parser r e b -> (b -> Parser r e b) -> Parser r e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> Parser r e b
go where
  go :: b -> Parser r e b
go b
b = do {!a
a <- Parser r e a
elem; b -> Parser r e b
go (b -> Parser r e b) -> b -> Parser r e b
forall a b. (a -> b) -> a -> b
$! b -> a -> b
f b
b a
a} Parser r e b -> Parser r e b -> Parser r e b
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> b -> Parser r e b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
{-# inline chainl #-}

-- | An analogue of the list `foldr` function: parse zero or more @a@-s, terminated by a @b@, and
--   combine the results in a right-nested way using the @a -> b -> b@ function. Note: this is not
--   the usual `chainr` function from the parsec libraries!
chainr :: (a -> b -> b) -> Parser r e a -> Parser r e b -> Parser r e b
chainr :: (a -> b -> b) -> Parser r e a -> Parser r e b -> Parser r e b
chainr a -> b -> b
f Parser r e a
elem Parser r e b
end = Parser r e b
go where
  go :: Parser r e b
go = (a -> b -> b
f (a -> b -> b) -> Parser r e a -> Parser r e (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e a
elem Parser r e (b -> b) -> Parser r e b -> Parser r e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser r e b
go) Parser r e b -> Parser r e b -> Parser r e b
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> Parser r e b
end
{-# inline chainr #-}

-- | Run a parser zero or more times, collect the results in a list. Note: for optimal performance,
--   try to avoid this. Often it is possible to get rid of the intermediate list by using a
--   combinator or a custom parser.
many :: Parser r e a -> Parser r e [a]
many :: Parser r e a -> Parser r e [a]
many Parser r e a
p = Parser r e [a]
go where
  go :: Parser r e [a]
go = ((:) (a -> [a] -> [a]) -> Parser r e a -> Parser r e ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e a
p Parser r e ([a] -> [a]) -> Parser r e [a] -> Parser r e [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser r e [a]
go) Parser r e [a] -> Parser r e [a] -> Parser r e [a]
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> [a] -> Parser r e [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
{-# inline many #-}

-- | Skip a parser zero or more times.
many_ :: Parser r e a -> Parser r e ()
many_ :: Parser r e a -> Parser r e ()
many_ (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = Parser r e ()
go where
  go :: Parser r e ()
go = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
    OK# a
a Addr#
s -> Parser r e ()
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ()
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# Parser r e ()
go ForeignPtrContents
fp r
r Addr#
eob Addr#
s
    Res# e a
Fail#   -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () Addr#
s
    Err# e
e  -> e -> Res# e ()
forall e a. e -> Res# e a
Err# e
e
{-# inline many_ #-}

-- | Run a parser one or more times, collect the results in a list. Note: for optimal performance,
--   try to avoid this. Often it is possible to get rid of the intermediate list by using a
--   combinator or a custom parser.
some :: Parser r e a -> Parser r e [a]
some :: Parser r e a -> Parser r e [a]
some Parser r e a
p = (:) (a -> [a] -> [a]) -> Parser r e a -> Parser r e ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e a
p Parser r e ([a] -> [a]) -> Parser r e [a] -> Parser r e [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser r e a -> Parser r e [a]
forall r e a. Parser r e a -> Parser r e [a]
many Parser r e a
p
{-# inline some #-}

-- | Skip a parser one or more times.
some_ :: Parser r e a -> Parser r e ()
some_ :: Parser r e a -> Parser r e ()
some_ Parser r e a
pa = Parser r e a
pa Parser r e a -> Parser r e () -> Parser r e ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser r e a -> Parser r e ()
forall r e a. Parser r e a -> Parser r e ()
many_ Parser r e a
pa
{-# inline some_ #-}

-- | Succeed if the first parser succeeds and the second one fails.
notFollowedBy :: Parser r e a -> Parser r e b -> Parser r e a
notFollowedBy :: Parser r e a -> Parser r e b -> Parser r e a
notFollowedBy Parser r e a
p1 Parser r e b
p2 = Parser r e a
p1 Parser r e a -> Parser r e () -> Parser r e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser r e b -> Parser r e ()
forall r e a. Parser r e a -> Parser r e ()
fails Parser r e b
p2
{-# inline notFollowedBy #-}


--------------------------------------------------------------------------------

-- | Byte offset counted backwards from the end of the buffer.
newtype Pos = Pos Int deriving (Pos -> Pos -> Bool
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c== :: Pos -> Pos -> Bool
Eq, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos] -> ShowS
$cshowList :: [Pos] -> ShowS
show :: Pos -> String
$cshow :: Pos -> String
showsPrec :: Int -> Pos -> ShowS
$cshowsPrec :: Int -> Pos -> ShowS
Show)

-- | A pair of positions.
data Span = Span !Pos !Pos deriving (Span -> Span -> Bool
(Span -> Span -> Bool) -> (Span -> Span -> Bool) -> Eq Span
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span -> Span -> Bool
$c/= :: Span -> Span -> Bool
== :: Span -> Span -> Bool
$c== :: Span -> Span -> Bool
Eq, Int -> Span -> ShowS
[Span] -> ShowS
Span -> String
(Int -> Span -> ShowS)
-> (Span -> String) -> ([Span] -> ShowS) -> Show Span
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span] -> ShowS
$cshowList :: [Span] -> ShowS
show :: Span -> String
$cshow :: Span -> String
showsPrec :: Int -> Span -> ShowS
$cshowsPrec :: Int -> Span -> ShowS
Show)

instance Ord Pos where
  Pos Int
p <= :: Pos -> Pos -> Bool
<= Pos Int
p' = Int
p' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
p
  Pos Int
p < :: Pos -> Pos -> Bool
<  Pos Int
p' = Int
p' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
p
  Pos Int
p > :: Pos -> Pos -> Bool
>  Pos Int
p' = Int
p' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
p
  Pos Int
p >= :: Pos -> Pos -> Bool
>= Pos Int
p' = Int
p' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
p
  {-# inline (<=) #-}
  {-# inline (<) #-}
  {-# inline (>) #-}
  {-# inline (>=) #-}

-- | Get the current position in the input.
getPos :: Parser r e Pos
getPos :: Parser r e Pos
getPos = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Pos)
-> Parser r e Pos
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> Pos -> Addr# -> Res# e Pos
forall a e. a -> Addr# -> Res# e a
OK# (Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s) Addr#
s
{-# inline getPos #-}

-- | Set the input position. Warning: this can result in crashes if the position points outside the
--   current buffer. It is always safe to `setPos` values which came from `getPos` with the current
--   input.
setPos :: Pos -> Parser r e ()
setPos :: Pos -> Parser r e ()
setPos Pos
s = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
_ -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Pos -> Addr#
posToAddr# Addr#
eob Pos
s)
{-# inline setPos #-}

-- | The end of the input.
endPos :: Pos
endPos :: Pos
endPos = Int -> Pos
Pos Int
0
{-# inline endPos #-}


-- | Return the consumed span of a parser.
spanOf :: Parser r e a -> Parser r e Span
spanOf :: Parser r e a -> Parser r e Span
spanOf (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Span)
-> Parser r e Span
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
a Addr#
s' -> Span -> Addr# -> Res# e Span
forall a e. a -> Addr# -> Res# e a
OK# (Pos -> Pos -> Span
Span (Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s) (Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s')) Addr#
s'
  Res# e a
x        -> Res# e a -> Res# e Span
unsafeCoerce# Res# e a
x
{-# inline spanOf #-}

-- | Bind the result together with the span of the result. CPS'd version of `spanOf`
--   for better unboxing.
spanned :: Parser r e a -> (a -> Span -> Parser r e b) -> Parser r e b
spanned :: Parser r e a -> (a -> Span -> Parser r e b) -> Parser r e b
spanned (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) a -> Span -> Parser r e b
g = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
a Addr#
s' -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# (a -> Span -> Parser r e b
g a
a (Pos -> Pos -> Span
Span (Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s) (Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s'))) ForeignPtrContents
fp r
r Addr#
eob Addr#
s'
  Res# e a
x        -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
{-# inline spanned #-}

-- | Return the `B.ByteString` consumed by a parser. Note: it's more efficient to use `spanOf` and
--   `spanned` instead.
byteStringOf :: Parser r e a -> Parser r e B.ByteString
byteStringOf :: Parser r e a -> Parser r e ByteString
byteStringOf (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ByteString)
-> Parser r e ByteString
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
a Addr#
s' -> ByteString -> Addr# -> Res# e ByteString
forall a e. a -> Addr# -> Res# e a
OK# (ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS (Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
s ForeignPtrContents
fp) Int
0 (Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
s' Addr#
s))) Addr#
s'
  Res# e a
x        -> Res# e a -> Res# e ByteString
unsafeCoerce# Res# e a
x
{-# inline byteStringOf #-}

-- | CPS'd version of `byteStringOf`. Can be more efficient, because the result is more eagerly unboxed
--   by GHC. It's more efficient to use `spanOf` or `spanned` instead.
byteStringed :: Parser r e a -> (a -> B.ByteString -> Parser r e b) -> Parser r e b
byteStringed :: Parser r e a -> (a -> ByteString -> Parser r e b) -> Parser r e b
byteStringed (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) a -> ByteString -> Parser r e b
g = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b)
-> Parser r e b
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r Addr#
eob Addr#
s of
  OK# a
a Addr#
s' -> Parser r e b
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e b
forall r e a.
Parser r e a
-> ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
runParser# (a -> ByteString -> Parser r e b
g a
a (ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS (Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
s ForeignPtrContents
fp) Int
0 (Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
s' Addr#
s)))) ForeignPtrContents
fp r
r Addr#
eob Addr#
s'
  Res# e a
x        -> Res# e a -> Res# e b
unsafeCoerce# Res# e a
x
{-# inline byteStringed #-}

-- | Run a parser in a given input span. The input position and the `Int` state is restored after
--   the parser is finished, so `inSpan` does not consume input and has no side effect.  Warning:
--   this operation may crash if the given span points outside the current parsing buffer. It's
--   always safe to use `inSpan` if the span comes from a previous `spanned` or `spanOf` call on
--   the current input.
inSpan :: Span -> Parser r e a -> Parser r e a
inSpan :: Span -> Parser r e a -> Parser r e a
inSpan (Span Pos
s Pos
eob) (Parser ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob' Addr#
s' ->
  case ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a
f ForeignPtrContents
fp r
r (Addr# -> Pos -> Addr#
posToAddr# Addr#
eob' Pos
eob) (Addr# -> Pos -> Addr#
posToAddr# Addr#
eob' Pos
s) of
    OK# a
a Addr#
_ -> a -> Addr# -> Res# e a
forall a e. a -> Addr# -> Res# e a
OK# a
a Addr#
s'
    Res# e a
x       -> Res# e a -> Res# e a
unsafeCoerce# Res# e a
x
{-# inline inSpan #-}

--------------------------------------------------------------------------------

-- | Check whether a `Pos` points into a `B.ByteString`.
validPos :: B.ByteString -> Pos -> Bool
validPos :: ByteString -> Pos -> Bool
validPos ByteString
str Pos
pos =
  let go :: Parser r e Bool
go = do
        Pos
start <- Parser r e Pos
forall r e. Parser r e Pos
getPos
        Bool -> Parser r e Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos
start Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
<= Pos
pos Bool -> Bool -> Bool
&& Pos
pos Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
<= Pos
endPos)
  in case Parser () Any Bool -> () -> ByteString -> Result Any Bool
forall r e a. Parser r e a -> r -> ByteString -> Result e a
runParser Parser () Any Bool
forall r e. Parser r e Bool
go () ByteString
str of
    OK Bool
b ByteString
_ -> Bool
b
    Result Any Bool
_      -> String -> Bool
forall a. HasCallStack => String -> a
error String
"impossible"
{-# inline validPos #-}

-- | Compute corresponding line and column numbers for each `Pos` in a list. Throw an error
--   on invalid positions. Note: computing lines and columns may traverse the `B.ByteString`,
--   but it traverses it only once regardless of the length of the position list.
posLineCols :: B.ByteString -> [Pos] -> [(Int, Int)]
posLineCols :: ByteString -> [Pos] -> [(Int, Int)]
posLineCols ByteString
str [Pos]
poss =
  let go :: a -> a -> [(a, Pos)] -> Parser r e [(a, (a, a))]
go !a
line !a
col [] = [(a, (a, a))] -> Parser r e [(a, (a, a))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      go a
line a
col ((a
i, Pos
pos):[(a, Pos)]
poss) = do
        Pos
p <- Parser r e Pos
forall r e. Parser r e Pos
getPos
        if Pos
pos Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
p then
          ((a
i, (a
line, a
col))(a, (a, a)) -> [(a, (a, a))] -> [(a, (a, a))]
forall k1. k1 -> [k1] -> [k1]
:) ([(a, (a, a))] -> [(a, (a, a))])
-> Parser r e [(a, (a, a))] -> Parser r e [(a, (a, a))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> [(a, Pos)] -> Parser r e [(a, (a, a))]
go a
line a
col [(a, Pos)]
poss
        else do
          Word8
c <- Parser r e Word8
forall r e. Parser r e Word8
anyWord8
          if Char -> Int
ord Char
'\n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c then
            a -> a -> [(a, Pos)] -> Parser r e [(a, (a, a))]
go (a
line a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) a
0 ((a
i, Pos
pos)(a, Pos) -> [(a, Pos)] -> [(a, Pos)]
forall k1. k1 -> [k1] -> [k1]
:[(a, Pos)]
poss)
          else
            a -> a -> [(a, Pos)] -> Parser r e [(a, (a, a))]
go a
line (a
col a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) ((a
i, Pos
pos)(a, Pos) -> [(a, Pos)] -> [(a, Pos)]
forall k1. k1 -> [k1] -> [k1]
:[(a, Pos)]
poss)

      sorted :: [(Int, Pos)]
      sorted :: [(Int, Pos)]
sorted = ((Int, Pos) -> (Int, Pos) -> Ordering)
-> [(Int, Pos)] -> [(Int, Pos)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Pos) -> Pos) -> (Int, Pos) -> (Int, Pos) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Pos) -> Pos
forall a b. (a, b) -> b
snd) ([Int] -> [Pos] -> [(Int, Pos)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Pos]
poss)

  in case Parser () Any [(Int, (Int, Int))]
-> () -> ByteString -> Result Any [(Int, (Int, Int))]
forall r e a. Parser r e a -> r -> ByteString -> Result e a
runParser (Int -> Int -> [(Int, Pos)] -> Parser () Any [(Int, (Int, Int))]
forall a a a r e.
(Num a, Num a) =>
a -> a -> [(a, Pos)] -> Parser r e [(a, (a, a))]
go Int
0 Int
0 [(Int, Pos)]
sorted) () ByteString
str of
       OK [(Int, (Int, Int))]
res ByteString
_ -> (Int, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd ((Int, (Int, Int)) -> (Int, Int))
-> [(Int, (Int, Int))] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, (Int, Int)) -> (Int, (Int, Int)) -> Ordering)
-> [(Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, (Int, Int)) -> Int)
-> (Int, (Int, Int)) -> (Int, (Int, Int)) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, (Int, Int)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (Int, Int))]
res
       Result Any [(Int, (Int, Int))]
_        -> String -> [(Int, Int)]
forall a. HasCallStack => String -> a
error String
"invalid position"

-- | Create a `B.ByteString` from a `Span`. The result is invalid is the `Span` points
--   outside the current buffer, or if the `Span` start is greater than the end position.
unsafeSpanToByteString :: Span -> Parser r e B.ByteString
unsafeSpanToByteString :: Span -> Parser r e ByteString
unsafeSpanToByteString (Span Pos
l Pos
r) =
  Parser r e ByteString -> Parser r e ByteString
forall r e a. Parser r e a -> Parser r e a
lookahead (Pos -> Parser r e ()
forall r e. Pos -> Parser r e ()
setPos Pos
l Parser r e () -> Parser r e ByteString -> Parser r e ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser r e () -> Parser r e ByteString
forall r e a. Parser r e a -> Parser r e ByteString
byteStringOf (Pos -> Parser r e ()
forall r e. Pos -> Parser r e ()
setPos Pos
r))
{-# inline unsafeSpanToByteString #-}

-- | Create a `Pos` from a line and column number. Throws an error on out-of-bounds
--   line and column numbers.
mkPos :: B.ByteString -> (Int, Int) -> Pos
mkPos :: ByteString -> (Int, Int) -> Pos
mkPos ByteString
str (Int
line', Int
col') =
  let go :: Int -> Int -> Parser r e Pos
go Int
line Int
col | Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line' Bool -> Bool -> Bool
&& Int
col Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
col' = Parser r e Pos
forall r e. Parser r e Pos
getPos
      go Int
line Int
col = (do
        Char
c <- Parser r e Char
forall r e. Parser r e Char
anyChar
        if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Int -> Int -> Parser r e Pos
go (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
                     else Int -> Int -> Parser r e Pos
go Int
line (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Parser r e Pos -> Parser r e Pos -> Parser r e Pos
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> String -> Parser r e Pos
forall a. HasCallStack => String -> a
error String
"mkPos: invalid position"
  in case Parser () Any Pos -> () -> ByteString -> Result Any Pos
forall r e a. Parser r e a -> r -> ByteString -> Result e a
runParser (Int -> Int -> Parser () Any Pos
forall r e. Int -> Int -> Parser r e Pos
go Int
0 Int
0) () ByteString
str of
    OK Pos
res ByteString
_ -> Pos
res
    Result Any Pos
_        -> String -> Pos
forall a. HasCallStack => String -> a
error String
"impossible"

-- | Break an UTF-8-coded `B.ByteString` to lines. Throws an error on invalid input.
--   This is mostly useful for grabbing specific source lines for displaying error
--   messages.
lines :: B.ByteString -> [String]
lines :: ByteString -> [String]
lines ByteString
str =
  let go :: Parser r e [String]
go = ([] [String] -> Parser r e () -> Parser r e [String]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser r e ()
forall r e. Parser r e ()
eof) Parser r e [String] -> Parser r e [String] -> Parser r e [String]
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> ((:) (String -> [String] -> [String])
-> Parser r e String -> Parser r e ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e String
forall r e. Parser r e String
takeLine Parser r e ([String] -> [String])
-> Parser r e [String] -> Parser r e [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser r e [String]
go)
  in case Parser () Any [String] -> () -> ByteString -> Result Any [String]
forall r e a. Parser r e a -> r -> ByteString -> Result e a
runParser Parser () Any [String]
forall r e. Parser r e [String]
go () ByteString
str of
    OK [String]
ls ByteString
_ -> [String]
ls
    Result Any [String]
_       -> String -> [String]
forall a. HasCallStack => String -> a
error String
"linesUTF8: invalid input"


--------------------------------------------------------------------------------

-- | Parse the rest of the current line as a `String`. Assumes UTF-8 encoding,
--   throws an error if the encoding is invalid.
takeLine :: Parser r e String
takeLine :: Parser r e String
takeLine =
  Parser r e ()
-> Parser r e String -> Parser r e String -> Parser r e String
forall r e a b.
Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch Parser r e ()
forall r e. Parser r e ()
eof (String -> Parser r e String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"") do
  Char
c <- Parser r e Char
forall r e. Parser r e Char
anyChar
  case Char
c of
    Char
'\n' -> String -> Parser r e String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
    Char
_    -> (Char
cChar -> ShowS
forall k1. k1 -> [k1] -> [k1]
:) ShowS -> Parser r e String -> Parser r e String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e String
forall r e. Parser r e String
takeLine

-- | Parse the rest of the current line as a `String`, but restore the parsing state.
--   Assumes UTF-8 encoding. This can be used for debugging.
traceLine :: Parser r e String
traceLine :: Parser r e String
traceLine = Parser r e String -> Parser r e String
forall r e a. Parser r e a -> Parser r e a
lookahead Parser r e String
forall r e. Parser r e String
takeLine

-- | Take the rest of the input as a `String`. Assumes UTF-8 encoding.
takeRest :: Parser r e String
takeRest :: Parser r e String
takeRest = ((:) (Char -> ShowS) -> Parser r e Char -> Parser r e ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser r e Char
forall r e. Parser r e Char
anyChar Parser r e ShowS -> Parser r e String -> Parser r e String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser r e String
forall r e. Parser r e String
takeRest) Parser r e String -> Parser r e String -> Parser r e String
forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> String -> Parser r e String
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Get the rest of the input as a `String`, but restore the parsing state. Assumes UTF-8 encoding.
--   This can be used for debugging.
traceRest :: Parser r e String
traceRest :: Parser r e String
traceRest = Parser r e String -> Parser r e String
forall r e a. Parser r e a -> Parser r e a
lookahead Parser r e String
forall r e. Parser r e String
traceRest

--------------------------------------------------------------------------------

addrToPos# :: Addr# -> Addr# -> Pos
addrToPos# :: Addr# -> Addr# -> Pos
addrToPos# Addr#
eob Addr#
s = Int -> Pos
Pos (Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
eob Addr#
s))
{-# inline addrToPos# #-}

posToAddr# :: Addr# -> Pos -> Addr#
posToAddr# :: Addr# -> Pos -> Addr#
posToAddr# Addr#
eob (Pos (I# Int#
n)) = Int# -> Addr#
unsafeCoerce# (Addr# -> Addr# -> Int#
minusAddr# Addr#
eob (Int# -> Addr#
unsafeCoerce# Int#
n))
{-# inline posToAddr# #-}

-- | Convert a `String` to an UTF-8-coded `B.ByteString`.
packUTF8 :: String -> B.ByteString
packUTF8 :: String -> ByteString
packUTF8 = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Word8]) -> String -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Word8]
charToBytes

charToBytes :: Char -> [Word8]
charToBytes :: Char -> [Word8]
charToBytes Char
c'
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7f     = [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c]
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7ff    = [Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z]
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xffff   = [Word8
0xe0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z]
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff = [Word8
0xf0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
w, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y, Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z]
    | Bool
otherwise = String -> [Word8]
forall a. HasCallStack => String -> a
error String
"Not a valid Unicode code point"
  where
    c :: Int
c = Char -> Int
ord Char
c'
    z :: Word8
z = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c                 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
    y :: Word8
y = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
c Int
6  Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
    x :: Word8
x = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
c Int
12 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
    w :: Word8
w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
c Int
18 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7)

strToBytes :: String -> [Word8]
strToBytes :: String -> [Word8]
strToBytes = (Char -> [Word8]) -> String -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Word8]
charToBytes
{-# inline strToBytes #-}

packBytes :: [Word8] -> Word
packBytes :: [Word8] -> Word
packBytes = (Word, Int) -> Word
forall a b. (a, b) -> a
fst ((Word, Int) -> Word)
-> ([Word8] -> (Word, Int)) -> [Word8] -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word, Int) -> Word8 -> (Word, Int))
-> (Word, Int) -> [Word8] -> (Word, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Int) -> Word8 -> (Word, Int)
forall a a.
(Bits a, Integral a, Num a) =>
(a, Int) -> a -> (a, Int)
go (Word
0, Int
0) where
  go :: (a, Int) -> a -> (a, Int)
go (a
acc, Int
shift) a
w | Int
shift Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 = String -> (a, Int)
forall a. HasCallStack => String -> a
error String
"packWords: too many bytes"
  go (a
acc, Int
shift) a
w = (a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) Int
shift a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
acc, Int
shiftInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
8)

splitBytes :: [Word8] -> ([Word8], [Word])
splitBytes :: [Word8] -> ([Word8], [Word])
splitBytes [Word8]
ws = case Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem ([Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws) Int
8 of
  (Int
0, Int
_) -> ([Word8]
ws, [])
  (Int
_, Int
r) -> ([Word8]
as, [Word8] -> [Word]
chunk8s [Word8]
bs) where
              ([Word8]
as, [Word8]
bs) = Int -> [Word8] -> ([Word8], [Word8])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
r [Word8]
ws
              chunk8s :: [Word8] -> [Word]
chunk8s [] = []
              chunk8s [Word8]
ws = let ([Word8]
as, [Word8]
bs) = Int -> [Word8] -> ([Word8], [Word8])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Word8]
ws in
                           [Word8] -> Word
packBytes [Word8]
as Word -> [Word] -> [Word]
forall k1. k1 -> [k1] -> [k1]
: [Word8] -> [Word]
chunk8s [Word8]
bs

derefChar8# :: Addr# -> Char#
derefChar8# :: Addr# -> Char#
derefChar8# Addr#
addr = Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
addr Int#
0#
{-# inline derefChar8# #-}

-- | Check that the input has at least the given number of bytes.
ensureBytes# :: Int -> Parser r e ()
ensureBytes# :: Int -> Parser r e ()
ensureBytes# (I# Int#
len) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Int#
len  Int# -> Int# -> Int#
<=# Addr# -> Addr# -> Int#
minusAddr# Addr#
eob Addr#
s of
    Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () Addr#
s
    Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline ensureBytes# #-}

-- | Unsafely read a concrete byte from the input. It's not checked that the input has
--   enough bytes.
scan8# :: Word -> Parser r e ()
scan8# :: Word -> Parser r e ()
scan8# (W# Word#
c) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
s Int#
0# of
    Word#
c' -> case Word# -> Word# -> Int#
eqWord# Word#
c Word#
c' of
      Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
1#)
      Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline scan8# #-}

-- | Unsafely read two concrete bytes from the input. It's not checked that the input has
--   enough bytes.
scan16# :: Word -> Parser r e ()
scan16# :: Word -> Parser r e ()
scan16# (W# Word#
c) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Addr# -> Int# -> Word#
indexWord16OffAddr# Addr#
s Int#
0# of
    Word#
c' -> case Word# -> Word# -> Int#
eqWord# Word#
c Word#
c' of
      Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
2#)
      Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline scan16# #-}

-- | Unsafely read four concrete bytes from the input. It's not checked that the input has
--   enough bytes.
scan32# :: Word -> Parser r e ()
scan32# :: Word -> Parser r e ()
scan32# (W# Word#
c) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Addr# -> Int# -> Word#
indexWord32OffAddr# Addr#
s Int#
0# of
    Word#
c' -> case Word# -> Word# -> Int#
eqWord# Word#
c Word#
c' of
      Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
4#)
      Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline scan32# #-}

-- | Unsafely read eight concrete bytes from the input. It's not checked that the input has
--   enough bytes.
scan64# :: Word -> Parser r e ()
scan64# :: Word -> Parser r e ()
scan64# (W# Word#
c) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Addr# -> Int# -> Word#
indexWord64OffAddr# Addr#
s Int#
0# of
    Word#
c' -> case Word# -> Word# -> Int#
eqWord# Word#
c Word#
c' of
      Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
8#)
      Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline scan64# #-}

-- | Unsafely read and return a byte from the input. It's not checked that the input is non-empty.
scanAny8# :: Parser r e Word8
scanAny8# :: Parser r e Word8
scanAny8# = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e Word8)
-> Parser r e Word8
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s -> Word8 -> Addr# -> Res# e Word8
forall a e. a -> Addr# -> Res# e a
OK# (Word# -> Word8
W8# (Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
s Int#
0#)) (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
1#)
{-# inline scanAny8# #-}

scanPartial64# :: Int -> Word -> Parser r e ()
scanPartial64# :: Int -> Word -> Parser r e ()
scanPartial64# (I# Int#
len) (W# Word#
w) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  case Addr# -> Int# -> Word#
indexWordOffAddr# Addr#
s Int#
0# of
    Word#
w' -> case Int# -> Int# -> Int#
uncheckedIShiftL# (Int#
8# Int# -> Int# -> Int#
-# Int#
len) Int#
3# of
      Int#
sh -> case Word# -> Int# -> Word#
uncheckedShiftL# Word#
w' Int#
sh of
        Word#
w' -> case Word# -> Int# -> Word#
uncheckedShiftRL# Word#
w' Int#
sh of
          Word#
w' -> case Word# -> Word# -> Int#
eqWord# Word#
w Word#
w' of
            Int#
1# -> () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s Int#
len)
            Int#
_  -> Res# e ()
forall e a. Res# e a
Fail#
{-# inline scanPartial64# #-}

-- | Decrease the current input position by the given number of bytes.
setBack# :: Int -> Parser r e ()
setBack# :: Int -> Parser r e ()
setBack# (I# Int#
i) = (ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e ())
-> Parser r e ()
forall r e a.
(ForeignPtrContents -> r -> Addr# -> Addr# -> Res# e a)
-> Parser r e a
Parser \ForeignPtrContents
fp r
r Addr#
eob Addr#
s ->
  () -> Addr# -> Res# e ()
forall a e. a -> Addr# -> Res# e a
OK# () (Addr# -> Int# -> Addr#
plusAddr# Addr#
s (Int# -> Int#
negateInt# Int#
i))
{-# inline setBack# #-}

-- | Template function, creates a @Parser r e ()@ which unsafely scans a given
--   sequence of bytes.
scanBytes# :: [Word8] -> Q Exp
scanBytes# :: [Word8] -> Q Exp
scanBytes# [Word8]
bytes = do
  let !([Word8]
leading, [Word]
w8s) = [Word8] -> ([Word8], [Word])
splitBytes [Word8]
bytes
      !scanw8s :: Q Exp
scanw8s        = [Word] -> Q Exp
forall t. Lift t => [t] -> Q Exp
go [Word]
w8s where
                         go :: [t] -> Q Exp
go (t
w8:[] ) = [| scan64# w8 |]
                         go (t
w8:[t]
w8s) = [| scan64# w8 >> $(go w8s) |]
                         go []       = [| pure () |]
  case [Word]
w8s of
    [] -> [Word8] -> Q Exp
go [Word8]
leading
          where
            go :: [Word8] -> Q Exp
go (Word8
a:Word8
b:Word8
c:Word8
d:[]) = let !w :: Word
w = [Word8] -> Word
packBytes [Word8
a, Word8
b, Word8
c, Word8
d] in [| scan32# w |]
            go (Word8
a:Word8
b:Word8
c:Word8
d:[Word8]
ws) = let !w :: Word
w = [Word8] -> Word
packBytes [Word8
a, Word8
b, Word8
c, Word8
d] in [| scan32# w >> $(go ws) |]
            go (Word8
a:Word8
b:[])     = let !w :: Word
w = [Word8] -> Word
packBytes [Word8
a, Word8
b]       in [| scan16# w |]
            go (Word8
a:Word8
b:[Word8]
ws)     = let !w :: Word
w = [Word8] -> Word
packBytes [Word8
a, Word8
b]       in [| scan16# w >> $(go ws) |]
            go (Word8
a:[])       = [| scan8# a |]
            go []           = [| pure () |]
    [Word]
_  -> case [Word8]
leading of

      []              -> Q Exp
scanw8s
      [Word8
a]             -> [| scan8# a >> $scanw8s |]
      ws :: [Word8]
ws@[Word8
a, Word8
b]       -> let !w :: Word
w = [Word8] -> Word
packBytes [Word8]
ws in [| scan16# w >> $scanw8s |]
      ws :: [Word8]
ws@[Word8
a, Word8
b, Word8
c, Word8
d] -> let !w :: Word
w = [Word8] -> Word
packBytes [Word8]
ws in [| scan32# w >> $scanw8s |]
      [Word8]
ws              -> let !w :: Word
w = [Word8] -> Word
packBytes [Word8]
ws
                             !l :: Int
l = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws
                         in [| scanPartial64# l w >> $scanw8s |]


-- Trie switching
--------------------------------------------------------------------------------

data Trie a = Branch !a !(Map Word8 (Trie a))

type Rule = Maybe Int

nilTrie :: Trie Rule
nilTrie :: Trie (Maybe Int)
nilTrie = Maybe Int -> Map Word8 (Trie (Maybe Int)) -> Trie (Maybe Int)
forall a. a -> Map Word8 (Trie a) -> Trie a
Branch Maybe Int
forall k1. Maybe k1
Nothing Map Word8 (Trie (Maybe Int))
forall a. Monoid a => a
mempty

updRule :: Int -> Maybe Int -> Maybe Int
updRule :: Int -> Maybe Int -> Maybe Int
updRule Int
rule = Int -> Maybe Int
forall k1. k1 -> Maybe k1
Just (Int -> Maybe Int) -> (Maybe Int -> Int) -> Maybe Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
rule (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
rule)

insert :: Int -> [Word8] -> Trie Rule -> Trie Rule
insert :: Int -> [Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
insert Int
rule = [Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
go where
  go :: [Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
go [] (Branch Maybe Int
rule' Map Word8 (Trie (Maybe Int))
ts) =
    Maybe Int -> Map Word8 (Trie (Maybe Int)) -> Trie (Maybe Int)
forall a. a -> Map Word8 (Trie a) -> Trie a
Branch (Int -> Maybe Int -> Maybe Int
updRule Int
rule Maybe Int
rule') Map Word8 (Trie (Maybe Int))
ts
  go (Word8
c:[Word8]
cs) (Branch Maybe Int
rule' Map Word8 (Trie (Maybe Int))
ts) =
    Maybe Int -> Map Word8 (Trie (Maybe Int)) -> Trie (Maybe Int)
forall a. a -> Map Word8 (Trie a) -> Trie a
Branch Maybe Int
rule' ((Maybe (Trie (Maybe Int)) -> Maybe (Trie (Maybe Int)))
-> Word8
-> Map Word8 (Trie (Maybe Int))
-> Map Word8 (Trie (Maybe Int))
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Trie (Maybe Int) -> Maybe (Trie (Maybe Int))
forall k1. k1 -> Maybe k1
Just (Trie (Maybe Int) -> Maybe (Trie (Maybe Int)))
-> (Maybe (Trie (Maybe Int)) -> Trie (Maybe Int))
-> Maybe (Trie (Maybe Int))
-> Maybe (Trie (Maybe Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie (Maybe Int)
-> (Trie (Maybe Int) -> Trie (Maybe Int))
-> Maybe (Trie (Maybe Int))
-> Trie (Maybe Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
go [Word8]
cs Trie (Maybe Int)
nilTrie) ([Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
go [Word8]
cs)) Word8
c Map Word8 (Trie (Maybe Int))
ts)

fromList :: [(Int, String)] -> Trie Rule
fromList :: [(Int, String)] -> Trie (Maybe Int)
fromList = (Trie (Maybe Int) -> (Int, String) -> Trie (Maybe Int))
-> Trie (Maybe Int) -> [(Int, String)] -> Trie (Maybe Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Trie (Maybe Int)
t (!Int
r, !String
s) -> Int -> [Word8] -> Trie (Maybe Int) -> Trie (Maybe Int)
insert Int
r (Char -> [Word8]
charToBytes (Char -> [Word8]) -> String -> [Word8]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
s) Trie (Maybe Int)
t) Trie (Maybe Int)
nilTrie

-- | Decorate a trie with the minimum lengths of non-empty paths. This
--   is used later to place `ensureBytes#`.
mindepths :: Trie Rule -> Trie (Rule, Int)
mindepths :: Trie (Maybe Int) -> Trie (Maybe Int, Int)
mindepths (Branch Maybe Int
rule Map Word8 (Trie (Maybe Int))
ts) =
  if Map Word8 (Trie (Maybe Int)) -> Bool
forall k a. Map k a -> Bool
M.null Map Word8 (Trie (Maybe Int))
ts then
    (Maybe Int, Int)
-> Map Word8 (Trie (Maybe Int, Int)) -> Trie (Maybe Int, Int)
forall a. a -> Map Word8 (Trie a) -> Trie a
Branch (Maybe Int
rule, Int
0) Map Word8 (Trie (Maybe Int, Int))
forall a. Monoid a => a
mempty
  else
    let !ts' :: Map Word8 (Trie (Maybe Int, Int))
ts' = (Trie (Maybe Int) -> Trie (Maybe Int, Int))
-> Map Word8 (Trie (Maybe Int))
-> Map Word8 (Trie (Maybe Int, Int))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Trie (Maybe Int) -> Trie (Maybe Int, Int)
mindepths Map Word8 (Trie (Maybe Int))
ts in
    (Maybe Int, Int)
-> Map Word8 (Trie (Maybe Int, Int)) -> Trie (Maybe Int, Int)
forall a. a -> Map Word8 (Trie a) -> Trie a
Branch (
      Maybe Int
rule,
      Map Word8 Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Trie (Maybe Int, Int) -> Int)
-> Map Word8 (Trie (Maybe Int, Int)) -> Map Word8 Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(Branch (Maybe Int
rule,Int
d) Map Word8 (Trie (Maybe Int, Int))
_) -> Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (\Int
_ -> Int
1) Maybe Int
rule) Map Word8 (Trie (Maybe Int, Int))
ts'))
      Map Word8 (Trie (Maybe Int, Int))
ts'

data Trie' a
  = Branch' !a !(Map Word8 (Trie' a))
  | Path !a ![Word8] !(Trie' a)

-- | Compress linear paths.
pathify :: Trie (Rule, Int) -> Trie' (Rule, Int)
pathify :: Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int)
pathify (Branch (Maybe Int, Int)
a Map Word8 (Trie (Maybe Int, Int))
ts) = case Map Word8 (Trie (Maybe Int, Int))
-> [(Word8, Trie (Maybe Int, Int))]
forall k a. Map k a -> [(k, a)]
M.toList Map Word8 (Trie (Maybe Int, Int))
ts of
  [] -> (Maybe Int, Int)
-> Map Word8 (Trie' (Maybe Int, Int)) -> Trie' (Maybe Int, Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int, Int)
a Map Word8 (Trie' (Maybe Int, Int))
forall a. Monoid a => a
mempty
  [(Word8
w, Trie (Maybe Int, Int)
t)] -> case Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int)
pathify Trie (Maybe Int, Int)
t of
           Path (Maybe Int
Nothing, Int
_) [Word8]
ws Trie' (Maybe Int, Int)
t -> (Maybe Int, Int)
-> [Word8] -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int, Int)
a (Word8
wWord8 -> [Word8] -> [Word8]
forall k1. k1 -> [k1] -> [k1]
:[Word8]
ws) Trie' (Maybe Int, Int)
t
           Trie' (Maybe Int, Int)
t                      -> (Maybe Int, Int)
-> [Word8] -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int, Int)
a [Word8
w] Trie' (Maybe Int, Int)
t
  [(Word8, Trie (Maybe Int, Int))]
_   -> (Maybe Int, Int)
-> Map Word8 (Trie' (Maybe Int, Int)) -> Trie' (Maybe Int, Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int, Int)
a ((Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int))
-> Map Word8 (Trie (Maybe Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int)
pathify Map Word8 (Trie (Maybe Int, Int))
ts)

fallbacks :: Trie' (Rule, Int) -> Trie' (Rule, Int, Int)
fallbacks :: Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
fallbacks = Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go Maybe Int
forall k1. Maybe k1
Nothing Int
0  where
  go :: Rule -> Int -> Trie' (Rule, Int) -> Trie' (Rule, Int, Int)
  go :: Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go !Maybe Int
rule !Int
n (Branch' (Maybe Int
rule', Int
d) Map Word8 (Trie' (Maybe Int, Int))
ts)
    | Map Word8 (Trie' (Maybe Int, Int)) -> Bool
forall k a. Map k a -> Bool
M.null Map Word8 (Trie' (Maybe Int, Int))
ts        = (Maybe Int, Int, Int)
-> Map Word8 (Trie' (Maybe Int, Int, Int))
-> Trie' (Maybe Int, Int, Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
rule', Int
0, Int
d) Map Word8 (Trie' (Maybe Int, Int, Int))
forall a. Monoid a => a
mempty
    | Maybe Int
Nothing <- Maybe Int
rule' = (Maybe Int, Int, Int)
-> Map Word8 (Trie' (Maybe Int, Int, Int))
-> Trie' (Maybe Int, Int, Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
rule, Int
n, Int
d) (Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go Maybe Int
rule (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Word8 (Trie' (Maybe Int, Int))
ts)
    | Bool
otherwise        = (Maybe Int, Int, Int)
-> Map Word8 (Trie' (Maybe Int, Int, Int))
-> Trie' (Maybe Int, Int, Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
rule, Int
n, Int
d) (Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go Maybe Int
rule' Int
1      (Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Word8 (Trie' (Maybe Int, Int))
ts)
  go Maybe Int
rule Int
n (Path (Maybe Int
rule', Int
d) [Word8]
ws Trie' (Maybe Int, Int)
t)
    | Maybe Int
Nothing <- Maybe Int
rule' = (Maybe Int, Int, Int)
-> [Word8]
-> Trie' (Maybe Int, Int, Int)
-> Trie' (Maybe Int, Int, Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int
rule, Int
n, Int
d)  [Word8]
ws (Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go Maybe Int
rule (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Trie' (Maybe Int, Int)
t)
    | Bool
otherwise        = (Maybe Int, Int, Int)
-> [Word8]
-> Trie' (Maybe Int, Int, Int)
-> Trie' (Maybe Int, Int, Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int
rule', Int
0, Int
d) [Word8]
ws (Maybe Int
-> Int -> Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
go Maybe Int
rule' ([Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws) Trie' (Maybe Int, Int)
t)

-- | Decorate with `ensureBytes#` invocations, represented as
--   `Maybe Int`.
ensureBytes :: Trie' (Rule, Int, Int) -> Trie' (Rule, Int, Maybe Int)
ensureBytes :: Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
ensureBytes = Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go Int
0 where
  go :: Int -> Trie' (Rule, Int, Int) -> Trie' (Rule, Int, Maybe Int)
  go :: Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go !Int
res = \case
    Branch' (Maybe Int
r, Int
n, Int
d) Map Word8 (Trie' (Maybe Int, Int, Int))
ts
      | Map Word8 (Trie' (Maybe Int, Int, Int)) -> Bool
forall k a. Map k a -> Bool
M.null Map Word8 (Trie' (Maybe Int, Int, Int))
ts -> (Maybe Int, Int, Maybe Int)
-> Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
-> Trie' (Maybe Int, Int, Maybe Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
r, Int
n, Maybe Int
forall k1. Maybe k1
Nothing) Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
forall a. Monoid a => a
mempty
      |  Int
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1  -> (Maybe Int, Int, Maybe Int)
-> Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
-> Trie' (Maybe Int, Int, Maybe Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
r, Int
n, Int -> Maybe Int
forall k1. k1 -> Maybe k1
Just Int
d ) (Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go (Int
d   Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int))
-> Map Word8 (Trie' (Maybe Int, Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Word8 (Trie' (Maybe Int, Int, Int))
ts)
      | Bool
otherwise -> (Maybe Int, Int, Maybe Int)
-> Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
-> Trie' (Maybe Int, Int, Maybe Int)
forall a. a -> Map Word8 (Trie' a) -> Trie' a
Branch' (Maybe Int
r, Int
n, Maybe Int
forall k1. Maybe k1
Nothing) (Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go (Int
res Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int))
-> Map Word8 (Trie' (Maybe Int, Int, Int))
-> Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Word8 (Trie' (Maybe Int, Int, Int))
ts)
    Path (Maybe Int
r, Int
n, Int
d) [Word8]
ws Trie' (Maybe Int, Int, Int)
t -> case [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws of
      Int
l | Int
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l   -> (Maybe Int, Int, Maybe Int)
-> [Word8]
-> Trie' (Maybe Int, Int, Maybe Int)
-> Trie' (Maybe Int, Int, Maybe Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int
r, Int
n, Int -> Maybe Int
forall k1. k1 -> Maybe k1
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
res) [Word8]
ws (Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)   Trie' (Maybe Int, Int, Int)
t)
        | Bool
otherwise -> (Maybe Int, Int, Maybe Int)
-> [Word8]
-> Trie' (Maybe Int, Int, Maybe Int)
-> Trie' (Maybe Int, Int, Maybe Int)
forall a. a -> [Word8] -> Trie' a -> Trie' a
Path (Maybe Int
r, Int
n, Maybe Int
forall k1. Maybe k1
Nothing        ) [Word8]
ws (Int
-> Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
go (Int
res Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Trie' (Maybe Int, Int, Int)
t)

compileTrie :: [(Int, String)] -> Trie' (Rule, Int, Maybe Int)
compileTrie :: [(Int, String)] -> Trie' (Maybe Int, Int, Maybe Int)
compileTrie = Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int)
ensureBytes (Trie' (Maybe Int, Int, Int) -> Trie' (Maybe Int, Int, Maybe Int))
-> ([(Int, String)] -> Trie' (Maybe Int, Int, Int))
-> [(Int, String)]
-> Trie' (Maybe Int, Int, Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int)
fallbacks (Trie' (Maybe Int, Int) -> Trie' (Maybe Int, Int, Int))
-> ([(Int, String)] -> Trie' (Maybe Int, Int))
-> [(Int, String)]
-> Trie' (Maybe Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int)
pathify (Trie (Maybe Int, Int) -> Trie' (Maybe Int, Int))
-> ([(Int, String)] -> Trie (Maybe Int, Int))
-> [(Int, String)]
-> Trie' (Maybe Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie (Maybe Int) -> Trie (Maybe Int, Int)
mindepths (Trie (Maybe Int) -> Trie (Maybe Int, Int))
-> ([(Int, String)] -> Trie (Maybe Int))
-> [(Int, String)]
-> Trie (Maybe Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, String)] -> Trie (Maybe Int)
FlatParse.Basic.fromList

genTrie :: (Map (Maybe Int) Exp, Trie' (Rule, Int, Maybe Int)) -> Q Exp
genTrie :: (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int)) -> Q Exp
genTrie (Map (Maybe Int) Exp
rules, Trie' (Maybe Int, Int, Maybe Int)
t) = do
  Map (Maybe Int) (Name, Exp)
branches <- (Exp -> Q (Name, Exp))
-> Map (Maybe Int) Exp -> Q (Map (Maybe Int) (Name, Exp))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Exp
e -> (,) (Name -> Exp -> (Name, Exp)) -> Q Name -> Q (Exp -> (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Q Name
newName String
"rule") Q (Exp -> (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e) Map (Maybe Int) Exp
rules

  let ix :: Map a p -> a -> p
ix Map a p
m a
k = case a -> Map a p -> Maybe p
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
k Map a p
m of
        Maybe p
Nothing -> String -> p
forall a. HasCallStack => String -> a
error (String
"key not in map: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
k)
        Just p
a  -> p
a

  let ensure :: Maybe Int -> Maybe (Q Exp)
      ensure :: Maybe Int -> Maybe (Q Exp)
ensure = (Int -> Q Exp) -> Maybe Int -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
n -> [| ensureBytes# n |])

      fallback :: Rule -> Int ->  Q Exp
      fallback :: Maybe Int -> Int -> Q Exp
fallback Maybe Int
rule Int
0 = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ (Name, Exp) -> Name
forall a b. (a, b) -> a
fst ((Name, Exp) -> Name) -> (Name, Exp) -> Name
forall a b. (a -> b) -> a -> b
$ Map (Maybe Int) (Name, Exp) -> Maybe Int -> (Name, Exp)
forall a p. (Ord a, Show a) => Map a p -> a -> p
ix Map (Maybe Int) (Name, Exp)
branches Maybe Int
rule
      fallback Maybe Int
rule Int
n = [| setBack# n >> $(pure $ VarE $ fst $ ix branches rule) |]

  let go :: Trie' (Rule, Int, Maybe Int) -> Q Exp
      go :: Trie' (Maybe Int, Int, Maybe Int) -> Q Exp
go = \case
        Branch' (Maybe Int
r, Int
n, Maybe Int
alloc) Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
ts
          | Map Word8 (Trie' (Maybe Int, Int, Maybe Int)) -> Bool
forall k a. Map k a -> Bool
M.null Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
ts -> Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ (Name, Exp) -> Name
forall a b. (a, b) -> a
fst ((Name, Exp) -> Name) -> (Name, Exp) -> Name
forall a b. (a -> b) -> a -> b
$ Map (Maybe Int) (Name, Exp)
branches Map (Maybe Int) (Name, Exp) -> Maybe Int -> (Name, Exp)
forall k a. Ord k => Map k a -> k -> a
M.! Maybe Int
r
          | Bool
otherwise -> do
              ![(Word8, Exp)]
next         <- (((Word8, Trie' (Maybe Int, Int, Maybe Int)) -> Q (Word8, Exp))
-> [(Word8, Trie' (Maybe Int, Int, Maybe Int))] -> Q [(Word8, Exp)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Word8, Trie' (Maybe Int, Int, Maybe Int)) -> Q (Word8, Exp))
 -> [(Word8, Trie' (Maybe Int, Int, Maybe Int))]
 -> Q [(Word8, Exp)])
-> ((Trie' (Maybe Int, Int, Maybe Int) -> Q Exp)
    -> (Word8, Trie' (Maybe Int, Int, Maybe Int)) -> Q (Word8, Exp))
-> (Trie' (Maybe Int, Int, Maybe Int) -> Q Exp)
-> [(Word8, Trie' (Maybe Int, Int, Maybe Int))]
-> Q [(Word8, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trie' (Maybe Int, Int, Maybe Int) -> Q Exp)
-> (Word8, Trie' (Maybe Int, Int, Maybe Int)) -> Q (Word8, Exp)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) Trie' (Maybe Int, Int, Maybe Int) -> Q Exp
go (Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
-> [(Word8, Trie' (Maybe Int, Int, Maybe Int))]
forall k a. Map k a -> [(k, a)]
M.toList Map Word8 (Trie' (Maybe Int, Int, Maybe Int))
ts)
              !Exp
defaultCase  <- Maybe Int -> Int -> Q Exp
fallback Maybe Int
r (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

              let cases :: Exp
cases = [Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$
                    [Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP (String -> Name
mkName String
"c")) (Name -> Exp
VarE 'scanAny8#),
                      Exp -> Stmt
NoBindS (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE (String -> Name
mkName String
"c"))
                         (((Word8, Exp) -> Match) -> [(Word8, Exp)] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (\(Word8
w, Exp
t) ->
                                 Pat -> Body -> [Dec] -> Match
Match (Lit -> Pat
LitP (Integer -> Lit
IntegerL (Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)))
                                       (Exp -> Body
NormalB Exp
t)
                                       [])
                              [(Word8, Exp)]
next
                          [Match] -> [Match] -> [Match]
forall a. [a] -> [a] -> [a]
++ [Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
defaultCase) []]))]

              case Maybe Int -> Maybe (Q Exp)
ensure Maybe Int
alloc of
                Maybe (Q Exp)
Nothing    -> Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
cases
                Just Q Exp
alloc -> [| branch $alloc $(pure cases) $(fallback r n) |]

        Path (Maybe Int
r, Int
n, Maybe Int
alloc) [Word8]
ws Trie' (Maybe Int, Int, Maybe Int)
t ->
          case Maybe Int -> Maybe (Q Exp)
ensure Maybe Int
alloc of
            Maybe (Q Exp)
Nothing    -> [| branch $(scanBytes# ws) $(go t) $(fallback r n)|]
            Just Q Exp
alloc -> [| branch ($alloc >> $(scanBytes# ws)) $(go t) $(fallback r n) |]

  [DecQ] -> Q Exp -> Q Exp
letE
    (((Name, Exp) -> DecQ) -> [(Name, Exp)] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
x, Exp
rhs) -> PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
x) (Q Exp -> BodyQ
normalB (Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
rhs)) []) (Map (Maybe Int) (Name, Exp) -> [(Name, Exp)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Map (Maybe Int) (Name, Exp)
branches))
    (Trie' (Maybe Int, Int, Maybe Int) -> Q Exp
go Trie' (Maybe Int, Int, Maybe Int)
t)

parseSwitch :: Q Exp -> Q ([(String, Exp)], Maybe Exp)
parseSwitch :: Q Exp -> Q ([(String, Exp)], Maybe Exp)
parseSwitch Q Exp
exp = Q Exp
exp Q Exp
-> (Exp -> Q ([(String, Exp)], Maybe Exp))
-> Q ([(String, Exp)], Maybe Exp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  CaseE (UnboundVarE Name
_) []    -> String -> Q ([(String, Exp)], Maybe Exp)
forall a. HasCallStack => String -> a
error String
"switch: empty clause list"
  CaseE (UnboundVarE Name
_) [Match]
cases -> do
    (![Match]
cases, !Match
last) <- ([Match], Match) -> Q ([Match], Match)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match] -> [Match]
forall a. [a] -> [a]
init [Match]
cases, [Match] -> Match
forall a. [a] -> a
last [Match]
cases)
    ![(String, Exp)]
cases <- [Match] -> (Match -> Q (String, Exp)) -> Q [(String, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Match]
cases \case
      Match (LitP (StringL String
str)) (NormalB Exp
rhs) [] -> (String, Exp) -> Q (String, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
str, Exp
rhs)
      Match
_ -> String -> Q (String, Exp)
forall a. HasCallStack => String -> a
error String
"switch: expected a match clause on a string literal"
    (![(String, Exp)]
cases, !Maybe Exp
last) <- case Match
last of
      Match (LitP (StringL String
str)) (NormalB Exp
rhs) [] -> ([(String, Exp)], Maybe Exp) -> Q ([(String, Exp)], Maybe Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, Exp)]
cases [(String, Exp)] -> [(String, Exp)] -> [(String, Exp)]
forall a. [a] -> [a] -> [a]
++ [(String
str, Exp
rhs)], Maybe Exp
forall k1. Maybe k1
Nothing)
      Match Pat
WildP                (NormalB Exp
rhs) [] -> ([(String, Exp)], Maybe Exp) -> Q ([(String, Exp)], Maybe Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, Exp)]
cases, Exp -> Maybe Exp
forall k1. k1 -> Maybe k1
Just Exp
rhs)
      Match
_ -> String -> Q ([(String, Exp)], Maybe Exp)
forall a. HasCallStack => String -> a
error String
"switch: expected a match clause on a string literal or a wildcard"
    ([(String, Exp)], Maybe Exp) -> Q ([(String, Exp)], Maybe Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, Exp)]
cases, Maybe Exp
last)
  Exp
_ -> String -> Q ([(String, Exp)], Maybe Exp)
forall a. HasCallStack => String -> a
error String
"switch: expected a \"case _ of\" expression"

genSwitchTrie' :: Maybe Exp -> [(String, Exp)] -> Maybe Exp
              -> (Map (Maybe Int) Exp, Trie' (Rule, Int, Maybe Int))
genSwitchTrie' :: Maybe Exp
-> [(String, Exp)]
-> Maybe Exp
-> (Map (Maybe Int) Exp, Trie' (Maybe Int, Int, Maybe Int))
genSwitchTrie' Maybe Exp
postAction [(String, Exp)]
cases Maybe Exp
fallback =

  let (![(Maybe Int, Exp)]
branches, ![(Int, String)]
strings) = [((Maybe Int, Exp), (Int, String))]
-> ([(Maybe Int, Exp)], [(Int, String)])
forall a b. [(a, b)] -> ([a], [b])
unzip do
        (!Int
i, (!String
str, !Exp
rhs)) <- [Int] -> [(String, Exp)] -> [(Int, (String, Exp))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(String, Exp)]
cases
        case Maybe Exp
postAction of
          Maybe Exp
Nothing    -> ((Maybe Int, Exp), (Int, String))
-> [((Maybe Int, Exp), (Int, String))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> Maybe Int
forall k1. k1 -> Maybe k1
Just Int
i, Exp
rhs), (Int
i, String
str))
          Just !Exp
post -> ((Maybe Int, Exp), (Int, String))
-> [((Maybe Int, Exp), (Int, String))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> Maybe Int
forall k1. k1 -> Maybe k1
Just Int
i, (Name -> Exp
VarE '(>>)) Exp -> Exp -> Exp
`AppE` Exp
post Exp -> Exp -> Exp
`AppE` Exp
rhs), (Int
i, String
str))

      !m :: Map (Maybe Int) Exp
m    =  [(Maybe Int, Exp)] -> Map (Maybe Int) Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Maybe Int
forall k1. Maybe k1
Nothing, Exp -> (Exp -> Exp) -> Maybe Exp -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Exp
VarE 'empty) Exp -> Exp
forall a. a -> a
id Maybe Exp
fallback) (Maybe Int, Exp) -> [(Maybe Int, Exp)] -> [(Maybe Int, Exp)]
forall k1. k1 -> [k1] -> [k1]
: [(Maybe Int, Exp)]
branches)
      !trie :: Trie' (Maybe Int, Int, Maybe Int)
trie = [(Int, String)] -> Trie' (Maybe Int, Int, Maybe Int)
compileTrie [(Int, String)]
strings
  in (Map (Maybe Int) Exp
m , Trie' (Maybe Int, Int, Maybe Int)
trie)