{-# LANGUAGE StrictData #-}

module Little.Earley.Internal.Core where

import Control.Monad.State
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

-- | Grammars with non-terminal symbols @n@, terminal symbols @t@, and tokens @c@.
--
-- A grammar defines a language, which is a set of sequences of tokens @c@.
--
-- Two basic choices for @t@ and @c@ are:
--
-- - @t = 'Little.Earley.Examples.CharT'@ and @c = Char@,
--   with @'match' = 'Little.Earley.Examples.matchCharT'@: then the input @[c]@ is a @String@.
--
-- - @t = String@ and @c = String@, with @'match' = (==)@:
--   then the input @[c]@ is a @[String]@, which can be produced using 'words';
--   just remember to put spaces around operators and parentheses.
--
-- See also examples in "Little.Earley.Examples".
data Grammar n t c = Grammar
  { Grammar n t c -> n -> [Rule n t]
rules :: n -> [Rule n t]  -- ^ Production rules associated with each non-terminal symbol.
  , Grammar n t c -> t -> c -> Bool
match :: t -> c -> Bool   -- ^ Match a token @c@ with a terminal symbol @t@.
  , Grammar n t c -> n -> Bool
isNullable :: n -> Bool
    -- ^ Predicate for non-terminal symbols which may expand to the empty string.
    -- This function MUST be correct for the library to work.
    -- It can be populated automatically using 'mkGrammar'.
  }

-- | Construct a grammar given the fields 'rules' and 'match',
-- implicitly populating 'isNullable'.
mkGrammar :: (Ord n, Bounded n, Enum n) => (n -> [Rule n t]) -> (t -> c -> Bool) -> Grammar n t c
mkGrammar :: (n -> [Rule n t]) -> (t -> c -> Bool) -> Grammar n t c
mkGrammar n -> [Rule n t]
rs t -> c -> Bool
mc = Grammar :: forall n t c.
(n -> [Rule n t])
-> (t -> c -> Bool) -> (n -> Bool) -> Grammar n t c
Grammar
  { rules :: n -> [Rule n t]
rules = n -> [Rule n t]
rs
  , match :: t -> c -> Bool
match = t -> c -> Bool
mc
  , isNullable :: n -> Bool
isNullable = (n -> Set n -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set n
vs)
  } where vs :: Set n
vs = (n -> [Rule n t]) -> [n] -> Set n
forall n t. Ord n => (n -> [Rule n t]) -> [n] -> Set n
nullableSymbols n -> [Rule n t]
rs [n
forall a. Bounded a => a
minBound .. n
forall a. Bounded a => a
maxBound]

-- | Compute the set of non-terminal symbols which may expand to the empty string,
-- given an enumeration of all non-terminal symbols.
nullableSymbols :: Ord n => (n -> [Rule n t]) -> [n] -> Set n
nullableSymbols :: (n -> [Rule n t]) -> [n] -> Set n
nullableSymbols n -> [Rule n t]
g [n]
ns = Set n -> Set n
loop Set n
forall a. Set a
Set.empty where
  loop :: Set n -> Set n
loop Set n
vs =
    let vs' :: Set n
vs' = [n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set n -> n -> Bool
isNullable_ Set n
vs) [n]
ns) in
    if Set n
vs Set n -> Set n -> Bool
forall a. Eq a => a -> a -> Bool
== Set n
vs' then Set n
vs else Set n -> Set n
loop Set n
vs'
  isNullable_ :: Set n -> n -> Bool
isNullable_ Set n
vs n
n = (Rule n t -> Bool) -> [Rule n t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Atom n t -> Bool) -> Rule n t -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set n -> Atom n t -> Bool
forall a t. Ord a => Set a -> Atom a t -> Bool
isNullableS Set n
vs)) (n -> [Rule n t]
g n
n)
  isNullableS :: Set a -> Atom a t -> Bool
isNullableS Set a
vs (N a
n) = a
n a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
vs
  isNullableS Set a
_vs (T t
_) = Bool
False

-- | A production rule is a sequence of atoms.
type Rule n t = [Atom n t]

