{- |
Module      : Control.Lens.Grammar.Machine
Description : matching & transducers
Copyright   : (C) 2026 - Eitan Chatav
License     : BSD-style (see the file LICENSE)
Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
Stability   : provisional
Portability : non-portable
-}

module Control.Lens.Grammar.Machine
  ( -- * Matching
    Matching (..)
    -- * Transducer
  , transducer
  , parseForest
  , languageSample
  , expectNext
  , unreachableRules
  , Transducer (..)
  , TransducerStep (..)
  ) where

import Control.Lens
import Control.Lens.Extras
import Control.Lens.Grammar.BackusNaur
import Control.Lens.Grammar.Boole
import Control.Lens.Grammar.Kleene
import Control.Lens.Grammar.Token
import Data.Foldable
import qualified Data.IntMap.Strict as IntMap
import Data.IntMap.Strict (IntMap)
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Tree (Tree (..))

-- | Does a word match a pattern?
class Matching word pattern | pattern -> word where
  (=~) :: word -> pattern -> Bool
  infix 2 =~
-- instances
instance Categorized token
  => Matching [token] (Transducer token) where
    [token]
word =~ :: [token] -> Transducer token -> Bool
=~ Transducer token
et = Key -> IntMap (IntMap IntSet) -> Bool
acceptsChart Key
n IntMap (IntMap IntSet)
chart
      where
        (Key
n, IntMap (IntMap IntSet)
chart) = Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
forall token.
Categorized token =>
Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
prefixGen Transducer token
et [token]
word
instance Categorized token
  => Matching [token] (Bnf (RegEx token)) where
    [token]
word =~ :: [token] -> Bnf (RegEx token) -> Bool
=~ Bnf (RegEx token)
bnf = [token]
word [token] -> Transducer token -> Bool
forall word pattern.
Matching word pattern =>
word -> pattern -> Bool
=~ Bnf (RegEx token) -> Transducer token
forall token. Bnf (RegEx token) -> Transducer token
transducer Bnf (RegEx token)
bnf
instance Categorized token
  => Matching [token] (RegEx token) where
    [token]
word =~ :: [token] -> RegEx token -> Bool
=~ RegEx token
pattern = [token]
word [token] -> Bnf (RegEx token) -> Bool
forall word pattern.
Matching word pattern =>
word -> pattern -> Bool
=~ RegEx token -> Bnf (RegEx token)
forall a. Ord a => a -> Bnf a
liftBnf0 RegEx token
pattern
instance Matching s (APrism s t a b) where
  s
word =~ :: s -> APrism s t a b -> Bool
=~ APrism s t a b
pattern = APrism s t a b -> s -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism s t a b
pattern s
word

{-| A `Transducer` is a tuple

@
T = (Σ, Δ, Q, I ⊆ Q, F ∈ Q, transition ⊆ Q × (Σ ∪ ∆) × Q, output ⊆ Q × ∆)
@

* @Σ@ is a (possibly infinite) set of terminal token classes, represented by `TokenClass`es.
* @Δ@ is a finite set of nonterminals, represented by the key set of `transducerRules`.
* @Q@ is a set of states, which is represented by the key set of `transducerRelations`.
* @I@ are initial states represented by `transducerStarts`.
* @F@ is a final state represented by @0@.
* @transition@ is a relation represented by `transducerRelations`
  with `TransitionTokenClass` and `TransitionNonTerminal` transitions.
* @output@ is a relation represented by `transducerRelations` with `EmitNonTerminal` outputs.
-}
data Transducer token = Transducer
  { forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations :: IntMap (TransducerStep token)
  , forall token. Transducer token -> Map String (IntSet, Bool)
transducerRules :: Map String (IntSet, Bool)
  -- ^ an index into `transducerRelations` for nonterminals with precomputed nullability
  , forall token. Transducer token -> IntSet
transducerStarts :: IntSet
  -- ^ an index into `transducerRelations` for the starting rule
  }

-- | A `TransducerStep` in a `Transducer`.
data TransducerStep token
  = TransitionTokenClass (TokenClass token) IntSet
  | TransitionNonTerminal String IntSet
  | EmitNonTerminal String

{- | Compile a `RegEx`tended `Bnf` into a `Transducer`,
using a combination of Thompson's algorithm for regular expressions
and Earley's algorithm for context-free grammars. See Jim & Mandelbaum,
[Efficient Earley Parsing with Regular Right-hand Sides]
(http://trevorjim.com/papers/ldta-2009.pdf),
and McIlroy, [Enumerating the strings of regular languages]
(https://www.cs.dartmouth.edu/~doug/nfa.pdf).

A transducer is a form of finite state machine
that can be run in various ways like
`=~`, `expectNext`, `languageSample`, `parseForest` & `unreachableRules`.
-}
transducer :: Bnf (RegEx token) -> Transducer token
transducer :: forall token. Bnf (RegEx token) -> Transducer token
transducer (Bnf RegEx token
start Set (String, RegEx token)
rules) = Transducer
  { transducerRelations :: IntMap (TransducerStep token)
transducerRelations = [(Key, TransducerStep token)] -> IntMap (TransducerStep token)
forall a. [(Key, a)] -> IntMap a
IntMap.fromList [(Key, TransducerStep token)]
allStates
  , transducerRules :: Map String (IntSet, Bool)
transducerRules = [(String, (IntSet, Bool))] -> Map String (IntSet, Bool)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ ( String
n
        , ( IntSet -> String -> Map String IntSet -> IntSet
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntSet
IntSet.empty String
n Map String IntSet
firstsMap
          , String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
n Set String
nullSet
          )
        )
      | String
n <- Map String [RegEx token] -> [String]
forall k a. Map k a -> [k]
Map.keys Map String [RegEx token]
ruleMap
      ]
  , transducerStarts :: IntSet
transducerStarts = IntSet
startStates
  }

  where

    ruleMap :: Map String [RegEx token]
ruleMap = ((String, RegEx token)
 -> Map String [RegEx token] -> Map String [RegEx token])
-> Map String [RegEx token]
-> [(String, RegEx token)]
-> Map String [RegEx token]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\(String
n, RegEx token
r) -> ([RegEx token] -> [RegEx token] -> [RegEx token])
-> String
-> [RegEx token]
-> Map String [RegEx token]
-> Map String [RegEx token]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [RegEx token] -> [RegEx token] -> [RegEx token]
forall a. [a] -> [a] -> [a]
(++) String
n [RegEx token
r]) Map String [RegEx token]
forall k a. Map k a
Map.empty (Set (String, RegEx token) -> [(String, RegEx token)]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (String, RegEx token)
rules)

    rexNullable :: Set String -> RegEx token -> Bool
rexNullable Set String
nm = \case
      RegEx token
SeqEmpty -> Bool
True
      NonTerminal String
n -> String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
n Set String
nm
      Sequence RegEx token
x RegEx token
y -> Set String -> RegEx token -> Bool
rexNullable Set String
nm RegEx token
x Bool -> Bool -> Bool
&& Set String -> RegEx token -> Bool
rexNullable Set String
nm RegEx token
y
      KleeneStar RegEx token
_ -> Bool
True
      KleeneOpt RegEx token
_ -> Bool
True
      KleenePlus RegEx token
x -> Set String -> RegEx token -> Bool
rexNullable Set String
nm RegEx token
x
      RegExam (Alternate RegEx token
x RegEx token
y) -> Set String -> RegEx token -> Bool
rexNullable Set String
nm RegEx token
x Bool -> Bool -> Bool
|| Set String -> RegEx token -> Bool
rexNullable Set String
nm RegEx token
y
      RegExam (OneOf Set token
_) -> Bool
False
      RegExam (NotOneOf Set token
_ CategoryTest token
_) -> Bool
False

    ruleNames :: [String]
