{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Regex.Internal.Parser
  ( Parser(..)
  , Node(..)
  , compile
  , compileBounded

  , ParserState
  , prepareParser
  , stepParser
  , finishParser
  , Foldr
  , parseFoldr
  ) where

import Control.Applicative
import Control.Monad.Trans.State.Strict
import Control.Monad.Fix
import Data.Maybe (isJust)
import Data.Primitive.SmallArray
import qualified Data.Foldable as F

import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))
import Regex.Internal.Unique (Unique(..), UniqueSet)
import qualified Regex.Internal.Unique as U

----------
-- Types
----------

-- | A parser compiled from a @'RE' c a@.
data Parser c a where
  PToken  :: !(c -> Maybe a) -> Parser c a
  PFmap   :: !Strictness -> !(a1 -> a) -> !(Parser c a1) -> Parser c a
  PFmap_  :: !(Node c a) -> Parser c a
  PPure   :: a -> Parser c a
  PLiftA2 :: !Strictness -> !(a1 -> a2 -> a) -> !(Parser c a1) -> !(Parser c a2) -> Parser c a
  PEmpty  :: Parser c a
  PAlt    :: !Unique -> !(Parser c a) -> !(Parser c a) -> !(SmallArray (Parser c a)) -> Parser c a
  PFoldGr :: !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a
  PFoldMn :: !Unique -> !Strictness -> !(a -> a1 -> a) -> a -> !(Parser c a1) -> Parser c a
  PMany   :: !Unique -> !(a1 -> a) -> !(a2 -> a) -> !(a2 -> a1 -> a2) -> !a2 -> !(Parser c a1) -> Parser c a

-- | A node in the NFA. Used for recognition.
data Node c a where
  NAccept :: a -> Node c a
  NGuard  :: !Unique -> Node c a -> Node c a
  NToken  :: !(c -> Maybe a1) -> !(Node c a) -> Node c a
  NEmpty  :: Node c a
  NAlt    :: !(Node c a) -> !(Node c a) -> !(SmallArray (Node c a)) -> Node c a
-- Note that NGuard is lazy in the node. We have to introduce laziness in
-- at least one place, to make a graph with loops possible.

------------
-- Compile
------------