-- | An atom is either a non-terminal or a terminal.
data Atom n t = N n | T t
  deriving (Atom n t -> Atom n t -> Bool
(Atom n t -> Atom n t -> Bool)
-> (Atom n t -> Atom n t -> Bool) -> Eq (Atom n t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n t. (Eq n, Eq t) => Atom n t -> Atom n t -> Bool
/= :: Atom n t -> Atom n t -> Bool
$c/= :: forall n t. (Eq n, Eq t) => Atom n t -> Atom n t -> Bool
== :: Atom n t -> Atom n t -> Bool
$c== :: forall n t. (Eq n, Eq t) => Atom n t -> Atom n t -> Bool
Eq, Eq (Atom n t)
Eq (Atom n t)
-> (Atom n t -> Atom n t -> Ordering)
-> (Atom n t -> Atom n t -> Bool)
-> (Atom n t -> Atom n t -> Bool)
-> (Atom n t -> Atom n t -> Bool)
-> (Atom n t -> Atom n t -> Bool)
-> (Atom n t -> Atom n t -> Atom n t)
-> (Atom n t -> Atom n t -> Atom n t)
-> Ord (Atom n t)
Atom n t -> Atom n t -> Bool
Atom n t -> Atom n t -> Ordering
Atom n t -> Atom n t -> Atom n t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n t. (Ord n, Ord t) => Eq (Atom n t)
forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Bool
forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Ordering
forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Atom n t
min :: Atom n t -> Atom n t -> Atom n t
$cmin :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Atom n t
max :: Atom n t -> Atom n t -> Atom n t
$cmax :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Atom n t
>= :: Atom n t -> Atom n t -> Bool
$c>= :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Bool
> :: Atom n t -> Atom n t -> Bool
$c> :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Bool
<= :: Atom n t -> Atom n t -> Bool
$c<= :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Bool
< :: Atom n t -> Atom n t -> Bool
$c< :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Bool
compare :: Atom n t -> Atom n t -> Ordering
$ccompare :: forall n t. (Ord n, Ord t) => Atom n t -> Atom n t -> Ordering
$cp1Ord :: forall n t. (Ord n, Ord t) => Eq (Atom n t)
Ord, Int -> Atom n t -> ShowS
[Atom n t] -> ShowS
Atom n t -> String
(Int -> Atom n t -> ShowS)
-> (Atom n t -> String) -> ([Atom n t] -> ShowS) -> Show (Atom n t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n t. (Show n, Show t) => Int -> Atom n t -> ShowS
forall n t. (Show n, Show t) => [Atom n t] -> ShowS
forall n t. (Show n, Show t) => Atom n t -> String
showList :: [Atom n t] -> ShowS
$cshowList :: forall n t. (Show n, Show t) => [Atom n t] -> ShowS
show :: Atom n t -> String
$cshow :: forall n t. (Show n, Show t) => Atom n t -> String
showsPrec :: Int -> Atom n t -> ShowS
$cshowsPrec :: forall n t. (Show n, Show t) => Int -> Atom n t -> ShowS
Show)

-- | A rule can be identified by a non-terminal and an index into all
-- of the associated rules of that non-terminal.
data RuleId n = RuleId n Int
  deriving (RuleId n -> RuleId n -> Bool
(RuleId n -> RuleId n -> Bool)
-> (RuleId n -> RuleId n -> Bool) -> Eq (RuleId n)
forall n. Eq n => RuleId n -> RuleId n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RuleId n -> RuleId n -> Bool
$c/= :: forall n. Eq n => RuleId n -> RuleId n -> Bool
== :: RuleId n -> RuleId n -> Bool
$c== :: forall n. Eq n => RuleId n -> RuleId n -> Bool
Eq, Eq (RuleId n)
Eq (RuleId n)
-> (RuleId n -> RuleId n -> Ordering)
-> (RuleId n -> RuleId n -> Bool)
-> (RuleId n -> RuleId n -> Bool)
-> (RuleId n -> RuleId n -> Bool)
-> (RuleId n -> RuleId n -> Bool)
-> (RuleId n -> RuleId n -> RuleId n)
-> (RuleId n -> RuleId n -> RuleId n)
-> Ord (RuleId n)
RuleId n -> RuleId n -> Bool
RuleId n -> RuleId n -> Ordering
RuleId n -> RuleId n -> RuleId n
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n. Ord n => Eq (RuleId n)
forall n. Ord n => RuleId n -> RuleId n -> Bool
forall n. Ord n => RuleId n -> RuleId n -> Ordering
forall n. Ord n => RuleId n -> RuleId n -> RuleId n
min :: RuleId n -> RuleId n -> RuleId n
$cmin :: forall n. Ord n => RuleId n -> RuleId n -> RuleId n
max :: RuleId n -> RuleId n -> RuleId n
$cmax :: forall n. Ord n => RuleId n -> RuleId n -> RuleId n
>= :: RuleId n -> RuleId n -> Bool
$c>= :: forall n. Ord n => RuleId n -> RuleId n -> Bool
> :: RuleId n -> RuleId n -> Bool
$c> :: forall n. Ord n => RuleId n -> RuleId n -> Bool
<= :: RuleId n -> RuleId n -> Bool
$c<= :: forall n. Ord n => RuleId n -> RuleId n -> Bool
< :: RuleId n -> RuleId n -> Bool
$c< :: forall n. Ord n => RuleId n -> RuleId n -> Bool
compare :: RuleId n -> RuleId n -> Ordering
$ccompare :: forall n. Ord n => RuleId n -> RuleId n -> Ordering
$cp1Ord :: forall n. Ord n => Eq (RuleId n)
Ord, Int -> RuleId n -> ShowS
[RuleId n] -> ShowS
RuleId n -> String
(Int -> RuleId n -> ShowS)
-> (RuleId n -> String) -> ([RuleId n] -> ShowS) -> Show (RuleId n)
forall n. Show n => Int -> RuleId n -> ShowS
forall n. Show n => [RuleId n] -> ShowS
forall n. Show n => RuleId n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuleId n] -> ShowS
$cshowList :: forall n. Show n => [RuleId n] -> ShowS
show :: RuleId n -> String
$cshow :: forall n. Show n => RuleId n -> String
showsPrec :: Int -> RuleId n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> RuleId n -> ShowS
Show)

data Item n t = Item (RuleId n) [Atom n t] Int
  deriving (Item n t -> Item n t -> Bool
(Item n t -> Item n t -> Bool)
-> (Item n t -> Item n t -> Bool) -> Eq (Item n t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n t. (Eq n, Eq t) => Item n t -> Item n t -> Bool
/= :: Item n t -> Item n t -> Bool
$c/= :: forall n t. (Eq n, Eq t) => Item n t -> Item n t -> Bool
== :: Item n t -> Item n t -> Bool
$c== :: forall n t. (Eq n, Eq t) => Item n t -> Item n t -> Bool
Eq, Eq (Item n t)
Eq (Item n t)
-> (Item n t -> Item n t -> Ordering)
-> (Item n t -> Item n t -> Bool)
-> (Item n t -> Item n t -> Bool)
-> (Item n t -> Item n t -> Bool)
-> (Item n t -> Item n t -> Bool)
-> (Item n t -> Item n t -> Item n t)
-> (Item n t -> Item n t -> Item n t)
-> Ord (Item n t)
Item n t -> Item n t -> Bool
Item n t -> Item n t -> Ordering
Item n t -> Item n t -> Item n t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n t. (Ord n, Ord t) => Eq (Item n t)
forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Bool
forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Ordering
forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Item n t
min :: Item n t -> Item n t -> Item n t
$cmin :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Item n t
max :: Item n t -> Item n t -> Item n t
$cmax :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Item n t
>= :: Item n t -> Item n t -> Bool
$c>= :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Bool
> :: Item n t -> Item n t -> Bool
$c> :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Bool
<= :: Item n t -> Item n t -> Bool
$c<= :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Bool
< :: Item n t -> Item n t -> Bool
$c< :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Bool
compare :: Item n t -> Item n t -> Ordering
$ccompare :: forall n t. (Ord n, Ord t) => Item n t -> Item n t -> Ordering
$cp1Ord :: forall n t. (Ord n, Ord t) => Eq (Item n t)
Ord, Int -> Item n t -> ShowS
[Item n t] -> ShowS
Item n t -> String
(Int -> Item n t -> ShowS)
-> (Item n t -> String) -> ([Item n t] -> ShowS) -> Show (Item n t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n t. (Show n, Show t) => Int -> Item n t -> ShowS
forall n t. (Show n, Show t) => [Item n t] -> ShowS
forall n t. (Show n, Show t) => Item n t -> String
showList :: [Item n t] -> ShowS
$cshowList :: forall n t. (Show n, Show t) => [Item n t] -> ShowS
show :: Item n t -> String
$cshow :: forall n t. (Show n, Show t) => Item n t -> String
showsPrec :: Int -> Item n t -> ShowS
$cshowsPrec :: forall n t. (Show n, Show t) => Int -> Item n t -> ShowS
Show)

data S n t = S
  { S n t -> Seq (Set (Item n t))
itemSets :: Seq (Set (Item n t))
  , S n t -> Set (Item n t)
currItemSet :: Set (Item n t)
  , S n t -> Set (Item n t)
nextItemSet :: Set (Item n t)
  , S n t -> Int
currIndex :: Int
  , S n t -> [Item n t]
todo :: [Item n t]
  } deriving (S n t -> S n t -> Bool
(S n t -> S n t -> Bool) -> (S n t -> S n t -> Bool) -> Eq (S n t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n t. (Eq n, Eq t) => S n t -> S n t -> Bool
/= :: S n t -> S n t -> Bool
$c/= :: forall n t. (Eq n, Eq t) => S n t -> S n t -> Bool
== :: S n t -> S n t -> Bool
$c== :: forall n t. (Eq n, Eq t) => S n t -> S n t -> Bool
Eq, Int -> S n t -> ShowS
[S n t] -> ShowS
S n t -> String
(Int -> S n t -> ShowS)
-> (S n t -> String) -> ([S n t] -> ShowS) -> Show (S n t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n t. (Show n, Show t) => Int -> S n t -> ShowS
forall n t. (Show n, Show t) => [S n t] -> ShowS
forall n t. (Show n, Show t) => S n t -> String
showList :: [S n t] -> ShowS
$cshowList :: forall n t. (Show n, Show t) => [S n t] -> ShowS
show :: S n t -> String
$cshow :: forall n t. (Show n, Show t) => S n t -> String
showsPrec :: Int -> S n t -> ShowS
$cshowsPrec :: forall n t. (Show n, Show t) => Int -> S n t -> ShowS
Show)

emptyS :: S n t
emptyS :: S n t
emptyS = S :: forall n t.
Seq (Set (Item n t))
-> Set (Item n t) -> Set (Item n t) -> Int -> [Item n t] -> S n t
S
  { itemSets :: Seq (Set (Item n t))
itemSets = Seq (Set (Item n t))
forall a. Seq a
Seq.empty
  , currItemSet :: Set (Item n t)
currItemSet = Set (Item n t)
forall a. Set a
Set.empty
  , nextItemSet :: Set (Item n t)
nextItemSet = Set (Item n t)
forall a. Set a
Set.empty
  , currIndex :: Int
currIndex = Int
0
  , todo :: [Item n t]
todo = []
  }

initialS :: (Ord n, Ord t) => Grammar n t c -> n -> S n t
initialS :: Grammar n t c -> n -> S n t
initialS Grammar n t c
g n
n =
  S n t
forall n t. S n t
emptyS { currItemSet :: Set (Item n t)
currItemSet = [Item n t] -> Set (Item n t)
forall a. Ord a => [a] -> Set a
Set.fromList (Grammar n t c -> Int -> n -> [Item n t]
forall n t c. Ord n => Grammar n t c -> Int -> n -> [Item n t]
newItems Grammar n t c
g Int
0 n
n) }

newItems :: Ord n => Grammar n t c -> Int -> n -> [Item n t]
newItems :: Grammar n t c -> Int -> n -> [Item n t]
newItems Grammar n t c
g Int
i n
n =
  let rs :: [Rule n t]
rs = Grammar n t c -> n -> [Rule n t]
forall n t c. Grammar n t c -> n -> [Rule n t]
rules Grammar n t c
g n
n in
  ((Int, Rule n t) -> Item n t) -> [(Int, Rule n t)] -> [Item n t]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ri_, Rule n t
r) -> RuleId n -> Rule n t -> Int -> Item n t
forall n t. RuleId n -> [Atom n t] -> Int -> Item n t
Item (n -> Int -> RuleId n
forall n. n -> Int -> RuleId n
RuleId n
n Int
ri_) Rule n t
r Int
i) ([Int] -> [Rule n t] -> [(Int, Rule n t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Rule n t]
rs)

allItemSets :: S n t -> Seq (Set (Item n t))
allItemSets :: S n t -> Seq (Set (Item n t))
allItemSets S n t
s = S n t -> Seq (Set (Item n t))
forall n t. S n t -> Seq (Set (Item n t))
itemSets S n t
s Seq (Set (Item n t)) -> Set (Item n t) -> Seq (Set (Item n t))
forall a. Seq a -> a -> Seq a
Seq.|> S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s Seq (Set (Item n t)) -> Set (Item n t) -> Seq (Set (Item n t))
forall a. Seq a -> a -> Seq a
Seq.|> S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
nextItemSet S n t
s

type Parser n t = State (S n t)

next :: Parser n t ()
next :: Parser n t ()
next = (S n t -> S n t) -> Parser n t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\S n t
s ->
  let items :: Seq (Set (Item n t))
items | S n t -> Int
forall n t. S n t -> Int
currIndex S n t
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 = Seq (Set (Item n t))
forall a. Seq a
Seq.empty
            | Bool
otherwise = S n t -> Seq (Set (Item n t))
forall n t. S n t -> Seq (Set (Item n t))
itemSets S n t
s Seq (Set (Item n t)) -> Set (Item n t) -> Seq (Set (Item n t))
forall a. Seq a -> a -> Seq a
Seq.|> S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s in
  S n t
s { itemSets :: Seq (Set (Item n t))
itemSets = Seq (Set (Item n t))
items
    , currItemSet :: Set (Item n t)
currItemSet = S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
nextItemSet S n t
s
    , nextItemSet :: Set (Item n t)
nextItemSet = Set (Item n t)
forall a. Set a
Set.empty
    , currIndex :: Int
currIndex = S n t -> Int
forall n t. S n t -> Int
currIndex S n t
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    , todo :: [Item n t]
todo = []
    })

addItemCurr :: (Ord n, Ord t) => Item n t -> Parser n t ()
addItemCurr :: Item n t -> Parser n t ()
addItemCurr Item n t
item = do
  S n t
s <- StateT (S n t) Identity (S n t)
forall s (m :: * -> *). MonadState s m => m s
get
  if Item n t -> Set (Item n t) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Item n t
item (S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s) then
    () -> Parser n t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else do
    S n t -> Parser n t ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (S n t
s
      { currItemSet :: Set (Item n t)
currItemSet = Item n t -> Set (Item n t) -> Set (Item n t)
forall a. Ord a => a -> Set a -> Set a
Set.insert Item n t
item (S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s)
      , todo :: [Item n t]
todo = Item n t
item Item n t -> [Item n t] -> [Item n t]
forall a. a -> [a] -> [a]
: S n t -> [Item n t]
forall n t. S n t -> [Item n t]
todo S n t
s })

-- Invariant: @i <= currIndex s@
-- In particular, never look up @nextItemSet s@.
lookupItemSet :: Int -> Parser n t (Set (Item n t))
lookupItemSet :: Int -> Parser n t (Set (Item n t))
lookupItemSet Int
i = (S n t -> Set (Item n t)) -> Parser n t (Set (Item n t))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (\S n t
s ->
  if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== S n t -> Int
forall n t. S n t -> Int
currIndex S n t
s then
    S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s
  else
    Set (Item n t) -> Maybe (Set (Item n t)) -> Set (Item n t)
forall a. a -> Maybe a -> a
fromMaybe (String -> Set (Item n t)
forall a. HasCallStack => String -> a
error String
"Should exist") (Int -> Seq (Set (Item n t)) -> Maybe (Set (Item n t))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
i (S n t -> Seq (Set (Item n t))
forall n t. S n t -> Seq (Set (Item n t))
itemSets S n t
s)))

addItemNext :: (Ord n, Ord t) => Item n t -> Parser n t ()
addItemNext :: Item n t -> Parser n t ()
addItemNext Item n t
item = do
  (S n t -> S n t) -> Parser n t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\S n t
s -> S n t
s { nextItemSet :: Set (Item n t)
nextItemSet = Item n t -> Set (Item n t) -> Set (Item n t)
forall a. Ord a => a -> Set a -> Set a
Set.insert Item n t
item (S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
nextItemSet S n t
s) })

stepItem :: (Ord n, Ord t) => Grammar n t c -> Maybe c -> Item n t -> Parser n t ()
stepItem :: Grammar n t c -> Maybe c -> Item n t -> Parser n t ()
stepItem Grammar n t c
g Maybe c
_c (Item RuleId n
ri (N n
n : [Atom n t]
xs) Int
iStart) = do
  Int
i <- (S n t -> Int) -> StateT (S n t) Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets S n t -> Int
forall n t. S n t -> Int
currIndex
  [Item n t] -> (Item n t -> Parser n t ()) -> Parser n t ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Grammar n t c -> Int -> n -> [Item n t]
forall n t c. Ord n => Grammar n t c -> Int -> n -> [Item n t]
newItems Grammar n t c
g Int
i n
n) Item n t -> Parser n t ()
forall n t. (Ord n, Ord t) => Item n t -> Parser n t ()
addItemCurr
  if Grammar n t c -> n -> Bool
forall n t c. Grammar n t c -> n -> Bool
isNullable Grammar n t c
g n
n then Item n t -> Parser n t ()
forall n t. (Ord n, Ord t) => Item n t -> Parser n t ()
addItemCurr (RuleId n -> [Atom n t] -> Int -> Item n t
forall n t. RuleId n -> [Atom n t] -> Int -> Item n t
Item RuleId n
ri [Atom n t]
xs Int
iStart) else () -> Parser n t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
stepItem Grammar n t c
_ Maybe c
_ (Item (RuleId n
n Int
_) [] Int
iStart) = do
  Set (Item n t)
sset <- Int -> Parser n t (Set (Item n t))
forall n t. Int -> Parser n t (Set (Item n t))
lookupItemSet Int
iStart
  Set (Item n t) -> (Item n t -> Parser n t ()) -> Parser n t ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Item n t)