ruleNames = Map String [RegEx token] -> [String]
forall k a. Map k a -> [k]
Map.keys Map String [RegEx token]
ruleMap

    iterNull :: Set String -> Set String
iterNull Set String
ns =
      let ns' :: Set String
ns' = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
            [ String
n
            | String
n <- [String]
ruleNames
            , (RegEx token -> Bool) -> [RegEx token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set String -> RegEx token -> Bool
forall {token}. Set String -> RegEx token -> Bool
rexNullable Set String
ns) ([RegEx token]
-> String -> Map String [RegEx token] -> [RegEx token]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
n Map String [RegEx token]
ruleMap)
            ]
      in if Set String
ns Set String -> Set String -> Bool
forall a. Eq a => a -> a -> Bool
== Set String
ns' then Set String
ns else Set String -> Set String
iterNull Set String
ns'

    nullSet :: Set String
nullSet = Set String -> Set String
iterNull Set String
forall a. Set a
Set.empty

    transducerAcceptId0 :: Key
transducerAcceptId0 = Key
0

    (Map String Key
finalMap, Key
nextIdAfterFinals) =
      ((Map String Key, Key) -> String -> (Map String Key, Key))
-> (Map String Key, Key) -> [String] -> (Map String Key, Key)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map String Key, Key) -> String -> (Map String Key, Key)
forall {p} {b}. (Ord p, Num b) => (Map p b, b) -> p -> (Map p b, b)
alloc (Map String Key
forall k a. Map k a
Map.empty, Key
transducerAcceptId0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) [String]
ruleNames
      where alloc :: (Map p b, b) -> p -> (Map p b, b)
alloc (Map p b
m, b
i) p
n = (p -> b -> Map p b -> Map p b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
n b
i Map p b
m, b
i b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)

    finalStatesList :: [(Key, TransducerStep token)]
finalStatesList = [(Map String Key
finalMap Map String Key -> String -> Key
forall k a. Ord k => Map k a -> k -> a
Map.! String
n, String -> TransducerStep token
forall token. String -> TransducerStep token
EmitNonTerminal String
n) | String
n <- [String]
ruleNames]

    ([(Key, TransducerStep token)]
rulesStatesList, Map String IntSet
firstsMap, Key
nextIdAfterRules) =
      (([(Key, TransducerStep token)], Map String IntSet, Key)
 -> (String, [RegEx token])
 -> ([(Key, TransducerStep token)], Map String IntSet, Key))
-> ([(Key, TransducerStep token)], Map String IntSet, Key)
-> [(String, [RegEx token])]
-> ([(Key, TransducerStep token)], Map String IntSet, Key)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Key, TransducerStep token)], Map String IntSet, Key)
-> (String, [RegEx token])
-> ([(Key, TransducerStep token)], Map String IntSet, Key)
compileRule ([], Map String IntSet
forall k a. Map k a
Map.empty, Key
nextIdAfterFinals) (Map String [RegEx token] -> [(String, [RegEx token])]
forall k a. Map k a -> [(k, a)]
Map.toList Map String [RegEx token]
ruleMap)
      where
        compileRule :: ([(Key, TransducerStep token)], Map String IntSet, Key)
-> (String, [RegEx token])
-> ([(Key, TransducerStep token)], Map String IntSet, Key)
compileRule ([(Key, TransducerStep token)]
sts, Map String IntSet
fm, Key
nid) (String
name, [RegEx token]
prods) =
          let finalId :: Key
finalId = Map String Key
finalMap Map String Key -> String -> Key
forall k a. Ord k => Map k a -> k -> a
Map.! String
name
              ([(Key, TransducerStep token)]
newSts, IntSet
newFirsts, Key
nid') =
                (([(Key, TransducerStep token)], IntSet, Key)
 -> RegEx token -> ([(Key, TransducerStep token)], IntSet, Key))
-> ([(Key, TransducerStep token)], IntSet, Key)
-> [RegEx token]
-> ([(Key, TransducerStep token)], IntSet, Key)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Key, TransducerStep token)], IntSet, Key)
-> RegEx token -> ([(Key, TransducerStep token)], IntSet, Key)
compileProd ([], IntSet
IntSet.empty, Key
nid) [RegEx token]
prods
              compileProd :: ([(Key, TransducerStep token)], IntSet, Key)
-> RegEx token -> ([(Key, TransducerStep token)], IntSet, Key)
compileProd ([(Key, TransducerStep token)]
s, IntSet
fs, Key
i) RegEx token
prod =
                let (IntSet
f, [(Key, TransducerStep token)]
st, Key
i', Bool
_) =
                      RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