-- | \(O(m)\). Compile a @RE c a@ to a @Parser c a@.
--
-- Note: @compile@ does not limit the size of the @RE@. See 'compileBounded'
-- if you would like to limit the size.
-- @RE@s with size greater than @(maxBound::Int) \`div\` 2@ are not supported
-- and the behavior of such a @RE@ is undefined.
compile :: RE c a -> Parser c a
compile :: forall c a. RE c a -> Parser c a
compile RE c a
re = State Unique (Parser c a) -> Unique -> Parser c a
forall s a. State s a -> s -> a
evalState (RE c a -> State Unique (Parser c a)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a
re) (Int -> Unique
Unique Int
0)

nxtU :: State Unique Unique
nxtU :: State Unique Unique
nxtU = (Unique -> (Unique, Unique)) -> State Unique Unique
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Unique -> (Unique, Unique)) -> State Unique Unique)
-> (Unique -> (Unique, Unique)) -> State Unique Unique
forall a b. (a -> b) -> a -> b
$ \Unique
u -> let !u' :: Unique
u' = Int -> Unique
Unique (Unique -> Int
unUnique Unique
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) in (Unique
u, Unique
u')

compileToParser :: RE c a -> State Unique (Parser c a)
compileToParser :: forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a
re = case RE c a
re of
  RToken c -> Maybe a
t -> Parser c a -> State Unique (Parser c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser c a -> State Unique (Parser c a))
-> Parser c a -> State Unique (Parser c a)
forall a b. (a -> b) -> a -> b
$ (c -> Maybe a) -> Parser c a
forall c a. (c -> Maybe a) -> Parser c a
PToken c -> Maybe a
t
  RFmap Strictness
st a1 -> a
f RE c a1
re1 -> Strictness -> (a1 -> a) -> Parser c a1 -> Parser c a
forall a1 a c. Strictness -> (a1 -> a) -> Parser c a1 -> Parser c a
PFmap Strictness
st a1 -> a
f (Parser c a1 -> Parser c a)
-> StateT Unique Identity (Parser c a1)
-> State Unique (Parser c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE c a1 -> StateT Unique Identity (Parser c a1)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a1
re1
  RFmap_ a
a RE c a1
re1 -> Node c a -> Parser c a
forall c a. Node c a -> Parser c a
PFmap_ (Node c a -> Parser c a)
-> StateT Unique Identity (Node c a) -> State Unique (Parser c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> RE c a1 -> StateT Unique Identity (Node c a)
forall c a a1. a -> RE c a1 -> State Unique (Node c a)
compileToNode a
a RE c a1
re1
  RPure a
a -> Parser c a -> State Unique (Parser c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser c a -> State Unique (Parser c a))
-> Parser c a -> State Unique (Parser c a)
forall a b. (a -> b) -> a -> b
$ a -> Parser c a
forall a c. a -> Parser c a
PPure a
a
  RLiftA2 Strictness
st a1 -> a2 -> a
f RE c a1
re1 RE c a2
re2 ->
    (Parser c a1 -> Parser c a2 -> Parser c a)
-> StateT Unique Identity (Parser c a1)
-> StateT Unique Identity (Parser c a2)
-> State Unique (Parser c a)
forall a b c.
(a -> b -> c)
-> StateT Unique Identity a
-> StateT Unique Identity b
-> StateT Unique Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Strictness
-> (a1 -> a2 -> a) -> Parser c a1 -> Parser c a2 -> Parser c a
forall a1 a3 a c.
Strictness
-> (a1 -> a3 -> a) -> Parser c a1 -> Parser c a3 -> Parser c a
PLiftA2 Strictness
st a1 -> a2 -> a
f) (RE c a1 -> StateT Unique Identity (Parser c a1)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a1
re1) (RE c a2 -> StateT Unique Identity (Parser c a2)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a2
re2)
  RE c a
REmpty -> Parser c a -> State Unique (Parser c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Parser c a
forall c a. Parser c a
PEmpty
  RAlt RE c a
re01 RE c a
re02 -> do
    Unique
u <- State Unique Unique
nxtU
    let (RE c a
re1,RE c a
re2,[RE c a]
res) = RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
forall c a. RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
gatherAlts RE c a
re01 RE c a
re02
    Parser c a
p1 <- RE c a -> State Unique (Parser c a)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a
re1
    Parser c a
p2 <- RE c a -> State Unique (Parser c a)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a
re2
    [Parser c a]
ps <- (RE c a -> State Unique (Parser c a))
-> [RE c a] -> StateT Unique Identity [Parser c a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RE c a -> State Unique (Parser c a)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser [RE c a]
res
    Parser c a -> State Unique (Parser c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser c a -> State Unique (Parser c a))
-> Parser c a -> State Unique (Parser c a)
forall a b. (a -> b) -> a -> b
$ Unique
-> Parser c a
-> Parser c a
-> SmallArray (Parser c a)
-> Parser c a
forall c a.
Unique
-> Parser c a
-> Parser c a
-> SmallArray (Parser c a)
-> Parser c a
PAlt Unique
u Parser c a
p1 Parser c a
p2 ([Parser c a] -> SmallArray (Parser c a)
forall a. [a] -> SmallArray a
smallArrayFromList [Parser c a]
ps)
  RFold Strictness
st Greediness
gr a -> a1 -> a
f a
z RE c a1
re1 -> do
    Unique
u <- State Unique Unique
nxtU
    Unique
_localU <- State Unique Unique
nxtU
    case Greediness
gr of
      Greediness
Greedy -> Unique
-> Strictness -> (a -> a1 -> a) -> a -> Parser c a1 -> Parser c a
forall a a1 c.
Unique
-> Strictness -> (a -> a1 -> a) -> a -> Parser c a1 -> Parser c a
PFoldGr Unique
u Strictness
st a -> a1 -> a
f a
z (Parser c a1 -> Parser c a)
-> StateT Unique Identity (Parser c a1)
-> State Unique (Parser c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE c a1 -> StateT Unique Identity (Parser c a1)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a1
re1
      Greediness
Minimal -> Unique
-> Strictness -> (a -> a1 -> a) -> a -> Parser c a1 -> Parser c a
forall a a1 c.
Unique
-> Strictness -> (a -> a1 -> a) -> a -> Parser c a1 -> Parser c a
PFoldMn Unique
u Strictness
st a -> a1 -> a
f a
z (Parser c a1 -> Parser c a)
-> StateT Unique Identity (Parser c a1)
-> State Unique (Parser c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE c a1 -> StateT Unique Identity (Parser c a1)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a1
re1
  RMany a1 -> a
f1 a2 -> a
f2 a2 -> a1 -> a2
f a2
z RE c a1
re1 -> do
    Unique
u <- State Unique Unique
nxtU
    Unique
_localU <- State Unique Unique
nxtU
    Unique
-> (a1 -> a)
-> (a2 -> a)
-> (a2 -> a1 -> a2)
-> a2
-> Parser c a1
-> Parser c a
forall a1 a a3 c.
Unique
-> (a1 -> a)
-> (a3 -> a)
-> (a3 -> a1 -> a3)
-> a3
-> Parser c a1
-> Parser c a
PMany Unique
u a1 -> a
f1 a2 -> a
f2 a2 -> a1 -> a2
f a2
z (Parser c a1 -> Parser c a)
-> StateT Unique Identity (Parser c a1)
-> State Unique (Parser c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE c a1 -> StateT Unique Identity (Parser c a1)
forall c a. RE c a -> State Unique (Parser c a)
compileToParser RE c a1
re1

compileToNode :: forall c a a1. a -> RE c a1 -> State Unique (Node c a)
compileToNode :: forall c a a1. a -> RE c a1 -> State Unique (Node c a)
compileToNode a
a RE c a1
re0 = RE c a1 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a1
re0 (a -> Node c a
forall a c. a -> Node c a
NAccept a
a)
  where
    go :: forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
    go :: forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a2
re Node c a
nxt = case RE c a2
re of
      RToken c -> Maybe a2
t -> Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node c a -> State Unique (Node c a))
-> Node c a -> State Unique (Node c a)
forall a b. (a -> b) -> a -> b
$ (c -> Maybe a2) -> Node c a -> Node c a
forall c a1 a. (c -> Maybe a1) -> Node c a -> Node c a
NToken c -> Maybe a2
t Node c a
nxt
      RFmap Strictness
_ a1 -> a2
_ RE c a1
re1 -> RE c a1 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a1
re1 Node c a
nxt
      RFmap_ a2
_ RE c a1
re1 -> RE c a1 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a1
re1 Node c a
nxt
      RPure a2
_ -> Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node c a
nxt
      RLiftA2 Strictness
_ a1 -> a2 -> a2
_ RE c a1
re1 RE c a2
re2 -> RE c a2 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a2
re2 Node c a
nxt State Unique (Node c a)
-> (Node c a -> State Unique (Node c a)) -> State Unique (Node c a)
forall a b.
StateT Unique Identity a
-> (a -> StateT Unique Identity b) -> StateT Unique Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RE c a1 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a1
re1
      RE c a2
REmpty -> Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node c a
forall c a. Node c a
NEmpty
      RAlt RE c a2
re01 RE c a2
re02 -> do
        Unique
u <- State Unique Unique
nxtU
        let nxt1 :: Node c a
nxt1 = Unique -> Node c a -> Node c a
forall c a. Unique -> Node c a -> Node c a
NGuard Unique
u Node c a
nxt
            (RE c a2
re1,RE c a2
re2,[RE c a2]
res) = RE c a2 -> RE c a2 -> (RE c a2, RE c a2, [RE c a2])
forall c a. RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
gatherAlts RE c a2
re01 RE c a2
re02
        Node c a
n1 <- RE c a2 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a2
re1 Node c a
nxt1
        Node c a
n2 <- RE c a2 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a2
re2 Node c a
nxt1
        [Node c a]
ns <- (RE c a2 -> State Unique (Node c a))
-> [RE c a2] -> StateT Unique Identity [Node c a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((RE c a2 -> Node c a -> State Unique (Node c a))
-> Node c a -> RE c a2 -> State Unique (Node c a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip RE c a2 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go Node c a
nxt1) [RE c a2]
res
        Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node c a -> State Unique (Node c a))
-> Node c a -> State Unique (Node c a)
forall a b. (a -> b) -> a -> b
$ Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
forall c a.
Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
NAlt Node c a
n1 Node c a
n2 ([Node c a] -> SmallArray (Node c a)
forall a. [a] -> SmallArray a
smallArrayFromList [Node c a]
ns)
      RFold Strictness
_ Greediness
gr a2 -> a1 -> a2
_ a2
_ RE c a1
re1 -> Greediness -> RE c a1 -> Node c a -> State Unique (Node c a)
forall a2.
Greediness -> RE c a2 -> Node c a -> State Unique (Node c a)
goMany Greediness
gr RE c a1
re1 Node c a
nxt
      RMany a1 -> a2
_ a2 -> a2
_ a2 -> a1 -> a2
_ a2
_ RE c a1
re1 -> Greediness -> RE c a1 -> Node c a -> State Unique (Node c a)
forall a2.
Greediness -> RE c a2 -> Node c a -> State Unique (Node c a)
goMany Greediness
Greedy RE c a1
re1 Node c a
nxt
    goMany :: forall a2.
              Greediness -> RE c a2 -> Node c a -> State Unique (Node c a)
    goMany :: forall a2.
Greediness -> RE c a2 -> Node c a -> State Unique (Node c a)
goMany Greediness
gr RE c a2
re1 Node c a
nxt = do
      Unique
u <- State Unique Unique
nxtU
      (Node c a -> State Unique (Node c a)) -> State Unique (Node c a)
forall a.
(a -> StateT Unique Identity a) -> StateT Unique Identity a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((Node c a -> State Unique (Node c a)) -> State Unique (Node c a))
-> (Node c a -> State Unique (Node c a)) -> State Unique (Node c a)
forall a b. (a -> b) -> a -> b
$ \Node c a
n -> do
        Node c a
ndown <- RE c a2 -> Node c a -> State Unique (Node c a)
forall a2. RE c a2 -> Node c a -> State Unique (Node c a)
go RE c a2
re1 Node c a
n
        case Greediness
gr of
           Greediness
Greedy -> Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node c a -> State Unique (Node c a))
-> Node c a -> State Unique (Node c a)
forall a b. (a -> b) -> a -> b
$ Unique -> Node c a -> Node c a
forall c a. Unique -> Node c a -> Node c a
NGuard Unique
u (Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
forall c a.
Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
NAlt Node c a
ndown Node c a
nxt SmallArray (Node c a)
forall a. SmallArray a
emptySmallArray)
           Greediness
Minimal -> Node c a -> State Unique (Node c a)
forall a. a -> StateT Unique Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node c a -> State Unique (Node c a))
-> Node c a -> State Unique (Node c a)
forall a b. (a -> b) -> a -> b
$ Unique -> Node c a -> Node c a
forall c a. Unique -> Node c a -> Node c a
NGuard Unique
u (Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
forall c a.
Node c a -> Node c a -> SmallArray (Node c a) -> Node c a
NAlt Node c a
nxt Node c a
ndown SmallArray (Node c a)
forall a. SmallArray a
emptySmallArray)

gatherAlts :: RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
gatherAlts :: forall c a. RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
gatherAlts RE c a
re01 RE c a
re02 = case RE c a -> [RE c a] -> [RE c a]
forall {c} {a}. RE c a -> [RE c a] -> [RE c a]
go RE c a
re01 (RE c a -> [RE c a] -> [RE c a]
forall {c} {a}. RE c a -> [RE c a] -> [RE c a]
go RE c a
re02 []) of
  RE c a
re11:RE c a
re12:[RE c a]
res -> (RE c a
re11, RE c a
re12, [RE c a]
res)
  [RE c a]
_ -> [Char] -> (RE c a, RE c a, [RE c a])
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"Regex.Internal.Parser.gatherAlts: impossible"
  where
    go :: RE c a -> [RE c a] -> [RE c a]
go (RAlt RE c a
re1 RE c a
re2) = RE c a -> [RE c a] -> [RE c a]
go RE c a
re1 ([RE c a] -> [RE c a])
-> ([RE c a] -> [RE c a]) -> [RE c a] -> [RE c a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RE c a -> [RE c a] -> [RE c a]
go RE c a
re2
    go RE c a
re = (RE c a
reRE c a -> [RE c a] -> [RE c a]
forall a. a -> [a] -> [a]
:)

--------------------
-- Compile bounded
--------------------

-- | \(O(\min(l,m))\). Compile a @RE c a@ to a @Parser c a@.
--
-- Returns @Nothing@ if the size of the @RE@ is greater than the provided limit
-- \(l\). You may want to use this if you suspect that the @RE@ may be too
-- large, for instance if the regex is constructed from an untrusted source.
--
-- While the exact size of a @RE@ depends on an internal representation, it can
-- be assumed to be in the same order as the length of a
-- [regex pattern](https://en.wikipedia.org/wiki/Regular_expression#Syntax)
-- corresponding to the @RE@.
compileBounded :: Int -> RE c a -> Maybe (Parser c a)
compileBounded :: forall c a. Int -> RE c a -> Maybe (Parser c a)
compileBounded Int
lim RE c a
re =
  if Int -> RE c a -> Bool
forall c a. Int -> RE c a -> Bool
checkSize Int
lim RE c a
re
  then Parser c a -> Maybe (Parser c a)
forall a. a -> Maybe a
Just (Parser c a -> Maybe (Parser c a))
-> Parser c a -> Maybe (Parser c a)
forall a b. (a -> b) -> a -> b
$! RE c a -> Parser c a
forall c a. RE c a -> Parser c a
compile RE c a
re
  else Maybe (Parser c a)
forall a. Maybe a
Nothing

checkSize :: Int -> RE c a -> Bool
checkSize :: forall c a. Int -> RE c a -> Bool
checkSize Int
lim RE c a
re0 = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (StateT Int Maybe () -> Int -> Maybe ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RE c a -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a
re0) Int
0)
  where
    go :: RE c a1 -> StateT Int Maybe ()
    go :: forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re = case RE c a1
re of
        RToken c -> Maybe a1
_ -> StateT Int Maybe ()
inc
        RFmap Strictness
_ a1 -> a1
_ RE c a1
re1 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1
        RFmap_ a1
_ RE c a1
re1 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1
        RPure a1
_ -> StateT Int Maybe ()
inc
        RLiftA2 Strictness
_ a1 -> a2 -> a1
_ RE c a1
re1 RE c a2
re2 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1 StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a2 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a2
re2
        RE c a1
REmpty -> StateT Int Maybe ()
inc
        RAlt RE c a1
re1 RE c a1
re2 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1 StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re2
        RMany a1 -> a1
_ a2 -> a1
_ a2 -> a1 -> a2
_ a2
_ RE c a1
re1 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1
        RFold Strictness
_ Greediness
_ a1 -> a1 -> a1
_ a1
_ RE c a1
re1 -> StateT Int Maybe ()
inc StateT Int Maybe () -> StateT Int Maybe () -> StateT Int Maybe ()
forall a b.
StateT Int Maybe a -> StateT Int Maybe b -> StateT Int Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE c a1 -> StateT Int Maybe ()
forall c a1. RE c a1 -> StateT Int Maybe ()
go RE c a1
re1
    inc :: StateT Int Maybe ()
inc = do
      Int
n <- StateT Int Maybe Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
      if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lim
      then StateT Int Maybe ()
forall a. StateT Int Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty
      else Int -> StateT Int Maybe ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int -> StateT Int Maybe ()) -> Int -> StateT Int Maybe ()
forall a b. (a -> b) -> a -> b
$! Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1

----------
-- Parse
----------

data Cont c b a where
  CTop     :: Cont c a a
  CFmap    :: !Strictness -> !(b -> a1) -> !(Cont c a1 a) -> Cont c b a
  CFmap_   :: !(Node c a1) -> !(Cont c a1 a) -> Cont c b a
  CLiftA2A :: !Strictness -> !(b -> a2 -> a3) -> !(Parser c a2) -> !(Cont c a3 a) -> Cont c b a
  CLiftA2B :: !Strictness -> !(a1 -> b -> a3) -> a1 -> !(Cont c a3 a) -> Cont c b a
  CAlt     :: !Unique -> !(Cont c b a) -> Cont c b a
  CFoldGr  :: !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a
  CFoldMn  :: !Unique -> !Strictness -> !(Parser c b) -> !(a1 -> b -> a1) -> a1 -> !(Cont c a1 a) -> Cont c b a
  CMany    :: !Unique -> !(Parser c b) -> !(b -> a2) -> !(a1 -> a2) -> !(a1 -> b -> a1) -> !a1 -> !(Cont c a2 a) -> Cont c b a

data NeedCList c a where
  NeedCCons :: !(c -> Maybe b) -> !(Cont c b a) -> !(NeedCList c a) -> NeedCList c a
  NeedCNil :: NeedCList c a

data StepState c a = StepState
  { forall c a. StepState c a -> UniqueSet
sSet :: {-# UNPACK #-} !UniqueSet
  , forall c a. StepState c a -> NeedCList c a
sNeed :: !(NeedCList c a)
  , forall c a. StepState c a -> Maybe a
sResult :: !(Maybe a)
  }

stepStateZero :: StepState c a
stepStateZero :: forall c a. StepState c a
stepStateZero = UniqueSet -> NeedCList c a -> Maybe a -> StepState c a
forall c a. UniqueSet -> NeedCList c a -> Maybe a -> StepState c a
StepState UniqueSet
U.empty NeedCList c a
forall c a. NeedCList c a
NeedCNil Maybe a
forall a. Maybe a
Nothing

-- Note: Ideally we would have
-- down :: Parser c b -> Cont c b a -> State (StepState c a) ()
-- and similar downNode and up, but GHC is unable to optimize it to be
-- equivalent to the current code.
--
-- Using State is pretty convenient though, so it is used in branches. This
-- seems to get optimized well enough.

sMember :: Unique -> State (StepState c a) Bool
sMember :: forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u = (StepState c a -> Bool) -> StateT (StepState c a) Identity Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((StepState c a -> Bool) -> StateT (StepState c a) Identity Bool)
-> (StepState c a -> Bool) -> StateT (StepState c a) Identity Bool
forall a b. (a -> b) -> a -> b
$ \StepState c a
pt -> Unique -> UniqueSet -> Bool
U.member Unique
u (StepState c a -> UniqueSet
forall c a. StepState c a -> UniqueSet
sSet StepState c a
pt)

sInsert :: Unique -> State (StepState c a) ()
sInsert :: forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u = (StepState c a -> StepState c a)
-> StateT (StepState c a) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a)
 -> StateT (StepState c a) Identity ())
-> (StepState c a -> StepState c a)
-> StateT (StepState c a) Identity ()
forall a b. (a -> b) -> a -> b
$ \StepState c a
pt -> StepState c a
pt { sSet = U.insert u (sSet pt) }

down :: Parser c b -> Cont c b a -> StepState c a -> StepState c a
down :: forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p !Cont c b a
ct !StepState c a
pt = case Parser c b
p of
  PToken c -> Maybe b
t -> StepState c a
pt { sNeed = NeedCCons t ct (sNeed pt) }
  PFmap Strictness
st a1 -> b
f Parser c a1
p1 -> Parser c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a1
p1 (Strictness -> (a1 -> b) -> Cont c b a -> Cont c a1 a
forall b a1 c a.
Strictness -> (b -> a1) -> Cont c a1 a -> Cont c b a
CFmap Strictness
st a1 -> b
f Cont c b a
ct) StepState c a
pt
  PFmap_ Node c b
n -> Node c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Node c b -> Cont c b a -> StepState c a -> StepState c a
downNode Node c b
n Cont c b a
ct StepState c a
pt
  PPure b
b -> b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
b Cont c b a
ct StepState c a
pt
  PLiftA2 Strictness
st a1 -> a2 -> b
f Parser c a1
p1 Parser c a2
p2 -> Parser c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a1
p1 (Strictness
-> (a1 -> a2 -> b) -> Parser c a2 -> Cont c b a -> Cont c a1 a
forall b a1 a3 c a.
Strictness
-> (b -> a1 -> a3) -> Parser c a1 -> Cont c a3 a -> Cont c b a
CLiftA2A Strictness
st a1 -> a2 -> b
f Parser c a2
p2 Cont c b a
ct) StepState c a
pt
  Parser c b
PEmpty -> StepState c a
pt
  PAlt Unique
u Parser c b
p1 Parser c b
p2 SmallArray (Parser c b)
ps ->
    let ct1 :: Cont c b a
ct1 = Unique -> Cont c b a -> Cont c b a
forall c b a. Unique -> Cont c b a -> Cont c b a
CAlt Unique
u Cont c b a
ct
    in (StepState c a -> Parser c b -> StepState c a)
-> StepState c a -> SmallArray (Parser c b) -> StepState c a
forall b a. (b -> a -> b) -> b -> SmallArray a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\StepState c a
pt' Parser c b
p' -> Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p' Cont c b a
ct1 StepState c a
pt') (Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p2 Cont c b a
ct1 (Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p1 Cont c b a
ct1 StepState c a
pt)) SmallArray (Parser c b)
ps
  PFoldGr Unique
u Strictness
st b -> a1 -> b
f b
z Parser c a1
p1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert (Unique -> Unique
localU Unique
u)
      (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a1
p1 (Unique
-> Strictness
-> Parser c a1
-> (b -> a1 -> b)
-> b
-> Cont c b a
-> Cont c a1 a
forall c b a1 a.
Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
CFoldGr Unique
u Strictness
st Parser c a1
p1 b -> a1 -> b
f b
z Cont c b a
ct)
      StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
        Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
z Cont c b a
ct
  PFoldMn Unique
u Strictness
st b -> a1 -> b
f b
z Parser c a1
p1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember (Unique -> Unique
localU Unique
u)) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
z Cont c b a
ct
      Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
      (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a1
p1 (Unique
-> Strictness
-> Parser c a1
-> (b -> a1 -> b)
-> b
-> Cont c b a
-> Cont c a1 a
forall c b a1 a.
Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
CFoldMn Unique
u Strictness
st Parser c a1
p1 b -> a1 -> b
f b
z Cont c b a
ct)
  PMany Unique
u a1 -> b
f1 a2 -> b
f2 a2 -> a1 -> a2
f a2
z Parser c a1
p1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert (Unique -> Unique
localU Unique
u)
      (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a1
p1 (Unique
-> Parser c a1
-> (a1 -> b)
-> (a2 -> b)
-> (a2 -> a1 -> a2)
-> a2
-> Cont c b a
-> Cont c a1 a
forall c b a1 a3 a.
Unique
-> Parser c b
-> (b -> a1)
-> (a3 -> a1)
-> (a3 -> b -> a3)
-> a3
-> Cont c a1 a
-> Cont c b a
CMany Unique
u Parser c a1
p1 a1 -> b
f1 a2 -> b
f2 a2 -> a1 -> a2
f a2
z Cont c b a
ct)
      StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
        Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
        let !x :: b
x = a2 -> b
f2 a2
z
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
x Cont c b a
ct

downNode :: Node c b -> Cont c b a -> StepState c a -> StepState c a
downNode :: forall c b a.
Node c b -> Cont c b a -> StepState c a -> StepState c a
downNode Node c b
n0 !Cont c b a
ct = Node c b -> StepState c a -> StepState c a
go Node c b
n0
  where
    go :: Node c b -> StepState c a -> StepState c a
go Node c b
n !StepState c a
pt = case Node c b
n of
      NAccept b
b -> b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
b Cont c b a
ct StepState c a
pt
      NGuard Unique
u Node c b
n1
        | Unique -> UniqueSet -> Bool
U.member Unique
u (StepState c a -> UniqueSet
forall c a. StepState c a -> UniqueSet
sSet StepState c a
pt) -> StepState c a
pt
        | Bool
otherwise -> Node c b -> StepState c a -> StepState c a
go Node c b
n1 (StepState c a
pt { sSet = U.insert u (sSet pt) })
      NToken c -> Maybe a1
t Node c b
nxt ->
        StepState c a
pt { sNeed = NeedCCons t (CFmap_ nxt ct) (sNeed pt) }
      Node c b
NEmpty -> StepState c a
pt
      NAlt Node c b
n1 Node c b
n2 SmallArray (Node c b)
ns -> (StepState c a -> Node c b -> StepState c a)
-> StepState c a -> SmallArray (Node c b) -> StepState c a
forall b a. (b -> a -> b) -> b -> SmallArray a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' ((Node c b -> StepState c a -> StepState c a)
-> StepState c a -> Node c b -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node c b -> StepState c a -> StepState c a
go) (Node c b -> StepState c a -> StepState c a
go Node c b
n2 (Node c b -> StepState c a -> StepState c a
go Node c b
n1 StepState c a
pt)) SmallArray (Node c b)
ns

up :: b -> Cont c b a -> StepState c a -> StepState c a
up :: forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
b Cont c b a
ct !StepState c a
pt = case Cont c b a
ct of
  Cont c b a
CTop -> StepState c a
pt { sResult = sResult pt <|> Just b }
  CFmap Strictness
st b -> a1
f Cont c a1 a
ct1 -> case Strictness
st of
    Strictness
Strict -> let !x :: a1
x = b -> a1
f b
b in a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a1
x Cont c a1 a
ct1 StepState c a
pt
    Strictness
NonStrict -> a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up (b -> a1
f b
b) Cont c a1 a
ct1 StepState c a
pt
  CFmap_ Node c a1
n Cont c a1 a
ct1 -> Node c a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall c b a.
Node c b -> Cont c b a -> StepState c a -> StepState c a
downNode Node c a1
n Cont c a1 a
ct1 StepState c a
pt
  CLiftA2A Strictness
st b -> a2 -> a3
f Parser c a2
p1 Cont c a3 a
ct1 -> Parser c a2 -> Cont c a2 a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a2
p1 (Strictness -> (b -> a2 -> a3) -> b -> Cont c a3 a -> Cont c a2 a
forall a1 b a3 c a.
Strictness -> (a1 -> b -> a3) -> a1 -> Cont c a3 a -> Cont c b a
CLiftA2B Strictness
st b -> a2 -> a3
f b
b Cont c a3 a
ct1) StepState c a
pt
  CLiftA2B Strictness
st a1 -> b -> a3
f a1
a Cont c a3 a
ct1 -> case Strictness
st of
    Strictness
Strict -> let !x :: a3
x = a1 -> b -> a3
f a1
a b
b in a3 -> Cont c a3 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a3
x Cont c a3 a
ct1 StepState c a
pt
    Strictness
NonStrict -> a3 -> Cont c a3 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up (a1 -> b -> a3
f a1
a b
b) Cont c a3 a
ct1 StepState c a
pt
  CAlt Unique
u Cont c b a
ct1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
      (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
b Cont c b a
ct1
  CFoldGr Unique
u Strictness
st Parser c b
p1 a1 -> b -> a1
f a1
z Cont c a1 a
ct1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
lc <- Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember (Unique -> Unique
localU Unique
u)
      if Bool
lc then do
        Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a1
z Cont c a1 a
ct1
      else do
        let go :: a1 -> State (StepState c a) ()
go a1
z1 = do
              (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p1 (Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
forall c b a1 a.
Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
CFoldGr Unique
u Strictness
st Parser c b
p1 a1 -> b -> a1
f a1
z1 Cont c a1 a
ct1)
              Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
              (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a1
z1 Cont c a1 a
ct1
            {-# INLINE go #-}
        case Strictness
st of
          Strictness
Strict -> let !z1 :: a1
z1 = a1 -> b -> a1
f a1
z b
b in a1 -> State (StepState c a) ()
go a1
z1
          Strictness
NonStrict -> a1 -> State (StepState c a) ()
go (a1 -> b -> a1
f a1
z b
b)
  CFoldMn Unique
u Strictness
st Parser c b
p1 a1 -> b -> a1
f a1
z Cont c a1 a
ct1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      let go :: a1 -> State (StepState c a) ()
go a1
z1 = do
            Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert (Unique -> Unique
localU Unique
u)
            (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ a1 -> Cont c a1 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a1
z1 Cont c a1 a
ct1
            StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
              Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
              (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p1 (Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
forall c b a1 a.
Unique
-> Strictness
-> Parser c b
-> (a1 -> b -> a1)
-> a1
-> Cont c a1 a
-> Cont c b a
CFoldMn Unique
u Strictness
st Parser c b
p1 a1 -> b -> a1
f a1
z1 Cont c a1 a
ct1)
          {-# INLINE go #-}
      case Strictness
st of
        Strictness
Strict -> let !z1 :: a1
z1 = a1 -> b -> a1
f a1
z b
b in a1 -> State (StepState c a) ()
go a1
z1
        Strictness
NonStrict -> a1 -> State (StepState c a) ()
go (a1 -> b -> a1
f a1
z b
b)
  CMany Unique
u Parser c b
p1 b -> a2
f1 a1 -> a2
f2 a1 -> b -> a1
f a1
z Cont c a2 a
ct1 -> (State (StepState c a) () -> StepState c a -> StepState c a)
-> StepState c a -> State (StepState c a) () -> StepState c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (StepState c a) () -> StepState c a -> StepState c a
forall s a. State s a -> s -> s
execState StepState c a
pt (State (StepState c a) () -> StepState c a)
-> State (StepState c a) () -> StepState c a
forall a b. (a -> b) -> a -> b
$
    StateT (StepState c a) Identity Bool
-> State (StepState c a) () -> State (StepState c a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember Unique
u) (State (StepState c a) () -> State (StepState c a) ())
-> State (StepState c a) () -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
lc <- Unique -> StateT (StepState c a) Identity Bool
forall c a. Unique -> State (StepState c a) Bool
sMember (Unique -> Unique
localU Unique
u)
      if Bool
lc then do
        Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
        let !x :: a2
x = b -> a2
f1 b
b
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ a2 -> Cont c a2 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a2
x Cont c a2 a
ct1
      else do
        let !z1 :: a1
z1 = a1 -> b -> a1
f a1
z b
b
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ Parser c b -> Cont c b a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c b
p1 (Unique
-> Parser c b
-> (b -> a2)
-> (a1 -> a2)
-> (a1 -> b -> a1)
-> a1
-> Cont c a2 a
-> Cont c b a
forall c b a1 a3 a.
Unique
-> Parser c b
-> (b -> a1)
-> (a3 -> a1)
-> (a3 -> b -> a3)
-> a3
-> Cont c a1 a
-> Cont c b a
CMany Unique
u Parser c b
p1 b -> a2
f1 a1 -> a2
f2 a1 -> b -> a1
f a1
z1 Cont c a2 a
ct1)
        Unique -> State (StepState c a) ()
forall c a. Unique -> State (StepState c a) ()
sInsert Unique
u
        let !x :: a2
x = a1 -> a2
f2 a1
z1
        (StepState c a -> StepState c a) -> State (StepState c a) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((StepState c a -> StepState c a) -> State (StepState c a) ())
-> (StepState c a -> StepState c a) -> State (StepState c a) ()
forall a b. (a -> b) -> a -> b
$ a2 -> Cont c a2 a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up a2
x Cont c a2 a
ct1

localU :: Unique -> Unique
localU :: Unique -> Unique
localU = Int -> Unique
Unique (Int -> Unique) -> (Unique -> Int) -> Unique -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (Unique -> Int) -> Unique -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
unUnique

--------------------
-- Running a Parser
--------------------

-- | The state maintained for parsing.
data ParserState c a = ParserState
  { forall c a. ParserState c a -> NeedCList c a
psNeed :: !(NeedCList c a)
  , forall c a. ParserState c a -> Maybe a
psResult :: !(Maybe a)
  }

-- | \(O(m \log m)\). Prepare a parser for input.
prepareParser :: Parser c a -> ParserState c a
prepareParser :: forall c a. Parser c a -> ParserState c a
prepareParser Parser c a
p = StepState c a -> ParserState c a
forall c a. StepState c a -> ParserState c a
toParserState (Parser c a -> Cont c a a -> StepState c a -> StepState c a
forall c b a.
Parser c b -> Cont c b a -> StepState c a -> StepState c a
down Parser c a
p Cont c a a
forall c a. Cont c a a
CTop StepState c a
forall c a. StepState c a
stepStateZero)

-- | \(O(m \log m)\). Step a parser by feeding a single element @c@. Returns
-- @Nothing@ if the parse has failed regardless of further input. Otherwise,
-- returns an updated @ParserState@.
stepParser :: ParserState c a -> c -> Maybe (ParserState c a)
stepParser :: forall c a. ParserState c a -> c -> Maybe (ParserState c a)
stepParser ParserState c a
ps c
c = case ParserState c a -> NeedCList c a
forall c a. ParserState c a -> NeedCList c a
psNeed ParserState c a
ps of
  NeedCList c a
NeedCNil -> Maybe (ParserState c a)
forall a. Maybe a
Nothing
  NeedCList c a
needs -> ParserState c a -> Maybe (ParserState c a)
forall a. a -> Maybe a
Just (ParserState c a -> Maybe (ParserState c a))
-> ParserState c a -> Maybe (ParserState c a)
forall a b. (a -> b) -> a -> b
$! StepState c a -> ParserState c a
forall c a. StepState c a -> ParserState c a
toParserState (NeedCList c a -> StepState c a
go NeedCList c a
needs)
  where
    go :: NeedCList c a -> StepState c a
go (NeedCCons c -> Maybe b
t Cont c b a
ct NeedCList c a
rest) =
      let !pt :: StepState c a
pt = NeedCList c a -> StepState c a
go NeedCList c a
rest
      in StepState c a -> (b -> StepState c a) -> Maybe b -> StepState c a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StepState c a
pt (\b
b -> b -> Cont c b a -> StepState c a -> StepState c a
forall b c a. b -> Cont c b a -> StepState c a -> StepState c a
up b
b Cont c b a
ct StepState c a
pt) (c -> Maybe b
t c
c)
    go NeedCList c a
NeedCNil = StepState c a
forall c a. StepState c a
stepStateZero
{-# INLINE stepParser #-}

-- | \(O(1)\). Get the parse result for the input fed into the parser so far.
finishParser :: ParserState c a -> Maybe a
finishParser :: forall c a. ParserState c a -> Maybe a
finishParser = ParserState c a -> Maybe a
forall c a. ParserState c a -> Maybe a
psResult

toParserState :: StepState c a -> ParserState c a
toParserState :: forall c a. StepState c a -> ParserState c a
toParserState StepState c a
pt = ParserState
  { psNeed :: NeedCList c a
psNeed = StepState c a -> NeedCList c a
forall c a. StepState c a -> NeedCList c a
sNeed StepState c a
pt
  , psResult :: Maybe a
psResult = StepState c a -> Maybe a
forall c a. StepState c a -> Maybe a
sResult StepState c a
pt
  }

-- | A fold function.
type Foldr f a = forall b. (a -> b -> b) -> b -> f -> b

-- | \(O(mn \log m)\). Run a parser given a sequence @f@ and a fold of @f@.
parseFoldr :: Foldr f c -> Parser c a -> f -> Maybe a
parseFoldr :: forall f c a. Foldr f c -> Parser c a -> f -> Maybe a
parseFoldr Foldr f c
fr = \Parser c a
p f
xs -> (c -> (ParserState c a -> Maybe a) -> ParserState c a -> Maybe a)
-> (ParserState c a -> Maybe a) -> f -> ParserState c a -> Maybe a
Foldr f c
fr c -> (ParserState c a -> Maybe a) -> ParserState c a -> Maybe a
forall {c} {a} {b}.
c -> (ParserState c a -> Maybe b) -> ParserState c a -> Maybe b
f ParserState c a -> Maybe a
forall c a. ParserState c a -> Maybe a
finishParser f
xs (Parser c a -> ParserState c a
forall c a. Parser c a -> ParserState c a
prepareParser Parser c a
p)
  where
    f :: c -> (ParserState c a -> Maybe b) -> ParserState c a -> Maybe b
f c
c ParserState c a -> Maybe b
k = \ParserState c a
ps -> ParserState c a -> c -> Maybe (ParserState c a)
forall c a. ParserState c a -> c -> Maybe (ParserState c a)
stepParser ParserState c a
ps c
c Maybe (ParserState c a) -> (ParserState c a -> Maybe b) -> Maybe b
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParserState c a -> Maybe b
k
{-# INLINE parseFoldr #-}

---------
-- Util
---------

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
mb m ()
mx = do
  Bool
b <- m Bool
mb
  if Bool
b then () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else m ()
mx

----------
-- Notes
----------

-- Note [About the algorithm]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- To parse using a regex, we compile the regex into a non-deterministic finite
-- automata (NFA). Actually, we only only do this for recognition, i.e. checking
-- whether a sequence satisfies a regex. This is done if the regex is a RFmap_.
--
-- To parse into a value, we have to do more work. We keep the regex as a tree
-- (Parser), but we preserve the path taken down the tree, like a zipper.
-- This lets us go up the tree and continue parsing, once we parse a c.
-- If you squint your eyes, this is also an NFA, only each edge of the NFA is
-- broken into multiple steps up and down the tree.
--
-- Recognition using the NFA is faster than parsing, unsurprisingly.
-- A Parser tree can have NFAs as children. This means that if some subtree of
-- the regex only attempts to recognize some input, it doesn't pay the extra
-- cost of parsing.
--
-- Key objective: O(mn log m) time parsing. This means that for every c fed into
-- the parser, we are allowed to take no more than O(m log m) time.
--
-- How is this ensured?
-- 1. The compiled regex must have O(m) nodes and O(m) edges. The Parser tree
--    satisfies this, of course, since it reflects the regex itself. The NFA
--    also satisfies this, implemented as Thompson's construction:
--    https://en.wikipedia.org/wiki/Thompson%27s_construction
-- 2. For every c, no edge is traversed twice. Tree edges are bidirectional
--    unlike NFA edges, so an NFA edge may be traversed only once and a tree
--    edge may be traversed once in each direction.
--
-- NFA guards: To ensure each NFA edge can be traversed only once, guard nodes
-- (NGuard) carry a Unique which can be stored in a set (sSet). Guard nodes are
-- created during compilation whenever two nodes would lead into one node:
-- A->C, B->C. A guard node is added, such that it becomes A->G, B->G, G->C.
--
-- Parser guards: Parser guards are more tricky.
-- Alt: There are two ways into an Alt node when going up. So, an Alt node
--   carries a Unique is stored in sSet and guards upward travel through the
--   node.
-- FoldGr: There are two ways into a FoldGr node, one going down and one going
--   up. But, we can't just a use a Unique to guard entry into it because we
--   want to handle loopy cases correctly! A loopy case is where we reach the
--   same node in the tree by going up and down the edges without consuming
--   input. To detect this, we use a separate Unique (localU) when going down.
--   If we find it set when going up, we are looping. When we send up a value,
--   looping or not, we guard entry into the node using its (not localU) Unique.
-- Many: A Many node is just like FoldlGr, only the looping case is handled
--   specially.
-- FoldMn: Like FoldGr, there are two ways into a FoldlMn node, one going down
--   and one going up, and we must handle loopy cases correctly. A FoldMn sends
--   a value up before going down. So, the localU is set when going up and if
--   we find it when going down, we are looping. When we send down a value, we
--   guard entry into the node using its (not localU) Unique.

-- Note [Regex optimizations]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Currently, the only optimization performed is
--
-- * Gather multiple RAlts into a single multi-way branching PAlt/NAlt. It's
--   better to multi-way branch at a flat array instead of nested 2-way
--   branches, much less pointer-chasing.
--
-- Other possible optimizations are possible when compiling, such as removing
-- paths going to REmpty. Or even at the RE level by applying laws, such as
-- liftA2 f REmpty x = REmpty or liftA2 f (RPure x) y = RFmap (f x) y.
-- I don't know yet if this is worth doing.