sset (\(Item RuleId n
ri' [Atom n t]
xs' Int
iStart') ->
    case [Atom n t]
xs' of
      N n
n' : [Atom n t]
xs1' | n
n n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
n' -> Item n t -> Parser n t ()
forall n t. (Ord n, Ord t) => Item n t -> Parser n t ()
addItemCurr (RuleId n -> [Atom n t] -> Int -> Item n t
forall n t. RuleId n -> [Atom n t] -> Int -> Item n t
Item RuleId n
ri' [Atom n t]
xs1' Int
iStart')
      [Atom n t]
_ -> () -> Parser n t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
stepItem Grammar n t c
g (Just c
c) (Item RuleId n
ri (T t
t : [Atom n t]
xs) Int
iStart) | Grammar n t c -> t -> c -> Bool
forall n t c. Grammar n t c -> t -> c -> Bool
match Grammar n t c
g t
t c
c = Item n t -> Parser n t ()
forall n t. (Ord n, Ord t) => Item n t -> Parser n t ()
addItemNext (RuleId n -> [Atom n t] -> Int -> Item n t
forall n t. RuleId n -> [Atom n t] -> Int -> Item n t
Item RuleId n
ri [Atom n t]
xs Int
iStart)
stepItem Grammar n t c
_ Maybe c
_ (Item RuleId n
_ (T t
_ : [Atom n t]
_) Int
_) = () -> Parser n t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

step :: (Ord n, Ord t) => Grammar n t c -> Maybe c -> Parser n t ()
step :: Grammar n t c -> Maybe c -> Parser n t ()
step Grammar n t c
g Maybe c
c = (S n t -> [Item n t]) -> StateT (S n t) Identity [Item n t]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Set (Item n t) -> [Item n t]
forall a. Set a -> [a]
Set.toList (Set (Item n t) -> [Item n t])
-> (S n t -> Set (Item n t)) -> S n t -> [Item n t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet) StateT (S n t) Identity [Item n t]
-> ([Item n t] -> Parser n t ()) -> Parser n t ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Item n t] -> Parser n t ()
go where
  go :: [Item n t] -> Parser n t ()
go [] = () -> Parser n t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  go [Item n t]
td = do
    (S n t -> S n t) -> Parser n t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\S n t
s -> S n t
s { todo :: [Item n t]
todo = [] })
    [Item n t] -> (Item n t -> Parser n t ()) -> Parser n t ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Item n t]