prod Key
i (Key -> IntSet
IntSet.singleton Key
finalId)
                in ([(Key, TransducerStep token)]
s [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
st, IntSet
fs IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
f, Key
i')
          in ([(Key, TransducerStep token)]
sts [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
newSts, String -> IntSet -> Map String IntSet -> Map String IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name IntSet
newFirsts Map String IntSet
fm, Key
nid')

    (IntSet
startFirsts, [(Key, TransducerStep token)]
startStatesRaw, Key
_, Bool
startBypass) =
      RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
start Key
nextIdAfterRules (Key -> IntSet
IntSet.singleton Key
transducerAcceptId0)

    startStates :: IntSet
startStates =
      IntSet
startFirsts IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Bool -> IntSet -> IntSet
bypassStates Bool
startBypass (Key -> IntSet
IntSet.singleton Key
transducerAcceptId0)

    allStates :: [(Key, TransducerStep token)]
allStates = [(Key, TransducerStep token)]
finalStatesList [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
rulesStatesList [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
startStatesRaw

    bypassStates :: Bool -> IntSet -> IntSet
bypassStates Bool
True = IntSet -> IntSet
forall a. a -> a
id
    bypassStates Bool
False = IntSet -> IntSet -> IntSet
forall a b. a -> b -> a
const IntSet
IntSet.empty

    thompson :: RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex Key
nextId IntSet
dests = case RegEx token
rex of
        RegEx token
SeqEmpty -> (IntSet
IntSet.empty, [], Key
nextId, Bool
True)
        NonTerminal String
name ->
          ( Key -> IntSet
IntSet.singleton Key
nextId
          , [(Key
nextId, String -> IntSet -> TransducerStep token
forall token. String -> IntSet -> TransducerStep token
TransitionNonTerminal String
name IntSet
dests)]
          , Key
nextId Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
          , String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
name Set String
nullSet
          )
        Sequence RegEx token
rex0 RegEx token
rex1 ->
          let
            (IntSet
firsts1, [(Key, TransducerStep token)]
states1, Key
nextId1, Bool
bypass1) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex1 Key
nextId IntSet
dests
            (IntSet
firsts0, [(Key, TransducerStep token)]
states0, Key
nextId0, Bool
bypass0) =
              RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex0 Key
nextId1 (IntSet
firsts1 IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Bool -> IntSet -> IntSet
bypassStates Bool
bypass1 IntSet
dests)
          in
            ( IntSet
firsts0 IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Bool -> IntSet -> IntSet
bypassStates Bool
bypass0 IntSet
firsts1
            , [(Key, TransducerStep token)]
states0 [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
states1
            , Key
nextId0
            , Bool
bypass0 Bool -> Bool -> Bool
&& Bool
bypass1
            )
        KleeneStar RegEx token
rex0 ->
          let
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
_) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex0 Key
nextId (IntSet
firsts IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
dests)
          in
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
True)
        KleeneOpt RegEx token
rex0 ->
          let
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
_) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex0 Key
nextId IntSet
dests
          in
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
True)
        KleenePlus RegEx token
rex0 ->
          let
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
bypass) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex0 Key
nextId (IntSet
firsts IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
dests)
          in
            (IntSet
firsts, [(Key, TransducerStep token)]
states, Key
nextId', Bool
bypass)
        RegExam (OneOf Set token
chars)
          | Set token -> Bool
forall a. Set a -> Bool
Set.null Set token
chars -> (IntSet
IntSet.empty, [], Key
nextId, Bool
False)
          | Bool
otherwise ->
              ( Key -> IntSet
IntSet.singleton Key
nextId
              , [(Key
nextId, TokenClass token -> IntSet -> TransducerStep token
forall token. TokenClass token -> IntSet -> TransducerStep token
TransitionTokenClass (RegExam token (TokenClass token) -> TokenClass token
forall token. RegExam token (TokenClass token) -> TokenClass token
TokenClass (Set token -> RegExam token (TokenClass token)
forall token alg. Set token -> RegExam token alg
OneOf Set token
chars)) IntSet
dests)]
              , Key
nextId Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
              , Bool
False
              )
        RegExam (NotOneOf Set token
chars CategoryTest token
catTest) ->
          ( Key -> IntSet
IntSet.singleton Key
nextId
          , [(Key
nextId, TokenClass token -> IntSet -> TransducerStep token
forall token. TokenClass token -> IntSet -> TransducerStep token
TransitionTokenClass (RegExam token (TokenClass token) -> TokenClass token
forall token. RegExam token (TokenClass token) -> TokenClass token
TokenClass (Set token -> CategoryTest token -> RegExam token (TokenClass token)
forall token alg.
Set token -> CategoryTest token -> RegExam token alg
NotOneOf Set token
chars CategoryTest token
catTest)) IntSet
dests)]
          , Key
nextId Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
          , Bool
False
          )
        RegExam (Alternate RegEx token
rex0 RegEx token
rex1) ->
          let
            (IntSet
firsts1, [(Key, TransducerStep token)]
states1, Key
nextId1, Bool
bypass1) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex1 Key
nextId IntSet
dests
            (IntSet
firsts0, [(Key, TransducerStep token)]
states0, Key
nextId0, Bool
bypass0) = RegEx token
-> Key
-> IntSet
-> (IntSet, [(Key, TransducerStep token)], Key, Bool)
thompson RegEx token
rex0 Key
nextId1 IntSet
dests
          in
            ( IntSet
firsts0 IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
firsts1
            , [(Key, TransducerStep token)]
states0 [(Key, TransducerStep token)]
-> [(Key, TransducerStep token)] -> [(Key, TransducerStep token)]
forall a. Semigroup a => a -> a -> a
<> [(Key, TransducerStep token)]
states1
            , Key
nextId0
            , Bool
bypass0 Bool -> Bool -> Bool
|| Bool
bypass1
            )

{- | The parse forest of a string of tokens. -}
parseForest
  :: Categorized token
  => Transducer token
  -> [token] -- ^ string
  -> ([Tree (String, Int, Int, [token])], [token])
  {- ^ parse forest & remaining unparsed tokens -}
parseForest :: forall token.
Categorized token =>
Transducer token
-> [token] -> ([Tree (String, Key, Key, [token])], [token])
parseForest Transducer token
et [token]
word = ([[Tree (String, Key, Key, [token])]]
-> [Tree (String, Key, Key, [token])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Maybe String
-> Key
-> Key
-> Key
-> [[Tree (String, Key, Key, [token])]]
itemForests Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
forall a. Set a
Set.empty Maybe String
forall a. Maybe a
Nothing Key
0 Key
acceptedLen Key
0), Key -> [token] -> [token]
forall a. Key -> [a] -> [a]
drop Key
acceptedLen [token]
word)
  where
    (Key
n, IntMap (IntMap IntSet)
chart) = Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
forall token.
Categorized token =>
Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
prefixGen Transducer token
et [token]
word
    relations :: IntMap (TransducerStep token)
relations = Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et
    acceptedLen :: Key
acceptedLen = [Key] -> Key
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Key
j | Key
j <- [Key
0 .. Key
n], Key -> IntMap (IntMap IntSet) -> Bool
acceptsChart Key
j IntMap (IntMap IntSet)
chart]

    acceptedWord :: [token]
acceptedWord = Key -> [token] -> [token]
forall a. Key -> [a] -> [a]
take Key
acceptedLen [token]
word
    sliceAt :: Key -> Key -> [token]
sliceAt Key
start Key
end = Key -> [token] -> [token]
forall a. Key -> [a] -> [a]
take (Key
end Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
start) (Key -> [token] -> [token]
forall a. Key -> [a] -> [a]
drop Key
start [token]
acceptedWord)
    itemsAt :: Key -> IntMap IntSet
itemsAt Key
j = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
chart
    ruleInfo :: String -> (IntSet, Bool)
ruleInfo String
name = (IntSet, Bool)
-> String -> Map String (IntSet, Bool) -> (IntSet, Bool)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (IntSet
IntSet.empty, Bool
False) String
name (Transducer token -> Map String (IntSet, Bool)
forall token. Transducer token -> Map String (IntSet, Bool)
transducerRules Transducer token
et)

    edgesAt :: IntMap (IntMap [edge]) -> Int -> Int -> [edge]
    edgesAt :: forall edge. IntMap (IntMap [edge]) -> Key -> Key -> [edge]
edgesAt IntMap (IntMap [edge])
table Key
pos Key
stateId =
      [edge] -> Key -> IntMap [edge] -> [edge]
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault [] Key
stateId (IntMap [edge] -> Key -> IntMap (IntMap [edge]) -> IntMap [edge]
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap [edge]
forall a. IntMap a
IntMap.empty Key
pos IntMap (IntMap [edge])
table)

    insertEdges :: edge -> IntSet -> IntMap [edge] -> IntMap [edge]
    insertEdges :: forall edge. edge -> IntSet -> IntMap [edge] -> IntMap [edge]
insertEdges edge
edge IntSet
dests IntMap [edge]
acc = (Key -> IntMap [edge] -> IntMap [edge])
-> IntMap [edge] -> IntSet -> IntMap [edge]
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr
      (\Key
stateId IntMap [edge]
m -> ([edge] -> [edge] -> [edge])
-> Key -> [edge] -> IntMap [edge] -> IntMap [edge]
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
IntMap.insertWith [edge] -> [edge] -> [edge]
forall a. [a] -> [a] -> [a]
(++) Key
stateId [edge
edge] IntMap [edge]
m)
      IntMap [edge]
acc
      IntSet
dests

    scanBack :: IntMap (IntMap [(Key, IntSet)])
scanBack = [(Key, IntMap [(Key, IntSet)])] -> IntMap (IntMap [(Key, IntSet)])
forall a. [(Key, a)] -> IntMap a
IntMap.fromList
      [ (Key
end, Key -> token -> IntMap [(Key, IntSet)]
backRow (Key
end Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) token
input)
      | (Key
end, token
input) <- [Key] -> [token] -> [(Key, token)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
1 .. Key
acceptedLen] [token]
acceptedWord
      ]
      where
        backRow :: Key -> token -> IntMap [(Key, IntSet)]
backRow Key
prev token
input = (Key -> IntSet -> IntMap [(Key, IntSet)] -> IntMap [(Key, IntSet)])
-> IntMap [(Key, IntSet)]
-> IntMap IntSet
-> IntMap [(Key, IntSet)]
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key -> IntSet -> IntMap [(Key, IntSet)] -> IntMap [(Key, IntSet)]
step IntMap [(Key, IntSet)]
forall a. IntMap a
IntMap.empty (Key -> IntMap IntSet
itemsAt Key
prev)
          where
            step :: Key -> IntSet -> IntMap [(Key, IntSet)] -> IntMap [(Key, IntSet)]
step Key
prevState IntSet
origins IntMap [(Key, IntSet)]
acc = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
prevState IntMap (TransducerStep token)
relations of
              Just (TransitionTokenClass TokenClass token
cls IntSet
dests) | TokenClass token -> token -> Bool
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass TokenClass token
cls token
input ->
                (Key, IntSet)
-> IntSet -> IntMap [(Key, IntSet)] -> IntMap [(Key, IntSet)]
forall edge. edge -> IntSet -> IntMap [edge] -> IntMap [edge]
insertEdges (Key
prevState, IntSet
origins) IntSet
dests IntMap [(Key, IntSet)]
acc
              Maybe (TransducerStep token)
_ -> IntMap [(Key, IntSet)]
acc

    completeBack :: IntMap (IntMap [(Key, IntSet, String)])
completeBack = [(Key, IntMap [(Key, IntSet, String)])]
-> IntMap (IntMap [(Key, IntSet, String)])
forall a. [(Key, a)] -> IntMap a
IntMap.fromList
      [ (Key
split, (Key
 -> IntSet
 -> IntMap [(Key, IntSet, String)]
 -> IntMap [(Key, IntSet, String)])
-> IntMap [(Key, IntSet, String)]
-> IntMap IntSet
-> IntMap [(Key, IntSet, String)]
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key
-> IntSet
-> IntMap [(Key, IntSet, String)]
-> IntMap [(Key, IntSet, String)]
step IntMap [(Key, IntSet, String)]
forall a. IntMap a
IntMap.empty (Key -> IntMap IntSet
itemsAt Key
split))
      | Key
split <- [Key
0 .. Key
acceptedLen]
      ]
      where
        step :: Key
-> IntSet
-> IntMap [(Key, IntSet, String)]
-> IntMap [(Key, IntSet, String)]
step Key
caller IntSet
origins IntMap [(Key, IntSet, String)]
acc = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
caller IntMap (TransducerStep token)
relations of
          Just (TransitionNonTerminal String
name IntSet
dests) ->
            (Key, IntSet, String)
-> IntSet
-> IntMap [(Key, IntSet, String)]
-> IntMap [(Key, IntSet, String)]
forall edge. edge -> IntSet -> IntMap [edge] -> IntMap [edge]
insertEdges (Key
caller, IntSet
origins, String
name) IntSet
dests IntMap [(Key, IntSet, String)]
acc
          Maybe (TransducerStep token)
_ -> IntMap [(Key, IntSet, String)]
acc

    ruleFinals :: Map String Key
ruleFinals = (Key -> TransducerStep token -> Map String Key -> Map String Key)
-> Map String Key
-> IntMap (TransducerStep token)
-> Map String Key
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key -> TransducerStep token -> Map String Key -> Map String Key
forall {p} {token}.
p -> TransducerStep token -> Map String p -> Map String p
finalStates Map String Key
forall k a. Map k a
Map.empty IntMap (TransducerStep token)
relations
    finalStates :: p -> TransducerStep token -> Map String p -> Map String p
finalStates p
stateId TransducerStep token
step Map String p
acc = case TransducerStep token
step of
      EmitNonTerminal String
name -> String -> p -> Map String p -> Map String p
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name p
stateId Map String p
acc
      TransducerStep token
_ -> Map String p
acc

    entryStates :: Maybe String -> IntSet
entryStates Maybe String
Nothing = Transducer token -> IntSet
forall token. Transducer token -> IntSet
transducerStarts Transducer token
et
    entryStates (Just String
name) = (IntSet, Bool) -> IntSet
forall a b. (a, b) -> a
fst (String -> (IntSet, Bool)
ruleInfo String
name)

    ruleNullable :: String -> Bool
ruleNullable = (IntSet, Bool) -> Bool
forall a b. (a, b) -> b
snd ((IntSet, Bool) -> Bool)
-> (String -> (IntSet, Bool)) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (IntSet, Bool)
ruleInfo

    itemForests :: Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Maybe String
-> Key
-> Key
-> Key
-> [[Tree (String, Key, Key, [token])]]
itemForests Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards Maybe String
entry Key
origin Key
end Key
stateId
      | Either (Maybe String, Key, Key, Key) (String, Key, Key)
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Either (Maybe String, Key, Key, Key) (String, Key, Key)
itemKey Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards = []
      | Bool
otherwise = [[Tree (String, Key, Key, [token])]]
baseForests [[Tree (String, Key, Key, [token])]]
-> [[Tree (String, Key, Key, [token])]]
-> [[Tree (String, Key, Key, [token])]]
forall a. Semigroup a => a -> a -> a
<> [[Tree (String, Key, Key, [token])]]
scannedForests [[Tree (String, Key, Key, [token])]]
-> [[Tree (String, Key, Key, [token])]]
-> [[Tree (String, Key, Key, [token])]]
forall a. Semigroup a => a -> a -> a
<> [[Tree (String, Key, Key, [token])]]
completedForests
      where
        itemKey :: Either (Maybe String, Key, Key, Key) (String, Key, Key)
itemKey = (Maybe String, Key, Key, Key)
-> Either (Maybe String, Key, Key, Key) (String, Key, Key)
forall a b. a -> Either a b
Left (Maybe String
entry, Key
origin, Key
end, Key
stateId)
        guards' :: Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' = Either (Maybe String, Key, Key, Key) (String, Key, Key)
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
forall a. Ord a => a -> Set a -> Set a
Set.insert Either (Maybe String, Key, Key, Key) (String, Key, Key)
itemKey Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards

        baseForests :: [[Tree (String, Key, Key, [token])]]
baseForests
          | Key
end Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
origin Bool -> Bool -> Bool
&& Key -> IntSet -> Bool
IntSet.member Key
stateId (Maybe String -> IntSet
entryStates Maybe String
entry) = [[]]
          | Bool
otherwise = []

        scannedForests :: [[Tree (String, Key, Key, [token])]]
scannedForests
          | Key
end Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
origin = []
          | Bool
otherwise =
              [ [Tree (String, Key, Key, [token])]
forest
              | (Key
prevState, IntSet
origins) <- IntMap (IntMap [(Key, IntSet)]) -> Key -> Key -> [(Key, IntSet)]
forall edge. IntMap (IntMap [edge]) -> Key -> Key -> [edge]
edgesAt IntMap (IntMap [(Key, IntSet)])
scanBack Key
end Key
stateId
              , Key -> IntSet -> Bool
IntSet.member Key
origin IntSet
origins
              , let prev :: Key
prev = Key
end Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1
              , [Tree (String, Key, Key, [token])]
forest <- Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Maybe String
-> Key
-> Key
-> Key
-> [[Tree (String, Key, Key, [token])]]
itemForests Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' Maybe String
entry Key
origin Key
prev Key
prevState
              ]

        completedForests :: [[Tree (String, Key, Key, [token])]]
completedForests =
          [ [Tree (String, Key, Key, [token])]
prefix [Tree (String, Key, Key, [token])]
-> [Tree (String, Key, Key, [token])]
-> [Tree (String, Key, Key, [token])]
forall a. Semigroup a => a -> a -> a
<> [Tree (String, Key, Key, [token])
subtree]
          | Key
split <- [Key
origin .. Key
end]
          , (Key
caller, IntSet
origins, String
name) <- IntMap (IntMap [(Key, IntSet, String)])
-> Key -> Key -> [(Key, IntSet, String)]
forall edge. IntMap (IntMap [edge]) -> Key -> Key -> [edge]
edgesAt IntMap (IntMap [(Key, IntSet, String)])
completeBack Key
split Key
stateId
          , Key -> IntSet -> Bool
IntSet.member Key
origin IntSet
origins
          , [Tree (String, Key, Key, [token])]
prefix <- Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Maybe String
-> Key
-> Key
-> Key
-> [[Tree (String, Key, Key, [token])]]
itemForests Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' Maybe String
entry Key
origin Key
split Key
caller
          , Tree (String, Key, Key, [token])
subtree <- Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> String -> Key -> Key -> [Tree (String, Key, Key, [token])]
ruleTrees Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' String
name Key
split Key
end
          ]

    ruleTrees :: Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> String -> Key -> Key -> [Tree (String, Key, Key, [token])]
ruleTrees Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards String
name Key
start Key
end
      | Either (Maybe String, Key, Key, Key) (String, Key, Key)
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Either (Maybe String, Key, Key, Key) (String, Key, Key)
ruleKey Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards = []
      | Bool
otherwise = [Tree (String, Key, Key, [token])]
nullableTrees [Tree (String, Key, Key, [token])]
-> [Tree (String, Key, Key, [token])]
-> [Tree (String, Key, Key, [token])]
forall a. Semigroup a => a -> a -> a
<> [Tree (String, Key, Key, [token])]
derivedTrees
      where
        ruleKey :: Either (Maybe String, Key, Key, Key) (String, Key, Key)
ruleKey = (String, Key, Key)
-> Either (Maybe String, Key, Key, Key) (String, Key, Key)
forall a b. b -> Either a b
Right (String
name, Key
start, Key
end)
        guards' :: Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' = Either (Maybe String, Key, Key, Key) (String, Key, Key)
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
forall a. Ord a => a -> Set a -> Set a
Set.insert Either (Maybe String, Key, Key, Key) (String, Key, Key)
ruleKey Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards

        nullableTrees :: [Tree (String, Key, Key, [token])]
nullableTrees
          | Key
start Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
end Bool -> Bool -> Bool
&& String -> Bool
ruleNullable String
name = [(String, Key, Key, [token])
-> [Tree (String, Key, Key, [token])]
-> Tree (String, Key, Key, [token])
forall a. a -> [Tree a] -> Tree a
Node (String
name, Key
start, Key
end, []) []]
          | Bool
otherwise = []

        derivedTrees :: [Tree (String, Key, Key, [token])]
derivedTrees = case String -> Map String Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String Key
ruleFinals of
          Maybe Key
Nothing -> []
          Just Key
finalState ->
            [ (String, Key, Key, [token])
-> [Tree (String, Key, Key, [token])]
-> Tree (String, Key, Key, [token])
forall a. a -> [Tree a] -> Tree a
Node (String
name, Key
start, Key
end, Key -> Key -> [token]
sliceAt Key
start Key
end) [Tree (String, Key, Key, [token])]
subtrees
            | [Tree (String, Key, Key, [token])]
subtrees <- Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
-> Maybe String
-> Key
-> Key
-> Key
-> [[Tree (String, Key, Key, [token])]]
itemForests Set (Either (Maybe String, Key, Key, Key) (String, Key, Key))
guards' (String -> Maybe String
forall a. a -> Maybe a
Just String
name) Key
start Key
end Key
finalState
            ]