td (Grammar n t c -> Maybe c -> Item n t -> Parser n t ()
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> Maybe c -> Item n t -> Parser n t ()
stepItem Grammar n t c
g Maybe c
c)
    (S n t -> [Item n t]) -> StateT (S n t) Identity [Item n t]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets S n t -> [Item n t]
forall n t. S n t -> [Item n t]
todo StateT (S n t) Identity [Item n t]
-> ([Item n t] -> Parser n t ()) -> Parser n t ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Item n t] -> Parser n t ()
go

steps :: (Ord n, Ord t) => Grammar n t c -> [c] -> Parser n t ()
steps :: Grammar n t c -> [c] -> Parser n t ()
steps Grammar n t c
g = [c] -> Parser n t ()
go where
  go :: [c] -> Parser n t ()
go (c
c : [c]
cs) = Grammar n t c -> Maybe c -> Parser n t ()
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> Maybe c -> Parser n t ()
step Grammar n t c
g (c -> Maybe c
forall a. a -> Maybe a
Just c
c) Parser n t () -> Parser n t () -> Parser n t ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser n t ()
forall n t. Parser n t ()
next Parser n t () -> Parser n t () -> Parser n t ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [c] -> Parser n t ()
go [c]
cs
  go [] = Grammar n t c -> Maybe c -> Parser n t ()
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> Maybe c -> Parser n t ()
step Grammar n t c
g Maybe c
forall a. Maybe a
Nothing