prefixGen
  :: Categorized token
  => Transducer token
  -> [token]
  -> (Int, IntMap (IntMap IntSet))
prefixGen :: forall token.
Categorized token =>
Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
prefixGen Transducer token
et [token]
word = Key
-> IntMap (IntMap IntSet)
-> [token]
-> (Key, IntMap (IntMap IntSet))
go Key
0 (Transducer token -> IntMap (IntMap IntSet)
forall token. Transducer token -> IntMap (IntMap IntSet)
initialChart Transducer token
et) [token]
word
  where
    go :: Key
-> IntMap (IntMap IntSet)
-> [token]
-> (Key, IntMap (IntMap IntSet))
go Key
j IntMap (IntMap IntSet)
chart [] = (Key
j, IntMap (IntMap IntSet)
chart)
    go Key
j IntMap (IntMap IntSet)
chart (token
x : [token]
xs) =
      let scanned :: IntMap IntSet
scanned = Key -> token -> IntMap (IntMap IntSet) -> IntMap IntSet
scanFrom Key
j token
x IntMap (IntMap IntSet)
chart
          closed :: IntMap (IntMap IntSet)
closed = Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
forall token.
Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
closeChartAt Transducer token
et (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) (Key
-> IntMap IntSet
-> IntMap (IntMap IntSet)
-> IntMap (IntMap IntSet)
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) IntMap IntSet
scanned IntMap (IntMap IntSet)
chart)
      in Key