data Seq1 a = Seq a ::> a
  deriving (Seq1 a -> Seq1 a -> Bool
(Seq1 a -> Seq1 a -> Bool)
-> (Seq1 a -> Seq1 a -> Bool) -> Eq (Seq1 a)
forall a. Eq a => Seq1 a -> Seq1 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seq1 a -> Seq1 a -> Bool
$c/= :: forall a. Eq a => Seq1 a -> Seq1 a -> Bool
== :: Seq1 a -> Seq1 a -> Bool
$c== :: forall a. Eq a => Seq1 a -> Seq1 a -> Bool
Eq, Int -> Seq1 a -> ShowS
[Seq1 a] -> ShowS
Seq1 a -> String
(Int -> Seq1 a -> ShowS)
-> (Seq1 a -> String) -> ([Seq1 a] -> ShowS) -> Show (Seq1 a)
forall a. Show a => Int -> Seq1 a -> ShowS
forall a. Show a => [Seq1 a] -> ShowS
forall a. Show a => Seq1 a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Seq1 a] -> ShowS
$cshowList :: forall a. Show a => [Seq1 a] -> ShowS
show :: Seq1 a -> String
$cshow :: forall a. Show a => Seq1 a -> String
showsPrec :: Int -> Seq1 a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Seq1 a -> ShowS
Show)