-> IntMap (IntMap IntSet)
-> [token]
-> (Key, IntMap (IntMap IntSet))
go (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) IntMap (IntMap IntSet)
closed [token]
xs

    scanFrom :: Key -> token -> IntMap (IntMap IntSet) -> IntMap IntSet
scanFrom Key
j token
input IntMap (IntMap IntSet)
chart = (Key -> IntSet -> IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key -> IntSet -> IntMap IntSet -> IntMap IntSet
advance IntMap IntSet
forall a. IntMap a
IntMap.empty IntMap IntSet
eJ
      where
        eJ :: IntMap IntSet
eJ = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
chart
        advance :: Key -> IntSet -> IntMap IntSet -> IntMap IntSet
advance Key
s IntSet
origs IntMap IntSet
acc = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
s (Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et) of
          Just (TransitionTokenClass TokenClass token
cls IntSet
ds) | TokenClass token -> token -> Bool
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass TokenClass token
cls token
input ->
            (Key -> IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet -> IntSet -> IntMap IntSet
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr
              (\Key
d -> (IntSet -> IntSet -> IntSet)
-> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
IntMap.insertWith IntSet -> IntSet -> IntSet
IntSet.union Key
d IntSet
origs) IntMap IntSet
acc IntSet
ds
          Maybe (TransducerStep token)
_ -> IntMap IntSet
acc

{- | What token is expected next?
The scanner frontier, `expectNext` returns the `TokenClass`
that can be scanned next after the given input prefix.
A `falseB` result means the current chart has no scanner transitions,
i.e. the prefix is a dead end for recognition.
-}
expectNext
  :: Categorized token
  => Transducer token -> [token] {- ^ prefix -} -> TokenClass token
expectNext :: forall token.
Categorized token =>
Transducer token -> [token] -> TokenClass token
expectNext Transducer token
et [token]
word = ((TokenClass token, IntMap (IntMap IntSet)) -> TokenClass token)
-> [(TokenClass token, IntMap (IntMap IntSet))] -> TokenClass token
forall (f :: * -> *) b a.
(Foldable f, BooleanAlgebra b) =>
(a -> b) -> f a -> b
anyB (TokenClass token, IntMap (IntMap IntSet)) -> TokenClass token
forall a b. (a, b) -> a
fst (Transducer token
-> Key
-> IntMap (IntMap IntSet)
-> [(TokenClass token, IntMap (IntMap IntSet))]
forall token.
Categorized token =>
Transducer token
-> Key
-> IntMap (IntMap IntSet)
-> [(TokenClass token, IntMap (IntMap IntSet))]
scanClassOptions Transducer token
et Key
n IntMap (IntMap IntSet)
chart)
  where
    (Key
n, IntMap (IntMap IntSet)
chart) = Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
forall token.
Categorized token =>
Transducer token -> [token] -> (Key, IntMap (IntMap IntSet))
prefixGen Transducer token
et [token]
word

{- |
Rule names that can never be entered from the start
expression — dead productions. A non-empty result is a grammar-hygiene
warning: those rules can be deleted without changing the recognized language.
-}
unreachableRules :: Transducer token -> Set String
unreachableRules :: forall token. Transducer token -> Set String
unreachableRules Transducer token
et =
  Map String (IntSet, Bool) -> Set String
forall k a. Map k a -> Set k
Map.keysSet (Transducer token -> Map String (IntSet, Bool)
forall token. Transducer token -> Map String (IntSet, Bool)
transducerRules Transducer token
et) Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
called
  where
    called :: Set String
called = IntSet -> IntSet -> Set String -> Set String
bfs (Transducer token -> IntSet
forall token. Transducer token -> IntSet
transducerStarts Transducer token
et) IntSet
IntSet.empty Set String
forall a. Set a
Set.empty

    bfs :: IntSet -> IntSet -> Set String -> Set String
bfs IntSet
frontier IntSet
seen Set String
calls
      | IntSet -> Bool
IntSet.null IntSet
fresh = Set String
calls
      | Bool
otherwise = IntSet -> IntSet -> Set String -> Set String
bfs IntSet
next (IntSet
seen IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
fresh) Set String
calls'
      where
        fresh :: IntSet
fresh = IntSet -> IntSet -> IntSet
IntSet.difference IntSet
frontier IntSet
seen
        (IntSet
next, Set String
calls') = (Key -> (IntSet, Set String) -> (IntSet, Set String))
-> (IntSet, Set String) -> IntSet -> (IntSet, Set String)
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr Key -> (IntSet, Set String) -> (IntSet, Set String)
step (IntSet
IntSet.empty, Set String
calls) IntSet
fresh

    step :: Key -> (IntSet, Set String) -> (IntSet, Set String)
step Key
s (IntSet
acc, Set String
cs) = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
s (Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et) of
      Just (TransitionTokenClass TokenClass token
_ IntSet
ds) -> (IntSet
acc IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
ds, Set String
cs)
      Just (TransitionNonTerminal String
name IntSet
ds) ->
        let firsts :: IntSet
firsts = IntSet
-> ((IntSet, Bool) -> IntSet) -> Maybe (IntSet, Bool) -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
IntSet.empty (IntSet, Bool) -> IntSet
forall a b. (a, b) -> a
fst (String -> Map String (IntSet, Bool) -> Maybe (IntSet, Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name (Transducer token -> Map String (IntSet, Bool)
forall token. Transducer token -> Map String (IntSet, Bool)
transducerRules Transducer token
et))
        in (IntSet
acc IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
ds IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> IntSet
firsts, String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
name Set String
cs)
      Just (EmitNonTerminal String
_) -> (IntSet
acc, Set String
cs)
      Maybe (TransducerStep token)
Nothing -> (IntSet
acc, Set String
cs)

{- |
`languageSample` lazily produces all words in a language from shortest to longest.
However since `TokenClass`es can resolve to infinite sets of tokens,
and the relevant case of `Char` tokens while not infinite is huge,
it samples tokens in an `Applicative` `TokenAlgebra`.
-}
languageSample
  :: (TokenAlgebra token (f token), Applicative f)
  => Transducer token -- ^ transducer
  -> f [[token]]
languageSample :: forall token (f :: * -> *).
(TokenAlgebra token (f token), Applicative f) =>
Transducer token -> f [[token]]
languageSample Transducer token
et = [f [token]] -> f [[token]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA (([TokenClass token] -> f [token])
-> [[TokenClass token]] -> [f [token]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TokenClass token] -> f [token]
sampleWord [[TokenClass token]]
classWords)
  where

    classWords :: [[TokenClass token]]
classWords = [(Key, [TokenClass token], IntMap (IntMap IntSet))]
-> Set [TokenClass token] -> [[TokenClass token]]
enumerateByLength [(Key
0, [], Transducer token -> IntMap (IntMap IntSet)
forall token. Transducer token -> IntMap (IntMap IntSet)
initialChart Transducer token
et)] Set [TokenClass token]
forall a. Set a
Set.empty

    sampleWord :: [TokenClass token] -> f [token]
sampleWord = (TokenClass token -> f token) -> [TokenClass token] -> f [token]
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 TokenClass token -> f token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass ([TokenClass token] -> f [token])
-> ([TokenClass token] -> [TokenClass token])
-> [TokenClass token]
-> f [token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenClass token] -> [TokenClass token]
forall a. [a] -> [a]
reverse

    enumerateByLength :: [(Key, [TokenClass token], IntMap (IntMap IntSet))]
-> Set [TokenClass token] -> [[TokenClass token]]
enumerateByLength [] Set [TokenClass token]
_ = []
    enumerateByLength [(Key, [TokenClass token], IntMap (IntMap IntSet))]
frontier Set [TokenClass token]
seen =
      let
        ([[TokenClass token]]
accepted, Set [TokenClass token]
seen') = [(Key, [TokenClass token], IntMap (IntMap IntSet))]
-> Set [TokenClass token]
-> ([[TokenClass token]], Set [TokenClass token])
forall {t :: * -> *} {b}.
(Foldable t, Ord b) =>
t (Key, b, IntMap (IntMap IntSet)) -> Set b -> ([b], Set b)
acceptedAtFrontier [(Key, [TokenClass token], IntMap (IntMap IntSet))]
frontier Set [TokenClass token]
seen
        next :: [(Key, [TokenClass token], IntMap (IntMap IntSet))]
next = ((Key, [TokenClass token], IntMap (IntMap IntSet))
 -> [(Key, [TokenClass token], IntMap (IntMap IntSet))])
-> [(Key, [TokenClass token], IntMap (IntMap IntSet))]
-> [(Key, [TokenClass token], IntMap (IntMap IntSet))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Key, [TokenClass token], IntMap (IntMap IntSet))
-> [(Key, [TokenClass token], IntMap (IntMap IntSet))]
expand [(Key, [TokenClass token], IntMap (IntMap IntSet))]
frontier
      in [[TokenClass token]]
accepted [[TokenClass token]]
-> [[TokenClass token]] -> [[TokenClass token]]
forall a. Semigroup a => a -> a -> a
<> [(Key, [TokenClass token], IntMap (IntMap IntSet))]
-> Set [TokenClass token] -> [[TokenClass token]]
enumerateByLength [(Key, [TokenClass token], IntMap (IntMap IntSet))]
next Set [TokenClass token]
seen'

    acceptedAtFrontier :: t (Key, b, IntMap (IntMap IntSet)) -> Set b -> ([b], Set b)
acceptedAtFrontier t (Key, b, IntMap (IntMap IntSet))
frontier Set b
seen0 =
      let ([b]
acceptedRev, Set b
seen') = (([b], Set b) -> (Key, b, IntMap (IntMap IntSet)) -> ([b], Set b))
-> ([b], Set b)
-> t (Key, b, IntMap (IntMap IntSet))
-> ([b], Set b)
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([b], Set b) -> (Key, b, IntMap (IntMap IntSet)) -> ([b], Set b)
forall {b}.
Ord b =>
([b], Set b) -> (Key, b, IntMap (IntMap IntSet)) -> ([b], Set b)
step ([], Set b
seen0) t (Key, b, IntMap (IntMap IntSet))
frontier
      in ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
acceptedRev, Set b
seen')
      where
        step :: ([b], Set b) -> (Key, b, IntMap (IntMap IntSet)) -> ([b], Set b)
step ([b]
acc, Set b
seen) (Key
j, b
revWord, IntMap (IntMap IntSet)
chart)
          | Key -> IntMap (IntMap IntSet) -> Bool
acceptsChart Key
j IntMap (IntMap IntSet)
chart =
              if b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member b
revWord Set b
seen
                then ([b]
acc, Set b
seen)
                else (b
revWord b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
acc, b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
revWord Set b
seen)
          | Bool
otherwise = ([b]
acc, Set b
seen)

    expand :: (Key, [TokenClass token], IntMap (IntMap IntSet))
-> [(Key, [TokenClass token], IntMap (IntMap IntSet))]
expand (Key
j, [TokenClass token]
revWord, IntMap (IntMap IntSet)
chart) =
      [ (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1, TokenClass token
cls TokenClass token -> [TokenClass token] -> [TokenClass token]
forall a. a -> [a] -> [a]
: [TokenClass token]
revWord, IntMap (IntMap IntSet)
nextChart)
      | (TokenClass token
cls, IntMap (IntMap IntSet)
nextChart) <- Transducer token
-> Key
-> IntMap (IntMap IntSet)
-> [(TokenClass token, IntMap (IntMap IntSet))]
forall token.
Categorized token =>
Transducer token
-> Key
-> IntMap (IntMap IntSet)
-> [(TokenClass token, IntMap (IntMap IntSet))]
scanClassOptions Transducer token
et Key
j IntMap (IntMap IntSet)
chart
      ]

initialChart
  :: Transducer token
  -> IntMap (IntMap IntSet)
initialChart :: forall token. Transducer token -> IntMap (IntMap IntSet)
initialChart Transducer token
et = Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
forall token.
Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
closeChartAt Transducer token
et Key
0 (Key -> IntMap IntSet -> IntMap (IntMap IntSet)
forall a. Key -> a -> IntMap a
IntMap.singleton Key
0 IntMap IntSet
initialE0)
  where
    initialE0 :: IntMap IntSet
initialE0 = [(Key, IntSet)] -> IntMap IntSet
forall a. [(Key, a)] -> IntMap a
IntMap.fromList
      [ (Key
s, Key -> IntSet
IntSet.singleton Key
0) | Key
s <- IntSet -> [Key]
IntSet.toList (Transducer token -> IntSet
forall token. Transducer token -> IntSet
transducerStarts Transducer token
et) ]

-- Accept iff (q_accept, 0) is in E_n.
acceptsChart
  :: Int
  -> IntMap (IntMap IntSet)
  -> Bool
acceptsChart :: Key -> IntMap (IntMap IntSet) -> Bool
acceptsChart Key
j IntMap (IntMap IntSet)
chart = Key -> IntSet -> Bool
IntSet.member Key
0 IntSet
acceptOrigins
  where
    eJ :: IntMap IntSet
eJ = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
chart
    acceptOrigins :: IntSet
acceptOrigins = IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Key
0 IntMap IntSet
eJ

-- Group all scanner moves from E_j by token class; each result also carries the
-- closed successor chart at j+1.
scanClassOptions
  :: Categorized token
  => Transducer token
  -> Int
  -> IntMap (IntMap IntSet)
  -> [(TokenClass token, IntMap (IntMap IntSet))]
scanClassOptions :: forall token.
Categorized token =>
Transducer token
-> Key
-> IntMap (IntMap IntSet)
-> [(TokenClass token, IntMap (IntMap IntSet))]
scanClassOptions Transducer token
et Key
j IntMap (IntMap IntSet)
chart =
  [ (TokenClass token
cls, Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
forall token.
Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
closeChartAt Transducer token
et (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) (Key
-> IntMap IntSet
-> IntMap (IntMap IntSet)
-> IntMap (IntMap IntSet)
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert (Key
j Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) IntMap IntSet
scanned IntMap (IntMap IntSet)
chart))
  | (TokenClass token
cls, IntMap IntSet
scanned) <- Map (TokenClass token) (IntMap IntSet)
-> [(TokenClass token, IntMap IntSet)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (TokenClass token) (IntMap IntSet)
grouped
  ]
  where
    grouped :: Map (TokenClass token) (IntMap IntSet)
grouped = (Key
 -> IntSet
 -> Map (TokenClass token) (IntMap IntSet)
 -> Map (TokenClass token) (IntMap IntSet))
-> Map (TokenClass token) (IntMap IntSet)
-> IntMap IntSet
-> Map (TokenClass token) (IntMap IntSet)
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key
-> IntSet
-> Map (TokenClass token) (IntMap IntSet)
-> Map (TokenClass token) (IntMap IntSet)
advance Map (TokenClass token) (IntMap IntSet)
forall k a. Map k a
Map.empty IntMap IntSet
eJ
    eJ :: IntMap IntSet
eJ = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
chart

    advance :: Key
-> IntSet
-> Map (TokenClass token) (IntMap IntSet)
-> Map (TokenClass token) (IntMap IntSet)
advance Key
s IntSet
origs Map (TokenClass token) (IntMap IntSet)
acc = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
s (Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et) of
      Just (TransitionTokenClass TokenClass token
cls IntSet
ds) ->
        (IntMap IntSet -> IntMap IntSet -> IntMap IntSet)
-> TokenClass token
-> IntMap IntSet
-> Map (TokenClass token) (IntMap IntSet)
-> Map (TokenClass token) (IntMap IntSet)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union) TokenClass token
cls IntMap IntSet
scanned Map (TokenClass token) (IntMap IntSet)
acc
        where
          scanned :: IntMap IntSet
scanned = (Key -> IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet -> IntSet -> IntMap IntSet
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr
            (\Key
d -> (IntSet -> IntSet -> IntSet)
-> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
IntMap.insertWith IntSet -> IntSet -> IntSet
IntSet.union Key
d IntSet
origs) IntMap IntSet
forall a. IntMap a
IntMap.empty IntSet
ds
      Maybe (TransducerStep token)
_ -> Map (TokenClass token) (IntMap IntSet)
acc

closeChartAt
  :: Transducer token
  -> Int
  -> IntMap (IntMap IntSet)
  -> IntMap (IntMap IntSet)
closeChartAt :: forall token.
Transducer token
-> Key -> IntMap (IntMap IntSet) -> IntMap (IntMap IntSet)
closeChartAt Transducer token
et Key
j IntMap (IntMap IntSet)
initialChart0 = [(Key, Key)]
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (IntMap IntSet)
loop [(Key, Key)]
initialWork IntMap (IntMap IntSet)
initialChart0 IntMap (Map String [(IntSet, IntSet)])
forall a. IntMap a
IntMap.empty
  where
    initialEJ :: IntMap IntSet
initialEJ = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
initialChart0
    initialWork :: [(Key, Key)]
initialWork =
      [ (Key
s, Key
i) | (Key
s, IntSet
os) <- IntMap IntSet -> [(Key, IntSet)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap IntSet
initialEJ, Key
i <- IntSet -> [Key]
IntSet.toList IntSet
os ]

    -- For fixed i < j, E_i does not change while closing E_j. Cache an index
    -- from nonterminal name to caller origins/continuations to speed completion.
    -- IntMap key: origin index i
    -- Map key: nonterminal name
    -- Value: list of (caller origins, continuation destinations)

    -- Earley closure at E_j: apply predict/complete until fixed point.
    loop :: [(Key, Key)]
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (IntMap IntSet)
loop [] IntMap (IntMap IntSet)
chart IntMap (Map String [(IntSet, IntSet)])
_ = IntMap (IntMap IntSet)
chart
    loop ((Key
s, Key
i) : [(Key, Key)]
rest) IntMap (IntMap IntSet)
chart IntMap (Map String [(IntSet, IntSet)])
callerCache = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
s (Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et) of
      Just (TransitionNonTerminal String
name IntSet
ds) ->
        let
          (IntSet
firsts, Bool
isNull) = (IntSet, Bool)
-> String -> Map String (IntSet, Bool) -> (IntSet, Bool)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
            (IntSet
IntSet.empty, Bool
False) String
name (Transducer token -> Map String (IntSet, Bool)
forall token. Transducer token -> Map String (IntSet, Bool)
transducerRules Transducer token
et)
          predItems :: [(Key, Key)]
predItems = [(Key
f, Key
j) | Key
f <- IntSet -> [Key]
IntSet.toList IntSet
firsts]
          nullItems :: [(Key, Key)]
nullItems =
            if Bool
isNull then [(Key
d, Key
i) | Key
d <- IntSet -> [Key]
IntSet.toList IntSet
ds] else []
          (IntMap (IntMap IntSet)
chart', [(Key, Key)]
new) = [(Key, Key)]
-> IntMap (IntMap IntSet) -> (IntMap (IntMap IntSet), [(Key, Key)])
addEarleyItems ([(Key, Key)]
predItems [(Key, Key)] -> [(Key, Key)] -> [(Key, Key)]
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)]
nullItems) IntMap (IntMap IntSet)
chart
        in [(Key, Key)]
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (IntMap IntSet)
loop ([(Key, Key)]
new [(Key, Key)] -> [(Key, Key)] -> [(Key, Key)]
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)]
rest) IntMap (IntMap IntSet)
chart' IntMap (Map String [(IntSet, IntSet)])
callerCache
      Just (EmitNonTerminal String
name) ->
        let
          (Map String [(IntSet, IntSet)]
ixed, IntMap (Map String [(IntSet, IntSet)])
callerCache') = Key
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> (Map String [(IntSet, IntSet)],
    IntMap (Map String [(IntSet, IntSet)]))
callerEntries Key
i IntMap (IntMap IntSet)
chart IntMap (Map String [(IntSet, IntSet)])
callerCache
          callerRows :: [(IntSet, IntSet)]
callerRows = [(IntSet, IntSet)]
-> String -> Map String [(IntSet, IntSet)] -> [(IntSet, IntSet)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
name Map String [(IntSet, IntSet)]
ixed
          completions :: [(Key, Key)]
completions =
            [ (Key
d, Key
i')
            | (IntSet
os, IntSet
ds) <- [(IntSet, IntSet)]
callerRows
            , Key
i' <- IntSet -> [Key]
IntSet.toList IntSet
os
            , Key
d <- IntSet -> [Key]
IntSet.toList IntSet
ds
            ]
          (IntMap (IntMap IntSet)
chart', [(Key, Key)]
new) = [(Key, Key)]
-> IntMap (IntMap IntSet) -> (IntMap (IntMap IntSet), [(Key, Key)])
addEarleyItems [(Key, Key)]
completions IntMap (IntMap IntSet)
chart
        in [(Key, Key)]
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (IntMap IntSet)
loop ([(Key, Key)]
new [(Key, Key)] -> [(Key, Key)] -> [(Key, Key)]
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)]
rest) IntMap (IntMap IntSet)
chart' IntMap (Map String [(IntSet, IntSet)])
callerCache'
      Maybe (TransducerStep token)
_ -> [(Key, Key)]
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (IntMap IntSet)
loop [(Key, Key)]
rest IntMap (IntMap IntSet)
chart IntMap (Map String [(IntSet, IntSet)])
callerCache

    callerEntries :: Key
-> IntMap (IntMap IntSet)
-> IntMap (Map String [(IntSet, IntSet)])
-> (Map String [(IntSet, IntSet)],
    IntMap (Map String [(IntSet, IntSet)]))
callerEntries Key
i IntMap (IntMap IntSet)
chart IntMap (Map String [(IntSet, IntSet)])
callerCache
      -- E_j mutates during closure, so do not cache index for i == j.
      | Key
i Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
j = (IntMap IntSet -> Map String [(IntSet, IntSet)]
buildCallerIndex (IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
i IntMap (IntMap IntSet)
chart), IntMap (Map String [(IntSet, IntSet)])
callerCache)
      | Bool
otherwise = case Key
-> IntMap (Map String [(IntSet, IntSet)])
-> Maybe (Map String [(IntSet, IntSet)])
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
i IntMap (Map String [(IntSet, IntSet)])
callerCache of
          Just Map String [(IntSet, IntSet)]
ixed -> (Map String [(IntSet, IntSet)]
ixed, IntMap (Map String [(IntSet, IntSet)])
callerCache)
          Maybe (Map String [(IntSet, IntSet)])
Nothing ->
            let ixed :: Map String [(IntSet, IntSet)]
ixed = IntMap IntSet -> Map String [(IntSet, IntSet)]
buildCallerIndex (IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
i IntMap (IntMap IntSet)
chart)
            in (Map String [(IntSet, IntSet)]
ixed, Key
-> Map String [(IntSet, IntSet)]
-> IntMap (Map String [(IntSet, IntSet)])
-> IntMap (Map String [(IntSet, IntSet)])
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
i Map String [(IntSet, IntSet)]
ixed IntMap (Map String [(IntSet, IntSet)])
callerCache)

    buildCallerIndex :: IntMap IntSet -> Map String [(IntSet, IntSet)]
buildCallerIndex IntMap IntSet
eI = (Key
 -> IntSet
 -> Map String [(IntSet, IntSet)]
 -> Map String [(IntSet, IntSet)])
-> Map String [(IntSet, IntSet)]
-> IntMap IntSet
-> Map String [(IntSet, IntSet)]
forall a b. (Key -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Key
-> IntSet
-> Map String [(IntSet, IntSet)]
-> Map String [(IntSet, IntSet)]
step Map String [(IntSet, IntSet)]
forall k a. Map k a
Map.empty IntMap IntSet
eI
      where
        step :: Key
-> IntSet
-> Map String [(IntSet, IntSet)]
-> Map String [(IntSet, IntSet)]
step Key
t IntSet
os Map String [(IntSet, IntSet)]
acc = case Key
-> IntMap (TransducerStep token) -> Maybe (TransducerStep token)
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
t (Transducer token -> IntMap (TransducerStep token)
forall token. Transducer token -> IntMap (TransducerStep token)
transducerRelations Transducer token
et) of
          Just (TransitionNonTerminal String
n IntSet
ds) ->
            ([(IntSet, IntSet)] -> [(IntSet, IntSet)] -> [(IntSet, IntSet)])
-> String
-> [(IntSet, IntSet)]
-> Map String [(IntSet, IntSet)]
-> Map String [(IntSet, IntSet)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(IntSet, IntSet)] -> [(IntSet, IntSet)] -> [(IntSet, IntSet)]
forall a. [a] -> [a] -> [a]
(++) String
n [(IntSet
os, IntSet
ds)] Map String [(IntSet, IntSet)]
acc
          Maybe (TransducerStep token)
_ -> Map String [(IntSet, IntSet)]
acc

    addEarleyItems :: [(Key, Key)]
-> IntMap (IntMap IntSet) -> (IntMap (IntMap IntSet), [(Key, Key)])
addEarleyItems [(Key, Key)]
items IntMap (IntMap IntSet)
chart = ((IntMap (IntMap IntSet), [(Key, Key)])
 -> (Key, Key) -> (IntMap (IntMap IntSet), [(Key, Key)]))
-> (IntMap (IntMap IntSet), [(Key, Key)])
-> [(Key, Key)]
-> (IntMap (IntMap IntSet), [(Key, Key)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap (IntMap IntSet), [(Key, Key)])
-> (Key, Key) -> (IntMap (IntMap IntSet), [(Key, Key)])
ins (IntMap (IntMap IntSet)
chart, []) [(Key, Key)]
items
      where
        ins :: (IntMap (IntMap IntSet), [(Key, Key)])
-> (Key, Key) -> (IntMap (IntMap IntSet), [(Key, Key)])
ins (IntMap (IntMap IntSet)
acc, [(Key, Key)]
new) (Key
state, Key
origin) =
          let
            eJ :: IntMap IntSet
eJ = IntMap IntSet -> Key -> IntMap (IntMap IntSet) -> IntMap IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntMap IntSet
forall a. IntMap a
IntMap.empty Key
j IntMap (IntMap IntSet)
acc
            os :: IntSet
os = IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Key
state IntMap IntSet
eJ
          in if Key -> IntSet -> Bool
IntSet.member Key
origin IntSet
os
            then (IntMap (IntMap IntSet)
acc, [(Key, Key)]
new)
            else
              let
                eJ' :: IntMap IntSet
eJ' = Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
state (Key -> IntSet -> IntSet
IntSet.insert Key
origin IntSet
os) IntMap IntSet
eJ
                acc' :: IntMap (IntMap IntSet)
acc' = Key
-> IntMap IntSet
-> IntMap (IntMap IntSet)
-> IntMap (IntMap IntSet)
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
j IntMap IntSet
eJ' IntMap (IntMap IntSet)
acc
              in (IntMap (IntMap IntSet)
acc', (Key
state, Key
origin) (Key, Key) -> [(Key, Key)] -> [(Key, Key)]
forall a. a -> [a] -> [a]
: [(Key, Key)]
new)