-- Returns nonempty sequence.
preparse :: (Ord n, Ord t) => Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
preparse :: Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
preparse Grammar n t c
g n
n [c]
cs = S n t -> Seq1 (Set (Item n t))
forall n t. S n t -> Seq1 (Set (Item n t))
itemSets' (State (S n t) () -> S n t -> S n t
forall s a. State s a -> s -> s
execState (Grammar n t c -> [c] -> State (S n t) ()
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> [c] -> Parser n t ()
steps Grammar n t c
g [c]
cs) (Grammar n t c -> n -> S n t
forall n t c. (Ord n, Ord t) => Grammar n t c -> n -> S n t
initialS Grammar n t c
g n
n))
  where
    itemSets' :: S n t -> Seq1 (Set (Item n t))
itemSets' S n t
s = S n t -> Seq (Set (Item n t))
forall n t. S n t -> Seq (Set (Item n t))
itemSets S n t
s Seq (Set (Item n t)) -> Set (Item n t) -> Seq1 (Set (Item n t))
forall a. Seq a -> a -> Seq1 a
::> S n t -> Set (Item n t)
forall n t. S n t -> Set (Item n t)
currItemSet S n t
s
    -- nextItemSet should be empty at the end after (step g Nothing)

-- | Check whether a grammar matches a chain of character @[c]@ from a starting symbol @n@.
accepts :: (Ord n, Ord t) => Grammar n t c -> n -> [c] -> Bool
accepts :: Grammar n t c -> n -> [c] -> Bool
accepts Grammar n t c
g n
n [c]
cs =
  case Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
preparse Grammar n t c
g n
n [c]
cs of
    Seq (Set (Item n t))
_ ::> Set (Item n t)
items ->
      (Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [() | Item (RuleId n
n' Int
_) [] Int
0 <- Set (Item n t) -> [Item n t]
forall a. Set a -> [a]
Set.toList Set (Item n t)
items, n
n n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
n']