{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TemplateHaskell #-}

-- | LR-parser.

module ParseTable where

import Control.Monad
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Trans.Maybe

import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.List.NonEmpty as List1
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

import Data.Bifunctor (first, second)
import Data.Function (on)
import Data.Maybe (catMaybes, maybeToList, listToMaybe, fromMaybe)
import Data.Either (partitionEithers)
import Data.Semigroup (Semigroup(..))

-- uses microlens-platform
import Lens.Micro
import Lens.Micro.Extras (view)
import Lens.Micro.TH (makeLenses)

import qualified LBNF.Abs as A
import LBNF.Print (Print, printTree)

import SetMaybe (SetMaybe(SetMaybe))
import qualified SetMaybe

import Util
import Saturation
import CFG

-- Shift-reduce parser.

-- | A stack is a sentential form (reversed).

newtype Stack' x t = Stack [Symbol' x t]
  deriving (Stack' x t -> Stack' x t -> Bool
(Stack' x t -> Stack' x t -> Bool)
-> (Stack' x t -> Stack' x t -> Bool) -> Eq (Stack' x t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x t. Eq t => Stack' x t -> Stack' x t -> Bool
$c== :: forall x t. Eq t => Stack' x t -> Stack' x t -> Bool
== :: Stack' x t -> Stack' x t -> Bool
$c/= :: forall x t. Eq t => Stack' x t -> Stack' x t -> Bool
/= :: Stack' x t -> Stack' x t -> Bool
Eq, Eq (Stack' x t)
Eq (Stack' x t) =>
(Stack' x t -> Stack' x t -> Ordering)
-> (Stack' x t -> Stack' x t -> Bool)
-> (Stack' x t -> Stack' x t -> Bool)
-> (Stack' x t -> Stack' x t -> Bool)
-> (Stack' x t -> Stack' x t -> Bool)
-> (Stack' x t -> Stack' x t -> Stack' x t)
-> (Stack' x t -> Stack' x t -> Stack' x t)
-> Ord (Stack' x t)
Stack' x t -> Stack' x t -> Bool
Stack' x t -> Stack' x t -> Ordering
Stack' x t -> Stack' x t -> Stack' x 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 x t. Ord t => Eq (Stack' x t)
forall x t. Ord t => Stack' x t -> Stack' x t -> Bool
forall x t. Ord t => Stack' x t -> Stack' x t -> Ordering
forall x t. Ord t => Stack' x t -> Stack' x t -> Stack' x t
$ccompare :: forall x t. Ord t => Stack' x t -> Stack' x t -> Ordering
compare :: Stack' x t -> Stack' x t -> Ordering
$c< :: forall x t. Ord t => Stack' x t -> Stack' x t -> Bool
< :: Stack' x t -> Stack' x t -> Bool
$c<= :: forall x t. Ord t => Stack' x t -> Stack' x t -> Bool
<= :: Stack' x t -> Stack' x t -> Bool
$c> :: forall x t. Ord t => Stack' x t -> Stack' x t -> Bool
> :: Stack' x t -> Stack' x t -> Bool
$c>= :: forall x t. Ord t => Stack' x t -> Stack' x t -> Bool
>= :: Stack' x t -> Stack' x t -> Bool
$cmax :: forall x t. Ord t => Stack' x t -> Stack' x t -> Stack' x t
max :: Stack' x t -> Stack' x t -> Stack' x t
$cmin :: forall x t. Ord t => Stack' x t -> Stack' x t -> Stack' x t
min :: Stack' x t -> Stack' x t -> Stack' x t
Ord, Int -> Stack' x t -> ShowS
[Stack' x t] -> ShowS
Stack' x t -> String
(Int -> Stack' x t -> ShowS)
-> (Stack' x t -> String)
-> ([Stack' x t] -> ShowS)
-> Show (Stack' x t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x t. (Show t, Show x) => Int -> Stack' x t -> ShowS
forall x t. (Show t, Show x) => [Stack' x t] -> ShowS
forall x t. (Show t, Show x) => Stack' x t -> String
$cshowsPrec :: forall x t. (Show t, Show x) => Int -> Stack' x t -> ShowS
showsPrec :: Int -> Stack' x t -> ShowS
$cshow :: forall x t. (Show t, Show x) => Stack' x t -> String
show :: Stack' x t -> String
$cshowList :: forall x t. (Show t, Show x) => [Stack' x t] -> ShowS
showList :: [Stack' x t] -> ShowS
Show)

type Input' t = [t]

-- | The state of a shift-reduce parser consists of a stack and some input.

data SRState' x t = SRState
  { forall x t. SRState' x t -> Stack' x t
_srStack :: Stack' x t
  , forall x t. SRState' x t -> Input' t
_srInput :: Input' t
  } deriving (Int -> SRState' x t -> ShowS
[SRState' x t] -> ShowS
SRState' x t -> String
(Int -> SRState' x t -> ShowS)
-> (SRState' x t -> String)
-> ([SRState' x t] -> ShowS)
-> Show (SRState' x t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x t. (Show t, Show x) => Int -> SRState' x t -> ShowS
forall x t. (Show t, Show x) => [SRState' x t] -> ShowS
forall x t. (Show t, Show x) => SRState' x t -> String
$cshowsPrec :: forall x t. (Show t, Show x) => Int -> SRState' x t -> ShowS
showsPrec :: Int -> SRState' x t -> ShowS
$cshow :: forall x t. (Show t, Show x) => SRState' x t -> String
show :: SRState' x t -> String
$cshowList :: forall x t. (Show t, Show x) => [SRState' x t] -> ShowS
showList :: [SRState' x t] -> ShowS
Show)
makeLenses ''SRState'

-- | An action of a shift-reduce parser.

data SRAction' x r t
  = Shift                 -- ^ Shift next token onto stack.
  | Reduce (Rule' x r t)  -- ^ Reduce with given rule.
  deriving (Int -> SRAction' x r t -> ShowS
[SRAction' x r t] -> ShowS
SRAction' x r t -> String
(Int -> SRAction' x r t -> ShowS)
-> (SRAction' x r t -> String)
-> ([SRAction' x r t] -> ShowS)
-> Show (SRAction' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> SRAction' x r t -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
[SRAction' x r t] -> ShowS
forall x r t. (Show x, Show r, Show t) => SRAction' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> SRAction' x r t -> ShowS
showsPrec :: Int -> SRAction' x r t -> ShowS
$cshow :: forall x r t. (Show x, Show r, Show t) => SRAction' x r t -> String
show :: SRAction' x r t -> String
$cshowList :: forall x r t.
(Show x, Show r, Show t) =>
[SRAction' x r t] -> ShowS
showList :: [SRAction' x r t] -> ShowS
Show)

type Action' x r t = Maybe (SRAction' x r t)  -- ^ Nothing means halt.

data Rule' x r t = Rule (NT' x) (Alt' x r t)
  deriving (Rule' x r t -> Rule' x r t -> Bool
(Rule' x r t -> Rule' x r t -> Bool)
-> (Rule' x r t -> Rule' x r t -> Bool) -> Eq (Rule' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t. (Eq r, Eq t) => Rule' x r t -> Rule' x r t -> Bool
$c== :: forall x r t. (Eq r, Eq t) => Rule' x r t -> Rule' x r t -> Bool
== :: Rule' x r t -> Rule' x r t -> Bool
$c/= :: forall x r t. (Eq r, Eq t) => Rule' x r t -> Rule' x r t -> Bool
/= :: Rule' x r t -> Rule' x r t -> Bool
Eq, Eq (Rule' x r t)
Eq (Rule' x r t) =>
(Rule' x r t -> Rule' x r t -> Ordering)
-> (Rule' x r t -> Rule' x r t -> Bool)
-> (Rule' x r t -> Rule' x r t -> Bool)
-> (Rule' x r t -> Rule' x r t -> Bool)
-> (Rule' x r t -> Rule' x r t -> Bool)
-> (Rule' x r t -> Rule' x r t -> Rule' x r t)
-> (Rule' x r t -> Rule' x r t -> Rule' x r t)
-> Ord (Rule' x r t)
Rule' x r t -> Rule' x r t -> Bool
Rule' x r t -> Rule' x r t -> Ordering
Rule' x r t -> Rule' x r t -> Rule' x r 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 x r t. (Ord r, Ord t) => Eq (Rule' x r t)
forall x r t. (Ord r, Ord t) => Rule' x r t -> Rule' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
Rule' x r t -> Rule' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
Rule' x r t -> Rule' x r t -> Rule' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
Rule' x r t -> Rule' x r t -> Ordering
compare :: Rule' x r t -> Rule' x r t -> Ordering
$c< :: forall x r t. (Ord r, Ord t) => Rule' x r t -> Rule' x r t -> Bool
< :: Rule' x r t -> Rule' x r t -> Bool
$c<= :: forall x r t. (Ord r, Ord t) => Rule' x r t -> Rule' x r t -> Bool
<= :: Rule' x r t -> Rule' x r t -> Bool
$c> :: forall x r t. (Ord r, Ord t) => Rule' x r t -> Rule' x r t -> Bool
> :: Rule' x r t -> Rule' x r t -> Bool
$c>= :: forall x r t. (Ord r, Ord t) => Rule' x r t -> Rule' x r t -> Bool
>= :: Rule' x r t -> Rule' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
Rule' x r t -> Rule' x r t -> Rule' x r t
max :: Rule' x r t -> Rule' x r t -> Rule' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
Rule' x r t -> Rule' x r t -> Rule' x r t
min :: Rule' x r t -> Rule' x r t -> Rule' x r t
Ord, Int -> Rule' x r t -> ShowS
[Rule' x r t] -> ShowS
Rule' x r t -> String
(Int -> Rule' x r t -> ShowS)
-> (Rule' x r t -> String)
-> ([Rule' x r t] -> ShowS)
-> Show (Rule' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> Rule' x r t -> ShowS
forall x r t. (Show x, Show r, Show t) => [Rule' x r t] -> ShowS
forall x r t. (Show x, Show r, Show t) => Rule' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> Rule' x r t -> ShowS
showsPrec :: Int -> Rule' x r t -> ShowS
$cshow :: forall x r t. (Show x, Show r, Show t) => Rule' x r t -> String
show :: Rule' x r t -> String
$cshowList :: forall x r t. (Show x, Show r, Show t) => [Rule' x r t] -> ShowS
showList :: [Rule' x r t] -> ShowS
Show)

-- | A trace is a list of pairs of states and actions.

data TraceItem' x r t = TraceItem
  { forall x r t. TraceItem' x r t -> SRState' x t
_trState  :: SRState' x t
  , forall x r t. TraceItem' x r t -> Action' x r t
_trAction :: Action' x r t
  } deriving (Int -> TraceItem' x r t -> ShowS
[TraceItem' x r t] -> ShowS
TraceItem' x r t -> String
(Int -> TraceItem' x r t -> ShowS)
-> (TraceItem' x r t -> String)
-> ([TraceItem' x r t] -> ShowS)
-> Show (TraceItem' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show t, Show x, Show r) =>
Int -> TraceItem' x r t -> ShowS
forall x r t.
(Show t, Show x, Show r) =>
[TraceItem' x r t] -> ShowS
forall x r t.
(Show t, Show x, Show r) =>
TraceItem' x r t -> String
$cshowsPrec :: forall x r t.
(Show t, Show x, Show r) =>
Int -> TraceItem' x r t -> ShowS
showsPrec :: Int -> TraceItem' x r t -> ShowS
$cshow :: forall x r t.
(Show t, Show x, Show r) =>
TraceItem' x r t -> String
show :: TraceItem' x r t -> String
$cshowList :: forall x r t.
(Show t, Show x, Show r) =>
[TraceItem' x r t] -> ShowS
showList :: [TraceItem' x r t] -> ShowS
Show)

type Trace' x r t = [TraceItem' x r t]

-- | The next action is decided by a control function.

type Control' x r t m = SRState' x t -> MaybeT m (SRAction' x r t)

-- | Run a shift-reduce parser given by control function on some input,
--   Returning a trace of states and actions.

runShiftReduceParser :: (Eq t, Monad m)
  => Control' x r t m
  -> Input' t
  -> m (Trace' x r t)
runShiftReduceParser :: forall t (m :: * -> *) x r.
(Eq t, Monad m) =>
Control' x r t m -> Input' t -> m (Trace' x r t)
runShiftReduceParser Control' x r t m
nextAction Input' t
input = SRState' x t -> m [TraceItem' x r t]
loop (SRState' x t -> m [TraceItem' x r t])
-> SRState' x t -> m [TraceItem' x r t]
forall a b. (a -> b) -> a -> b
$ Stack' x t -> Input' t -> SRState' x t
forall x t. Stack' x t -> Input' t -> SRState' x t
SRState ([Symbol' x t] -> Stack' x t
forall x t. [Symbol' x t] -> Stack' x t
Stack []) Input' t
input
  where
  loop :: SRState' x t -> m [TraceItem' x r t]
loop st :: SRState' x t
st@(SRState (Stack [Symbol' x t]
stk) Input' t
ts0) = do
    act <- MaybeT m (SRAction' x r t) -> m (Maybe (SRAction' x r t))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (SRAction' x r t) -> m (Maybe (SRAction' x r t)))
-> MaybeT m (SRAction' x r t) -> m (Maybe (SRAction' x r t))
forall a b. (a -> b) -> a -> b
$ Control' x r t m
nextAction SRState' x t
st
    (TraceItem st act :) <$> do
      case (act, ts0) of
        (Maybe (SRAction' x r t)
Nothing   , Input' t
_   ) -> m [TraceItem' x r t]
forall {a}. m [a]
halt
        (Just SRAction' x r t
Shift, t
t:Input' t
ts) -> SRState' x t -> m [TraceItem' x r t]
loop (SRState' x t -> m [TraceItem' x r t])
-> SRState' x t -> m [TraceItem' x r t]
forall a b. (a -> b) -> a -> b
$ Stack' x t -> Input' t -> SRState' x t
forall x t. Stack' x t -> Input' t -> SRState' x t
SRState ([Symbol' x t] -> Stack' x t
forall x t. [Symbol' x t] -> Stack' x t
Stack ([Symbol' x t] -> Stack' x t) -> [Symbol' x t] -> Stack' x t
forall a b. (a -> b) -> a -> b
$ t -> Symbol' x t
forall x t. t -> Symbol' x t
Term t
t Symbol' x t -> [Symbol' x t] -> [Symbol' x t]
forall a. a -> [a] -> [a]
: [Symbol' x t]
stk) Input' t
ts
        (Just (Reduce (Rule NT' x
x (Alt r
r Form' x t
alpha))), Input' t
_)
          | Just [Symbol' x t]
stk' <- [Symbol' x t] -> Form' x t -> Maybe [Symbol' x t]
forall {t} {x}.
Eq t =>
[Symbol' x t] -> Form' x t -> Maybe [Symbol' x t]
matchStack [Symbol' x t]
stk Form' x t
alpha
                           -> SRState' x t -> m [TraceItem' x r t]
loop (SRState' x t -> m [TraceItem' x r t])
-> SRState' x t -> m [TraceItem' x r t]
forall a b. (a -> b) -> a -> b
$ Stack' x t -> Input' t -> SRState' x t
forall x t. Stack' x t -> Input' t -> SRState' x t
SRState ([Symbol' x t] -> Stack' x t
forall x t. [Symbol' x t] -> Stack' x t
Stack ([Symbol' x t] -> Stack' x t) -> [Symbol' x t] -> Stack' x t
forall a b. (a -> b) -> a -> b
$ NT' x -> Symbol' x t
forall x t. NT' x -> Symbol' x t
NonTerm NT' x
x Symbol' x t -> [Symbol' x t] -> [Symbol' x t]
forall a. a -> [a] -> [a]
: [Symbol' x t]
stk') Input' t
ts0
        (Maybe (SRAction' x r t), Input' t)
_ -> String -> m [TraceItem' x r t]
forall a. HasCallStack => String -> a
error String
"runShiftReduceParser: reduce failed"

  matchStack :: [Symbol' x t] -> Form' x t -> Maybe [Symbol' x t]
matchStack [Symbol' x t]
stk (Form [Symbol' x t]
alpha) = [Symbol' x t] -> [Symbol' x t] -> Maybe [Symbol' x t]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix ([Symbol' x t] -> [Symbol' x t]
forall a. [a] -> [a]
reverse [Symbol' x t]
alpha) [Symbol' x t]
stk
  halt :: m [a]
halt = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []


-- | A parse table maps pairs of states and symbols to actions.
--
--   Non-terminal 'Nothing' is the end of file.
--   For non-terminals, either a shift or a reduce action is returned.
--   For terminals, a goto action (next state) is returned.
--   If 'Nothing' is returned, the parser halts.

data ParseTable' x r t s = ParseTable
  { forall x r t s.
ParseTable' x r t s
-> s -> Maybe t -> Maybe (Either s (Rule' x r t))
_tabSR   :: s -> Maybe t -> Maybe (Either s (Rule' x r t))  -- ^ S/R-action on terminals.
  , forall x r t s. ParseTable' x r t s -> s -> NT' x -> Maybe s
_tabGoto :: s -> NT' x   -> Maybe s                         -- ^ Goto-action on reduction result.
  , forall x r t s. ParseTable' x r t s -> s
_tabInit :: s
  }
makeLenses ''ParseTable'

-- | A LR control stack is a non-empty list of states.
--   The bottom element is the initial state.

type LRStack' s = List1.NonEmpty s

-- | The LR control function modifies a control stack.
--   It interprets the parse table.

lr1Control :: ParseTable' x r t s -> Control' x r t (State (LRStack' s))
lr1Control :: forall x r t s.
ParseTable' x r t s -> Control' x r t (State (LRStack' s))
lr1Control (ParseTable s -> Maybe t -> Maybe (Either s (Rule' x r t))
tabSR s -> NT' x -> Maybe s
tabGoto s
_) (SRState Stack' x t
stk Input' t
input) = do
  -- Get control stack
  ss <- MaybeT (State (LRStack' s)) (LRStack' s)
forall s (m :: * -> *). MonadState s m => m s
get
  -- Query table on maybe top state and maybe first input token.
  (MaybeT $ return $ tabSR (List1.head ss) (listToMaybe input)) >>= \case
    -- Shift action:
    Left s
s -> do
      -- Put new state on top of stack
      (LRStack' s -> LRStack' s) -> MaybeT (State (LRStack' s)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LRStack' s -> LRStack' s) -> MaybeT (State (LRStack' s)) ())
-> (LRStack' s -> LRStack' s) -> MaybeT (State (LRStack' s)) ()
forall a b. (a -> b) -> a -> b
$ s -> LRStack' s -> LRStack' s
forall a. a -> NonEmpty a -> NonEmpty a
List1.cons s
s
      SRAction' x r t -> MaybeT (State (LRStack' s)) (SRAction' x r t)
forall a. a -> MaybeT (State (LRStack' s)) a
forall (m :: * -> *) a. Monad m => a -> m a
return SRAction' x r t
forall x r t. SRAction' x r t
Shift
    -- Reduce action:
    Right rule :: Rule' x r t
rule@(Rule NT' x
x (Alt r
_ (Form [Symbol' x t]
alpha))) -> do
      -- Pop |alpha| many states
      let n :: Int
n = [Symbol' x t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol' x t]
alpha
      let ([s]
ss1, [s]
rest) = Int -> LRStack' s -> ([s], [s])
forall a. Int -> NonEmpty a -> ([a], [a])
List1.splitAt Int
n LRStack' s
ss
      -- Rest should be non-empty, otherwise internal error.
      let err :: b
err = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"lr1Control: control stack too short to reduce"
      let ss2 :: LRStack' s
ss2 = LRStack' s -> Maybe (LRStack' s) -> LRStack' s
forall a. a -> Maybe a -> a
fromMaybe LRStack' s
forall {b}. b
err (Maybe (LRStack' s) -> LRStack' s)
-> Maybe (LRStack' s) -> LRStack' s
forall a b. (a -> b) -> a -> b
$ [s] -> Maybe (LRStack' s)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [s]
rest
      -- Execute the goto action (if present)
      s <- State (LRStack' s) (Maybe s) -> MaybeT (State (LRStack' s)) s
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (State (LRStack' s) (Maybe s) -> MaybeT (State (LRStack' s)) s)
-> State (LRStack' s) (Maybe s) -> MaybeT (State (LRStack' s)) s
forall a b. (a -> b) -> a -> b
$ Maybe s -> State (LRStack' s) (Maybe s)
forall a. a -> StateT (LRStack' s) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe s -> State (LRStack' s) (Maybe s))
-> Maybe s -> State (LRStack' s) (Maybe s)
forall a b. (a -> b) -> a -> b
$ s -> NT' x -> Maybe s
tabGoto (LRStack' s -> s
forall a. NonEmpty a -> a
List1.head LRStack' s
ss2) NT' x
x
      put (List1.cons s ss2)
      return $ Reduce rule

-- | Run the LR(1) parser with the given parsetable.

runLR1Parser :: (Eq t) => ParseTable' x r t s -> Input' t -> Trace' x r t
runLR1Parser :: forall t x r s.
Eq t =>
ParseTable' x r t s -> Input' t -> Trace' x r t
runLR1Parser pt :: ParseTable' x r t s
pt@(ParseTable s -> Maybe t -> Maybe (Either s (Rule' x r t))
_ s -> NT' x -> Maybe s
_ s
s0) Input' t
input =
  Control' x r t (StateT (LRStack' s) Identity)
-> Input' t -> StateT (LRStack' s) Identity (Trace' x r t)
forall t (m :: * -> *) x r.
(Eq t, Monad m) =>
Control' x r t m -> Input' t -> m (Trace' x r t)
runShiftReduceParser Control' x r t (StateT (LRStack' s) Identity)
control Input' t
input StateT (LRStack' s) Identity (Trace' x r t)
-> LRStack' s -> Trace' x r t
forall s a. State s a -> s -> a
`evalState` LRStack' s
st
  where
  control :: Control' x r t (StateT (LRStack' s) Identity)
control = ParseTable' x r t s
-> Control' x r t (StateT (LRStack' s) Identity)
forall x r t s.
ParseTable' x r t s -> Control' x r t (State (LRStack' s))
lr1Control ParseTable' x r t s
pt
  st :: LRStack' s
st = s
s0 s -> [s] -> LRStack' s
forall a. a -> [a] -> NonEmpty a
List1.:| []  -- List1.singleton only available from base-4.15 (GHC 9.0)

-- * LR(1) parsetable generation.

-- | A parse item is a dotted rule X → α.β.

data ParseItem' x r t = ParseItem
  { forall x r t. ParseItem' x r t -> Rule' x r t
_piRule   :: Rule' x r t    -- ^ The rule this item comes from.
  , forall x r t. ParseItem' x r t -> [Symbol' x t]
_piRest   :: [Symbol' x t]  -- ^ The rest after the ".".
  }
  deriving (ParseItem' x r t -> ParseItem' x r t -> Bool
(ParseItem' x r t -> ParseItem' x r t -> Bool)
-> (ParseItem' x r t -> ParseItem' x r t -> Bool)
-> Eq (ParseItem' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t.
(Eq r, Eq t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
$c== :: forall x r t.
(Eq r, Eq t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
== :: ParseItem' x r t -> ParseItem' x r t -> Bool
$c/= :: forall x r t.
(Eq r, Eq t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
/= :: ParseItem' x r t -> ParseItem' x r t -> Bool
Eq, Eq (ParseItem' x r t)
Eq (ParseItem' x r t) =>
(ParseItem' x r t -> ParseItem' x r t -> Ordering)
-> (ParseItem' x r t -> ParseItem' x r t -> Bool)
-> (ParseItem' x r t -> ParseItem' x r t -> Bool)
-> (ParseItem' x r t -> ParseItem' x r t -> Bool)
-> (ParseItem' x r t -> ParseItem' x r t -> Bool)
-> (ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t)
-> (ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t)
-> Ord (ParseItem' x r t)
ParseItem' x r t -> ParseItem' x r t -> Bool
ParseItem' x r t -> ParseItem' x r t -> Ordering
ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r 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 x r t. (Ord r, Ord t) => Eq (ParseItem' x r t)
forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Ordering
compare :: ParseItem' x r t -> ParseItem' x r t -> Ordering
$c< :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
< :: ParseItem' x r t -> ParseItem' x r t -> Bool
$c<= :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
<= :: ParseItem' x r t -> ParseItem' x r t -> Bool
$c> :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
> :: ParseItem' x r t -> ParseItem' x r t -> Bool
$c>= :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> Bool
>= :: ParseItem' x r t -> ParseItem' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t
max :: ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t
min :: ParseItem' x r t -> ParseItem' x r t -> ParseItem' x r t
Ord, Int -> ParseItem' x r t -> ShowS
[ParseItem' x r t] -> ShowS
ParseItem' x r t -> String
(Int -> ParseItem' x r t -> ShowS)
-> (ParseItem' x r t -> String)
-> ([ParseItem' x r t] -> ShowS)
-> Show (ParseItem' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> ParseItem' x r t -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
[ParseItem' x r t] -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
ParseItem' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> ParseItem' x r t -> ShowS
showsPrec :: Int -> ParseItem' x r t -> ShowS
$cshow :: forall x r t.
(Show x, Show r, Show t) =>
ParseItem' x r t -> String
show :: ParseItem' x r t -> String
$cshowList :: forall x r t.
(Show x, Show r, Show t) =>
[ParseItem' x r t] -> ShowS
showList :: [ParseItem' x r t] -> ShowS
Show)
makeLenses ''ParseItem'

type Lookahead t = SetMaybe t  -- ^ The set of lookahead symbols.

-- | A parse state is a map of parse items to lookahead lists.

newtype ParseState' x r t = ParseState { forall x r t.
ParseState' x r t -> Map (ParseItem' x r t) (Lookahead t)
theParseState :: Map (ParseItem' x r t) (Lookahead t) }
  deriving (ParseState' x r t -> ParseState' x r t -> Bool
(ParseState' x r t -> ParseState' x r t -> Bool)
-> (ParseState' x r t -> ParseState' x r t -> Bool)
-> Eq (ParseState' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t.
(Eq r, Eq t) =>
ParseState' x r t -> ParseState' x r t -> Bool
$c== :: forall x r t.
(Eq r, Eq t) =>
ParseState' x r t -> ParseState' x r t -> Bool
== :: ParseState' x r t -> ParseState' x r t -> Bool
$c/= :: forall x r t.
(Eq r, Eq t) =>
ParseState' x r t -> ParseState' x r t -> Bool
/= :: ParseState' x r t -> ParseState' x r t -> Bool
Eq, Eq (ParseState' x r t)
Eq (ParseState' x r t) =>
(ParseState' x r t -> ParseState' x r t -> Ordering)
-> (ParseState' x r t -> ParseState' x r t -> Bool)
-> (ParseState' x r t -> ParseState' x r t -> Bool)
-> (ParseState' x r t -> ParseState' x r t -> Bool)
-> (ParseState' x r t -> ParseState' x r t -> Bool)
-> (ParseState' x r t -> ParseState' x r t -> ParseState' x r t)
-> (ParseState' x r t -> ParseState' x r t -> ParseState' x r t)
-> Ord (ParseState' x r t)
ParseState' x r t -> ParseState' x r t -> Bool
ParseState' x r t -> ParseState' x r t -> Ordering
ParseState' x r t -> ParseState' x r t -> ParseState' x r 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 x r t. (Ord r, Ord t) => Eq (ParseState' x r t)
forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> ParseState' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Ordering
compare :: ParseState' x r t -> ParseState' x r t -> Ordering
$c< :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Bool
< :: ParseState' x r t -> ParseState' x r t -> Bool
$c<= :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Bool
<= :: ParseState' x r t -> ParseState' x r t -> Bool
$c> :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Bool
> :: ParseState' x r t -> ParseState' x r t -> Bool
$c>= :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> Bool
>= :: ParseState' x r t -> ParseState' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> ParseState' x r t
max :: ParseState' x r t -> ParseState' x r t -> ParseState' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
ParseState' x r t -> ParseState' x r t -> ParseState' x r t
min :: ParseState' x r t -> ParseState' x r t -> ParseState' x r t
Ord, Int -> ParseState' x r t -> ShowS
[ParseState' x r t] -> ShowS
ParseState' x r t -> String
(Int -> ParseState' x r t -> ShowS)
-> (ParseState' x r t -> String)
-> ([ParseState' x r t] -> ShowS)
-> Show (ParseState' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> ParseState' x r t -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
[ParseState' x r t] -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
ParseState' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> ParseState' x r t -> ShowS
showsPrec :: Int -> ParseState' x r t -> ShowS
$cshow :: forall x r t.
(Show x, Show r, Show t) =>
ParseState' x r t -> String
show :: ParseState' x r t -> String
$cshowList :: forall x r t.
(Show x, Show r, Show t) =>
[ParseState' x r t] -> ShowS
showList :: [ParseState' x r t] -> ShowS
Show)

instance (Ord r, Ord t) => Semigroup (ParseState' x r t) where
  ParseState Map (ParseItem' x r t) (Lookahead t)
is <> :: ParseState' x r t -> ParseState' x r t -> ParseState' x r t
<> ParseState Map (ParseItem' x r t) (Lookahead t)
is' = Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState (Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t)
-> Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ (Lookahead t -> Lookahead t -> Lookahead t)
-> Map (ParseItem' x r t) (Lookahead t)
-> Map (ParseItem' x r t) (Lookahead t)
-> Map (ParseItem' x r t) (Lookahead t)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Lookahead t -> Lookahead t -> Lookahead t
forall t. Ord t => SetMaybe t -> SetMaybe t -> SetMaybe t
SetMaybe.union Map (ParseItem' x r t) (Lookahead t)
is Map (ParseItem' x r t) (Lookahead t)
is'

instance (Ord r, Ord t) => Monoid (ParseState' x r t) where
  mempty :: ParseState' x r t
mempty = Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState (Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t)
-> Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ Map (ParseItem' x r t) (Lookahead t)
forall k a. Map k a
Map.empty
  mappend :: ParseState' x r t -> ParseState' x r t -> ParseState' x r t
mappend = ParseState' x r t -> ParseState' x r t -> ParseState' x r t
forall a. Semigroup a => a -> a -> a
(<>)

-- | Completing a parse state.
--
--   For each (X → α.Yβ, ts), add (Y → .γ, FIRST(β)∘ts)).
--   This might add a whole new item or just extend the token list.

complete :: (Ord r, Ord t)
  => EGrammar' x r t
  -> ParseState' x r t
  -> ParseState' x r t
complete :: forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t -> ParseState' x r t
complete = (ParseState' x r t -> Change (ParseState' x r t))
-> ParseState' x r t -> ParseState' x r t
forall a. (a -> Change a) -> a -> a
saturate ((ParseState' x r t -> Change (ParseState' x r t))
 -> ParseState' x r t -> ParseState' x r t)
-> (EGrammar' x r t
    -> ParseState' x r t -> Change (ParseState' x r t))
-> EGrammar' x r t
-> ParseState' x r t
-> ParseState' x r t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EGrammar' x r t -> ParseState' x r t -> Change (ParseState' x r t)
forall x r t.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t -> Change (ParseState' x r t)
completeStep

completeStep :: forall x r t. (Ord r, Ord t)
  => EGrammar' x r t
  -> ParseState' x r t
  -> Change (ParseState' x r t)
completeStep :: forall x r t.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t -> Change (ParseState' x r t)
completeStep (EGrammar (Grammar Int
_ Map x Int
_ IntMap (NTDef' x r t)
ntDefs) NT' x
_ FirstSets t
fs) (ParseState Map (ParseItem' x r t) (Lookahead t)
is) =
    ((ParseItem' x r t, Lookahead t)
 -> StateT (ParseState' x r t) Change ())
-> [(ParseItem' x r t, Lookahead t)]
-> StateT (ParseState' x r t) Change ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ParseItem' x r t, Lookahead t)
-> StateT (ParseState' x r t) Change ()
add
      [ (Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
forall x r t. Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
ParseItem (NT' x -> Alt' x r t -> Rule' x r t
forall x r t. NT' x -> Alt' x r t -> Rule' x r t
Rule NT' x
y Alt' x r t
alt) [Symbol' x t]
gamma, Lookahead t
la')
      | (ParseItem Rule' x r t
_ (NonTerm NT' x
y : [Symbol' x t]
beta), Lookahead t
la) <- Map (ParseItem' x r t) (Lookahead t)
-> [(ParseItem' x r t, Lookahead t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ParseItem' x r t) (Lookahead t)
is
      , NTDef x
_ [Alt' x r t]
alts                         <- Maybe (NTDef' x r t) -> [NTDef' x r t]
forall a. Maybe a -> [a]
maybeToList (Maybe (NTDef' x r t) -> [NTDef' x r t])
-> Maybe (NTDef' x r t) -> [NTDef' x r t]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (NTDef' x r t) -> Maybe (NTDef' x r t)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
y) IntMap (NTDef' x r t)
ntDefs
      , alt :: Alt' x r t
alt@(Alt r
_ (Form [Symbol' x t]
gamma))             <- [Alt' x r t]
alts
      , let la' :: Lookahead t
la' = First t -> Lookahead t
forall t. First t -> SetMaybe t
getFirst (First t -> Lookahead t) -> First t -> Lookahead t
forall a b. (a -> b) -> a -> b
$ First t -> First t -> First t
forall t. Ord t => First t -> First t -> First t
concatFirst (FirstSets t -> Form' x t -> First t
forall t r. Ord t => FirstSets t -> Form' r t -> First t
firstSet FirstSets t
fs (Form' x t -> First t) -> Form' x t -> First t
forall a b. (a -> b) -> a -> b
$ [Symbol' x t] -> Form' x t
forall x t. [Symbol' x t] -> Form' x t
Form [Symbol' x t]
beta) (First t -> First t) -> First t -> First t
forall a b. (a -> b) -> a -> b
$ Lookahead t -> First t
forall t. SetMaybe t -> First t
First Lookahead t
la
      ]
      StateT (ParseState' x r t) Change ()
-> ParseState' x r t -> WriterT Any Identity (ParseState' x r t)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState Map (ParseItem' x r t) (Lookahead t)
is
  where
    -- Add a parse item candidate.
    add :: (ParseItem' x r t, Lookahead t) -> StateT (ParseState' x r t) Change ()
    add :: (ParseItem' x r t, Lookahead t)
-> StateT (ParseState' x r t) Change ()
add (ParseItem' x r t
k, Lookahead t
new) = do
      ParseState st <- StateT (ParseState' x r t) Change (ParseState' x r t)
forall s (m :: * -> *). MonadState s m => m s
get
      let (mv, st') = Map.insertLookupWithKey (\ ParseItem' x r t
_ -> Lookahead t -> Lookahead t -> Lookahead t
forall t. Ord t => SetMaybe t -> SetMaybe t -> SetMaybe t
SetMaybe.union) k new st
      put $ ParseState st'
      -- Detect change:
      case mv of
        -- Item is new?
        Maybe (Lookahead t)
Nothing -> Change () -> StateT (ParseState' x r t) Change ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ParseState' x r t) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Change ()
dirty
        -- Item is old, maybe lookahead is new?
        Just Lookahead t
old -> Bool
-> StateT (ParseState' x r t) Change ()
-> StateT (ParseState' x r t) Change ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Lookahead t -> Lookahead t -> Bool
forall t. Ord t => SetMaybe t -> SetMaybe t -> Bool
SetMaybe.isSubsetOf Lookahead t
new Lookahead t
old) (StateT (ParseState' x r t) Change ()
 -> StateT (ParseState' x r t) Change ())
-> StateT (ParseState' x r t) Change ()
-> StateT (ParseState' x r t) Change ()
forall a b. (a -> b) -> a -> b
$ Change () -> StateT (ParseState' x r t) Change ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ParseState' x r t) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Change ()
dirty


-- | Goto action for a parse state.

successors :: (Ord r, Ord t) => EGrammar' x r t -> ParseState' x r t -> Map (Symbol' x t) (ParseState' x r t)
successors :: forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t
-> ParseState' x r t -> Map (Symbol' x t) (ParseState' x r t)
successors EGrammar' x r t
grm (ParseState Map (ParseItem' x r t) (Lookahead t)
is) = EGrammar' x r t -> ParseState' x r t -> ParseState' x r t
forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t -> ParseState' x r t
complete EGrammar' x r t
grm (ParseState' x r t -> ParseState' x r t)
-> Map (Symbol' x t) (ParseState' x r t)
-> Map (Symbol' x t) (ParseState' x r t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParseState' x r t -> ParseState' x r t -> ParseState' x r t)
-> [(Symbol' x t, ParseState' x r t)]
-> Map (Symbol' x t) (ParseState' x r t)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ParseState' x r t -> ParseState' x r t -> ParseState' x r t
forall a. Semigroup a => a -> a -> a
(<>)
  [ (Symbol' x t
sy, Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState (Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t)
-> Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ ParseItem' x r t
-> Lookahead t -> Map (ParseItem' x r t) (Lookahead t)
forall k a. k -> a -> Map k a
Map.singleton (Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
forall x r t. Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
ParseItem Rule' x r t
r [Symbol' x t]
alpha) Lookahead t
la)
  | (ParseItem Rule' x r t
r (Symbol' x t
sy : [Symbol' x t]
alpha), Lookahead t
la) <- Map (ParseItem' x r t) (Lookahead t)
-> [(ParseItem' x r t, Lookahead t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ParseItem' x r t) (Lookahead t)
is
  ]

-- * ParseState dictionary

type PState = Int

initPState :: Integer
initPState = Integer
0

-- | LALR: LR0 automaton decorated with lookahead.
--   The @LR0State@ is the @keysSet@ of a @ParseState@.

type LR0State' x r t = Set (ParseItem' x r t)

lr0state :: ParseState' x r t -> LR0State' x r t
lr0state :: forall x r t. ParseState' x r t -> LR0State' x r t
lr0state (ParseState Map (ParseItem' x r t) (Lookahead t)
is) = Map (ParseItem' x r t) (Lookahead t) -> Set (ParseItem' x r t)
forall k a. Map k a -> Set k
Map.keysSet Map (ParseItem' x r t) (Lookahead t)
is

-- | The dictionary maps LR0 states to state numbers and their best decoration.
type PSDict' x r t = Map (LR0State' x r t) (PState, ParseState' x r t)

-- | Internal parse table.

data IPT' x r t = IPT
  { forall x r t. IPT' x r t -> IntMap (ISRActions' x r t)
_iptSR   :: IntMap (ISRActions' x r t)  -- ^ Map from states to shift-reduce actions.
  , forall x r t. IPT' x r t -> IntMap IGotoActions
_iptGoto :: IntMap IGotoActions         -- ^ Map from states to goto actions.
  }
  deriving (Int -> IPT' x r t -> ShowS
[IPT' x r t] -> ShowS
IPT' x r t -> String
(Int -> IPT' x r t -> ShowS)
-> (IPT' x r t -> String)
-> ([IPT' x r t] -> ShowS)
-> Show (IPT' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> IPT' x r t -> ShowS
forall x r t. (Show x, Show r, Show t) => [IPT' x r t] -> ShowS
forall x r t. (Show x, Show r, Show t) => IPT' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> IPT' x r t -> ShowS
showsPrec :: Int -> IPT' x r t -> ShowS
$cshow :: forall x r t. (Show x, Show r, Show t) => IPT' x r t -> String
show :: IPT' x r t -> String
$cshowList :: forall x r t. (Show x, Show r, Show t) => [IPT' x r t] -> ShowS
showList :: [IPT' x r t] -> ShowS
Show)

-- | Goto actions of a state.
--   Mapping non-terminals to successor states.

type IGotoActions = IntMap PState

-- | Shift-reduce actions of a state.

data ISRActions' x r t = ISRActions
  { forall x r t. ISRActions' x r t -> ISRAction' x r t
_iactEof  :: ISRAction' x r t
  , forall x r t. ISRActions' x r t -> Map t (ISRAction' x r t)
_iactTerm :: Map t (ISRAction' x r t)
  }
  deriving (ISRActions' x r t -> ISRActions' x r t -> Bool
(ISRActions' x r t -> ISRActions' x r t -> Bool)
-> (ISRActions' x r t -> ISRActions' x r t -> Bool)
-> Eq (ISRActions' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t.
(Eq r, Eq t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
$c== :: forall x r t.
(Eq r, Eq t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
== :: ISRActions' x r t -> ISRActions' x r t -> Bool
$c/= :: forall x r t.
(Eq r, Eq t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
/= :: ISRActions' x r t -> ISRActions' x r t -> Bool
Eq, Eq (ISRActions' x r t)
Eq (ISRActions' x r t) =>
(ISRActions' x r t -> ISRActions' x r t -> Ordering)
-> (ISRActions' x r t -> ISRActions' x r t -> Bool)
-> (ISRActions' x r t -> ISRActions' x r t -> Bool)
-> (ISRActions' x r t -> ISRActions' x r t -> Bool)
-> (ISRActions' x r t -> ISRActions' x r t -> Bool)
-> (ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t)
-> (ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t)
-> Ord (ISRActions' x r t)
ISRActions' x r t -> ISRActions' x r t -> Bool
ISRActions' x r t -> ISRActions' x r t -> Ordering
ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r 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 x r t. (Ord r, Ord t) => Eq (ISRActions' x r t)
forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Ordering
compare :: ISRActions' x r t -> ISRActions' x r t -> Ordering
$c< :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
< :: ISRActions' x r t -> ISRActions' x r t -> Bool
$c<= :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
<= :: ISRActions' x r t -> ISRActions' x r t -> Bool
$c> :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
> :: ISRActions' x r t -> ISRActions' x r t -> Bool
$c>= :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> Bool
>= :: ISRActions' x r t -> ISRActions' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
max :: ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
min :: ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
Ord, Int -> ISRActions' x r t -> ShowS
[ISRActions' x r t] -> ShowS
ISRActions' x r t -> String
(Int -> ISRActions' x r t -> ShowS)
-> (ISRActions' x r t -> String)
-> ([ISRActions' x r t] -> ShowS)
-> Show (ISRActions' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> ISRActions' x r t -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
[ISRActions' x r t] -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
ISRActions' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> ISRActions' x r t -> ShowS
showsPrec :: Int -> ISRActions' x r t -> ShowS
$cshow :: forall x r t.
(Show x, Show r, Show t) =>
ISRActions' x r t -> String
show :: ISRActions' x r t -> String
$cshowList :: forall x r t.
(Show x, Show r, Show t) =>
[ISRActions' x r t] -> ShowS
showList :: [ISRActions' x r t] -> ShowS
Show)

instance (Ord r, Ord t) => Semigroup (ISRActions' x r t) where
  ISRActions ISRAction' x r t
aeof Map t (ISRAction' x r t)
atok <> :: ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
<> ISRActions ISRAction' x r t
aeof' Map t (ISRAction' x r t)
atok' =
    ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
forall x r t.
ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
ISRActions (ISRAction' x r t
aeof ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
forall a. Semigroup a => a -> a -> a
<> ISRAction' x r t
aeof') ((ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t)
-> Map t (ISRAction' x r t)
-> Map t (ISRAction' x r t)
-> Map t (ISRAction' x r t)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
forall a. Semigroup a => a -> a -> a
(<>) Map t (ISRAction' x r t)
atok Map t (ISRAction' x r t)
atok')

instance (Ord r, Ord t) => Monoid (ISRActions' x r t) where
  mempty :: ISRActions' x r t
mempty = ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
forall x r t.
ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
ISRActions ISRAction' x r t
forall a. Monoid a => a
mempty Map t (ISRAction' x r t)
forall k a. Map k a
Map.empty
  mappend :: ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
mappend = ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
forall a. Semigroup a => a -> a -> a
(<>)

shiftActions :: (Ord r, Ord t) => Map t (ISRAction' x r t) -> ISRActions' x r t
shiftActions :: forall r t x.
(Ord r, Ord t) =>
Map t (ISRAction' x r t) -> ISRActions' x r t
shiftActions = ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
forall x r t.
ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
ISRActions ISRAction' x r t
forall a. Monoid a => a
mempty

-- | Entry of a parse table cell: shift and/or reduce action(s).

data ISRAction' x r t = ISRAction
  { forall x r t. ISRAction' x r t -> Maybe Int
_iactShift  :: Maybe PState     -- ^ Possibly a shift action.
  , forall x r t. ISRAction' x r t -> Set (Rule' x r t)
_iactReduce :: Set (Rule' x r t)  -- ^ Possibly several reduce actions.
  }
  deriving (ISRAction' x r t -> ISRAction' x r t -> Bool
(ISRAction' x r t -> ISRAction' x r t -> Bool)
-> (ISRAction' x r t -> ISRAction' x r t -> Bool)
-> Eq (ISRAction' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t.
(Eq r, Eq t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
$c== :: forall x r t.
(Eq r, Eq t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
== :: ISRAction' x r t -> ISRAction' x r t -> Bool
$c/= :: forall x r t.
(Eq r, Eq t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
/= :: ISRAction' x r t -> ISRAction' x r t -> Bool
Eq, Eq (ISRAction' x r t)
Eq (ISRAction' x r t) =>
(ISRAction' x r t -> ISRAction' x r t -> Ordering)
-> (ISRAction' x r t -> ISRAction' x r t -> Bool)
-> (ISRAction' x r t -> ISRAction' x r t -> Bool)
-> (ISRAction' x r t -> ISRAction' x r t -> Bool)
-> (ISRAction' x r t -> ISRAction' x r t -> Bool)
-> (ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t)
-> (ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t)
-> Ord (ISRAction' x r t)
ISRAction' x r t -> ISRAction' x r t -> Bool
ISRAction' x r t -> ISRAction' x r t -> Ordering
ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r 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 x r t. (Ord r, Ord t) => Eq (ISRAction' x r t)
forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Ordering
compare :: ISRAction' x r t -> ISRAction' x r t -> Ordering
$c< :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
< :: ISRAction' x r t -> ISRAction' x r t -> Bool
$c<= :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
<= :: ISRAction' x r t -> ISRAction' x r t -> Bool
$c> :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
> :: ISRAction' x r t -> ISRAction' x r t -> Bool
$c>= :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> Bool
>= :: ISRAction' x r t -> ISRAction' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
max :: ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
min :: ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
Ord, Int -> ISRAction' x r t -> ShowS
[ISRAction' x r t] -> ShowS
ISRAction' x r t -> String
(Int -> ISRAction' x r t -> ShowS)
-> (ISRAction' x r t -> String)
-> ([ISRAction' x r t] -> ShowS)
-> Show (ISRAction' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show x, Show r, Show t) =>
Int -> ISRAction' x r t -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
[ISRAction' x r t] -> ShowS
forall x r t.
(Show x, Show r, Show t) =>
ISRAction' x r t -> String
$cshowsPrec :: forall x r t.
(Show x, Show r, Show t) =>
Int -> ISRAction' x r t -> ShowS
showsPrec :: Int -> ISRAction' x r t -> ShowS
$cshow :: forall x r t.
(Show x, Show r, Show t) =>
ISRAction' x r t -> String
show :: ISRAction' x r t -> String
$cshowList :: forall x r t.
(Show x, Show r, Show t) =>
[ISRAction' x r t] -> ShowS
showList :: [ISRAction' x r t] -> ShowS
Show)

instance (Ord r, Ord t) => Semigroup (ISRAction' x r t) where
  -- ISRAction Just{} _ <> ISRAction Just{} _ = error $ "impossible: union of shift actions"
  ISRAction Maybe Int
ms1   Set (Rule' x r t)
r1 <> :: ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
<> ISRAction Maybe Int
ms2   Set (Rule' x r t)
r2 = Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
forall x r t. Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
ISRAction Maybe Int
ms Set (Rule' x r t)
r
    where
    ms :: Maybe Int
ms = [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList Maybe Int
ms1 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList Maybe Int
ms2
    r :: Set (Rule' x r t)
r  = Set (Rule' x r t) -> Set (Rule' x r t) -> Set (Rule' x r t)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Rule' x r t)
r1 Set (Rule' x r t)
r2

instance (Ord r, Ord t) => Monoid (ISRAction' x r t) where
  mempty :: ISRAction' x r t
mempty = ISRAction' x r t
forall x r t. ISRAction' x r t
emptyAction
  mappend :: ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
mappend = ISRAction' x r t -> ISRAction' x r t -> ISRAction' x r t
forall a. Semigroup a => a -> a -> a
(<>)

emptyAction :: ISRAction' x r t
emptyAction :: forall x r t. ISRAction' x r t
emptyAction = Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
forall x r t. Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
ISRAction Maybe Int
forall a. Maybe a
Nothing Set (Rule' x r t)
forall a. Set a
Set.empty

shiftAction :: PState -> ISRAction' x r t
shiftAction :: forall x r t. Int -> ISRAction' x r t
shiftAction Int
s = Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
forall x r t. Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
ISRAction (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
s) Set (Rule' x r t)
forall a. Set a
Set.empty

reduceAction :: Rule' x r t -> ISRAction' x r t
reduceAction :: forall x r t. Rule' x r t -> ISRAction' x r t
reduceAction Rule' x r t
rule = Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
forall x r t. Maybe Int -> Set (Rule' x r t) -> ISRAction' x r t
ISRAction Maybe Int
forall a. Maybe a
Nothing (Set (Rule' x r t) -> ISRAction' x r t)
-> Set (Rule' x r t) -> ISRAction' x r t
forall a b. (a -> b) -> a -> b
$ Rule' x r t -> Set (Rule' x r t)
forall a. a -> Set a
Set.singleton Rule' x r t
rule

-- | Compute the reduce actions for a parse state.

reductions :: (Ord r, Ord t) => ParseState' x r t -> ISRActions' x r t
reductions :: forall r t x.
(Ord r, Ord t) =>
ParseState' x r t -> ISRActions' x r t
reductions (ParseState Map (ParseItem' x r t) (Lookahead t)
is) = [ISRActions' x r t] -> ISRActions' x r t
forall a. Monoid a => [a] -> a
mconcat
    [ ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
forall x r t.
ISRAction' x r t -> Map t (ISRAction' x r t) -> ISRActions' x r t
ISRActions (if Bool
eof then ISRAction' x r t
ra else ISRAction' x r t
forall x r t. ISRAction' x r t
emptyAction) ((t -> ISRAction' x r t) -> Set t -> Map t (ISRAction' x r t)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (ISRAction' x r t -> t -> ISRAction' x r t
forall a b. a -> b -> a
const ISRAction' x r t
ra) Set t
ts)
    | (ParseItem Rule' x r t
r [], SetMaybe Set t
ts Bool
eof) <- Map (ParseItem' x r t) (Lookahead t)
-> [(ParseItem' x r t, Lookahead t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ParseItem' x r t) (Lookahead t)
is
    , let ra :: ISRAction' x r t
ra = Rule' x r t -> ISRAction' x r t
forall x r t. Rule' x r t -> ISRAction' x r t
reduceAction Rule' x r t
r
    ]

-- | Parse table generator state

data PTGenState' x r t = PTGenState
  { forall x r t. PTGenState' x r t -> Int
_stNext   :: Int              -- ^ Next unused state number.
  , forall x r t. PTGenState' x r t -> PSDict' x r t
_stPSDict :: PSDict' x r t    -- ^ Translation from states to state numbers.
  , forall x r t. PTGenState' x r t -> IPT' x r t
_stIPT    :: IPT' x r t       -- ^ Internal parse table.
  }
makeLenses ''ISRAction'
makeLenses ''ISRActions'
makeLenses ''IPT'
makeLenses ''PTGenState'

ptState0 :: (Ord r, Ord t) => EGrammar' x r t -> ParseState' x r t
ptState0 :: forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t
ptState0 grm :: EGrammar' x r t
grm@(EGrammar (Grammar Int
_ Map x Int
_ IntMap (NTDef' x r t)
ntDefs) NT' x
start FirstSets t
_fs) =
  -- complete grm $
    Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState (Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t)
-> Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ [(ParseItem' x r t, Lookahead t)]
-> Map (ParseItem' x r t) (Lookahead t)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParseItem' x r t, Lookahead t)]
forall {t}. [(ParseItem' x r t, SetMaybe t)]
items0
  where
    laEOF :: SetMaybe t
laEOF  = Maybe t -> SetMaybe t
forall t. Maybe t -> SetMaybe t
SetMaybe.singleton Maybe t
forall a. Maybe a
Nothing
    alts0 :: [Alt' x r t]
alts0  = [Alt' x r t]
-> (NTDef' x r t -> [Alt' x r t])
-> Maybe (NTDef' x r t)
-> [Alt' x r t]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Getting [Alt' x r t] (NTDef' x r t) [Alt' x r t]
-> NTDef' x r t -> [Alt' x r t]
forall a s. Getting a s a -> s -> a
view Getting [Alt' x r t] (NTDef' x r t) [Alt' x r t]
forall x r1 t1 r2 t2 (f :: * -> *).
Functor f =>
([Alt' x r1 t1] -> f [Alt' x r2 t2])
-> NTDef' x r1 t1 -> f (NTDef' x r2 t2)
ntDef) (Maybe (NTDef' x r t) -> [Alt' x r t])
-> Maybe (NTDef' x r t) -> [Alt' x r t]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (NTDef' x r t) -> Maybe (NTDef' x r t)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
start) IntMap (NTDef' x r t)
ntDefs
    items0 :: [(ParseItem' x r t, SetMaybe t)]
items0 = ((Alt' x r t -> (ParseItem' x r t, SetMaybe t))
 -> [Alt' x r t] -> [(ParseItem' x r t, SetMaybe t)])
-> [Alt' x r t]
-> (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [(ParseItem' x r t, SetMaybe t)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [Alt' x r t] -> [(ParseItem' x r t, SetMaybe t)]
forall a b. (a -> b) -> [a] -> [b]
map [Alt' x r t]
alts0 ((Alt' x r t -> (ParseItem' x r t, SetMaybe t))
 -> [(ParseItem' x r t, SetMaybe t)])
-> (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [(ParseItem' x r t, SetMaybe t)]
forall a b. (a -> b) -> a -> b
$ \ alt :: Alt' x r t
alt@(Alt r
r (Form [Symbol' x t]
alpha)) ->
      (Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
forall x r t. Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
ParseItem (NT' x -> Alt' x r t -> Rule' x r t
forall x r t. NT' x -> Alt' x r t -> Rule' x r t
Rule NT' x
start Alt' x r t
alt) [Symbol' x t]
alpha, SetMaybe t
forall {t}. SetMaybe t
laEOF)

ptGen :: forall x r t. (Ord r, Ord t) => EGrammar' x r t -> IPT' x r t
ptGen :: forall x r t. (Ord r, Ord t) => EGrammar' x r t -> IPT' x r t
ptGen grm :: EGrammar' x r t
grm@(EGrammar (Grammar Int
_ Map x Int
_ IntMap (NTDef' x r t)
ntDefs) NT' x
start FirstSets t
fs) =
  Getting (IPT' x r t) (PTGenState' x r t) (IPT' x r t)
-> PTGenState' x r t -> IPT' x r t
forall a s. Getting a s a -> s -> a
view Getting (IPT' x r t) (PTGenState' x r t) (IPT' x r t)
forall x r t (f :: * -> *).
Functor f =>
(IPT' x r t -> f (IPT' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
stIPT (PTGenState' x r t -> IPT' x r t)
-> PTGenState' x r t -> IPT' x r t
forall a b. (a -> b) -> a -> b
$ [ParseState' x r t] -> State (PTGenState' x r t) ()
loop [ParseState' x r t
state0] State (PTGenState' x r t) ()
-> PTGenState' x r t -> PTGenState' x r t
forall s a. State s a -> s -> s
`execState` PTGenState' x r t
stInit
  where
  stInit :: PTGenState' x r t
  stInit :: PTGenState' x r t
stInit = Int -> PSDict' x r t -> IPT' x r t -> PTGenState' x r t
forall x r t.
Int -> PSDict' x r t -> IPT' x r t -> PTGenState' x r t
PTGenState Int
1 (LR0State' x r t -> (Int, ParseState' x r t) -> PSDict' x r t
forall k a. k -> a -> Map k a
Map.singleton (ParseState' x r t -> LR0State' x r t
forall x r t. ParseState' x r t -> LR0State' x r t
lr0state ParseState' x r t
state0) (Int
0, ParseState' x r t
state0)) (IPT' x r t -> PTGenState' x r t)
-> IPT' x r t -> PTGenState' x r t
forall a b. (a -> b) -> a -> b
$
             IntMap (ISRActions' x r t) -> IntMap IGotoActions -> IPT' x r t
forall x r t.
IntMap (ISRActions' x r t) -> IntMap IGotoActions -> IPT' x r t
IPT IntMap (ISRActions' x r t)
forall a. IntMap a
IntMap.empty IntMap IGotoActions
forall a. IntMap a
IntMap.empty
             -- IPT (IntMap.singleton 0 $ reductions state0)
             --     (IntMap.singleton 0 $ IntMap.empty)  -- initially no goto actions

  -- The first state contains the productions for the start non-terminal.
  state0 :: ParseState' x r t
  state0 :: ParseState' x r t
state0 = EGrammar' x r t -> ParseState' x r t -> ParseState' x r t
forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseState' x r t -> ParseState' x r t
complete EGrammar' x r t
grm (ParseState' x r t -> ParseState' x r t)
-> ParseState' x r t -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall x r t.
Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
ParseState (Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t)
-> Map (ParseItem' x r t) (Lookahead t) -> ParseState' x r t
forall a b. (a -> b) -> a -> b
$ [(ParseItem' x r t, Lookahead t)]
-> Map (ParseItem' x r t) (Lookahead t)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParseItem' x r t, Lookahead t)]
forall {t}. [(ParseItem' x r t, SetMaybe t)]
items0
    where
    laEOF :: SetMaybe t
laEOF  = Maybe t -> SetMaybe t
forall t. Maybe t -> SetMaybe t
SetMaybe.singleton Maybe t
forall a. Maybe a
Nothing
    alts0 :: [Alt' x r t]
alts0  = [Alt' x r t]
-> (NTDef' x r t -> [Alt' x r t])
-> Maybe (NTDef' x r t)
-> [Alt' x r t]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Getting [Alt' x r t] (NTDef' x r t) [Alt' x r t]
-> NTDef' x r t -> [Alt' x r t]
forall a s. Getting a s a -> s -> a
view Getting [Alt' x r t] (NTDef' x r t) [Alt' x r t]
forall x r1 t1 r2 t2 (f :: * -> *).
Functor f =>
([Alt' x r1 t1] -> f [Alt' x r2 t2])
-> NTDef' x r1 t1 -> f (NTDef' x r2 t2)
ntDef) (Maybe (NTDef' x r t) -> [Alt' x r t])
-> Maybe (NTDef' x r t) -> [Alt' x r t]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (NTDef' x r t) -> Maybe (NTDef' x r t)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
start) IntMap (NTDef' x r t)
ntDefs
    items0 :: [(ParseItem' x r t, SetMaybe t)]
items0 = ((Alt' x r t -> (ParseItem' x r t, SetMaybe t))
 -> [Alt' x r t] -> [(ParseItem' x r t, SetMaybe t)])
-> [Alt' x r t]
-> (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [(ParseItem' x r t, SetMaybe t)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [Alt' x r t] -> [(ParseItem' x r t, SetMaybe t)]
forall a b. (a -> b) -> [a] -> [b]
map [Alt' x r t]
alts0 ((Alt' x r t -> (ParseItem' x r t, SetMaybe t))
 -> [(ParseItem' x r t, SetMaybe t)])
-> (Alt' x r t -> (ParseItem' x r t, SetMaybe t))
-> [(ParseItem' x r t, SetMaybe t)]
forall a b. (a -> b) -> a -> b
$ \ alt :: Alt' x r t
alt@(Alt r
r (Form [Symbol' x t]
alpha)) ->
      (Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
forall x r t. Rule' x r t -> [Symbol' x t] -> ParseItem' x r t
ParseItem (NT' x -> Alt' x r t -> Rule' x r t
forall x r t. NT' x -> Alt' x r t -> Rule' x r t
Rule NT' x
start Alt' x r t
alt) [Symbol' x t]
alpha, SetMaybe t
forall {t}. SetMaybe t
laEOF)

  -- Work off worklist of registered by not processed parse states.
  loop :: [ParseState' x r t] -> State (PTGenState' x r t) ()
  loop :: [ParseState' x r t] -> State (PTGenState' x r t) ()
loop [] = () -> State (PTGenState' x r t) ()
forall a. a -> StateT (PTGenState' x r t) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  loop (ParseState' x r t
is : [ParseState' x r t]
worklist) = do
    let k :: LR0State' x r t
k = ParseState' x r t -> LR0State' x r t
forall x r t. ParseState' x r t -> LR0State' x r t
lr0state ParseState' x r t
is  -- the LR0State of is
    (LR0State' x r t -> PSDict' x r t -> Maybe (Int, ParseState' x r t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup LR0State' x r t
k (PSDict' x r t -> Maybe (Int, ParseState' x r t))
-> StateT (PTGenState' x r t) Identity (PSDict' x r t)
-> StateT
     (PTGenState' x r t) Identity (Maybe (Int, ParseState' x r t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
-> StateT (PTGenState' x r t) Identity (PSDict' x r t)
forall s (m :: * -> *) a. MonadState s m => Lens s s a a -> m a
use (PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
forall x r t (f :: * -> *).
Functor f =>
(PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
stPSDict) StateT
  (PTGenState' x r t) Identity (Maybe (Int, ParseState' x r t))
-> (Maybe (Int, ParseState' x r t) -> State (PTGenState' x r t) ())
-> State (PTGenState' x r t) ()
forall a b.
StateT (PTGenState' x r t) Identity a
-> (a -> StateT (PTGenState' x r t) Identity b)
-> StateT (PTGenState' x r t) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Int, ParseState' x r t)
Nothing -> String -> State (PTGenState' x r t) ()
forall a. HasCallStack => String -> a
error String
"impossible: parse state without number"
      Just (Int
snew, ParseState' x r t
is0)  -> do
        -- Lookaheads are already updated by convert.
        -- -- Update the lookaheads
        -- is <- do
        --   let is2 = is <> is0
        --   if is2 == is0 then return is0 else do
        --     modifying stPSDict $ Map.insert k (snew, is2)
        --     return is2
        -- Compute successors of snew.
        let sucs :: [(Symbol' x t, ParseState' x r t)]
sucs = Map (Symbol' x t) (ParseState' x r t)
-> [(Symbol' x t, ParseState' x r t)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Symbol' x t) (ParseState' x r t)
 -> [(Symbol' x t, ParseState' x r t)])
-> Map (Symbol' x t) (ParseState' x r t)
-> [(Symbol' x t, ParseState' x r t)]
forall a b. (a -> b) -> a -> b
$ EGrammar' x r t
-> ParseState' x r t -> Map (Symbol' x t) (ParseState' x r t)
forall r t x.
(Ord r, Ord t) =>
EGrammar' x r t
-> ParseState' x r t -> Map (Symbol' x t) (ParseState' x r t)
successors EGrammar' x r t
grm ParseState' x r t
is
        -- Register the successors (if not known yet).
        (news, sucs') <- [(Maybe (ParseState' x r t), (Symbol' x t, Int))]
-> ([Maybe (ParseState' x r t)], [(Symbol' x t, Int)])
forall a b. [(a, b)] -> ([a], [b])
List.unzip ([(Maybe (ParseState' x r t), (Symbol' x t, Int))]
 -> ([Maybe (ParseState' x r t)], [(Symbol' x t, Int)]))
-> StateT
     (PTGenState' x r t)
     Identity
     [(Maybe (ParseState' x r t), (Symbol' x t, Int))]
-> StateT
     (PTGenState' x r t)
     Identity
     ([Maybe (ParseState' x r t)], [(Symbol' x t, Int)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Symbol' x t, ParseState' x r t)
 -> StateT
      (PTGenState' x r t)
      Identity
      (Maybe (ParseState' x r t), (Symbol' x t, Int)))
-> [(Symbol' x t, ParseState' x r t)]
-> StateT
     (PTGenState' x r t)
     Identity
     [(Maybe (ParseState' x r t), (Symbol' x t, Int))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Symbol' x t, ParseState' x r t)
-> StateT
     (PTGenState' x r t)
     Identity
     (Maybe (ParseState' x r t), (Symbol' x t, Int))
forall a.
(a, ParseState' x r t)
-> State (PTGenState' x r t) (Maybe (ParseState' x r t), (a, Int))
convert [(Symbol' x t, ParseState' x r t)]
sucs
        -- Compute goto actions for state snew.
        let fromSymbol (Term    a
t, b
a) = (a, b) -> Either (a, b) (Int, b)
forall a b. a -> Either a b
Left  (a
t, b
a)
            fromSymbol (NonTerm NT' x
x, b
a) = (Int, b) -> Either (a, b) (Int, b)
forall a b. b -> Either a b
Right (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
x, b
a)
        let (shifts0, gotos0) = partitionEithers $ map fromSymbol sucs'
        -- Equip the state snew with its goto actions.
        unless (null gotos0) $ do
          let gotos   = [(Int, Int)] -> IGotoActions
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, Int)]
gotos0
          modifying (stIPT . iptGoto) $ IntMap.insertWith IntMap.union snew gotos
        -- Compute shift and reduce actions of snew.
        let shifts  = [(t, ISRAction' x r t)] -> Map t (ISRAction' x r t)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(t, ISRAction' x r t)] -> Map t (ISRAction' x r t))
-> [(t, ISRAction' x r t)] -> Map t (ISRAction' x r t)
forall a b. (a -> b) -> a -> b
$ ((t, Int) -> (t, ISRAction' x r t))
-> [(t, Int)] -> [(t, ISRAction' x r t)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (t
t,Int
s) -> (t
t, Int -> ISRAction' x r t
forall x r t. Int -> ISRAction' x r t
shiftAction Int
s)) [(t, Int)]
shifts0
        let reduces = ParseState' x r t -> ISRActions' x r t
forall r t x.
(Ord r, Ord t) =>
ParseState' x r t -> ISRActions' x r t
reductions ParseState' x r t
is
        let actions = (Map t (ISRAction' x r t) -> ISRActions' x r t
forall r t x.
(Ord r, Ord t) =>
Map t (ISRAction' x r t) -> ISRActions' x r t
shiftActions Map t (ISRAction' x r t)
forall {x} {r} {t}. Map t (ISRAction' x r t)
shifts ISRActions' x r t -> ISRActions' x r t -> ISRActions' x r t
forall a. Semigroup a => a -> a -> a
<> ISRActions' x r t
reduces)
        unless (actions == mempty) $ do
        -- Equip the state snew with its shift/reduce actions.
          modifying (stIPT . iptSR) $ IntMap.insertWith (<>) snew actions
        -- Add the new states to the worklist and continue
        loop $ catMaybes news ++ worklist

  -- Register a parse state and decide whether we have to process it.
  convert :: (a, ParseState' x r t) -> State (PTGenState' x r t) (Maybe (ParseState' x r t), (a, PState))
  convert :: forall a.
(a, ParseState' x r t)
-> State (PTGenState' x r t) (Maybe (ParseState' x r t), (a, Int))
convert (a
a, ParseState' x r t
is) = do
    let k :: LR0State' x r t
k = ParseState' x r t -> LR0State' x r t
forall x r t. ParseState' x r t -> LR0State' x r t
lr0state ParseState' x r t
is
    snew <- Lens (PTGenState' x r t) (PTGenState' x r t) Int Int
-> StateT (PTGenState' x r t) Identity Int
forall s (m :: * -> *) a. MonadState s m => Lens s s a a -> m a
use (Int -> f Int) -> PTGenState' x r t -> f (PTGenState' x r t)
forall x r t (f :: * -> *).
Functor f =>
(Int -> f Int) -> PTGenState' x r t -> f (PTGenState' x r t)
Lens (PTGenState' x r t) (PTGenState' x r t) Int Int
stNext
    (Map.lookup k <$> use stPSDict) >>= \case
      -- Parse state has already been visited.  However, lookahead info might need update.
      Just (Int
s, ParseState' x r t
is0) -> do
        -- Combine old an new lookahead info.
        let is' :: ParseState' x r t
is' = ParseState' x r t
is ParseState' x r t -> ParseState' x r t -> ParseState' x r t
forall a. Semigroup a => a -> a -> a
<> ParseState' x r t
is0
        if ParseState' x r t
is' ParseState' x r t -> ParseState' x r t -> Bool
forall a. Eq a => a -> a -> Bool
== ParseState' x r t
is0 then (Maybe (ParseState' x r t), (a, Int))
-> StateT
     (PTGenState' x r t) Identity (Maybe (ParseState' x r t), (a, Int))
forall a. a -> StateT (PTGenState' x r t) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ParseState' x r t)
forall a. Maybe a
Nothing, (a
a, Int
s)) else do
          -- If something changed, update the lookahead info.
          -- Also, we will need to process this state again.
          Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
-> (PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ()
forall s (m :: * -> *) a.
MonadState s m =>
Lens s s a a -> (a -> a) -> m ()
modifying (PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
forall x r t (f :: * -> *).
Functor f =>
(PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
stPSDict ((PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ())
-> (PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ()
forall a b. (a -> b) -> a -> b
$ LR0State' x r t
-> (Int, ParseState' x r t) -> PSDict' x r t -> PSDict' x r t
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LR0State' x r t
k (Int
s, ParseState' x r t
is')
          (Maybe (ParseState' x r t), (a, Int))
-> StateT
     (PTGenState' x r t) Identity (Maybe (ParseState' x r t), (a, Int))
forall a. a -> StateT (PTGenState' x r t) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseState' x r t -> Maybe (ParseState' x r t)
forall a. a -> Maybe a
Just ParseState' x r t
is', (a
a, Int
s))
      -- New parse state.
      Maybe (Int, ParseState' x r t)
Nothing -> do
        -- Increase parse state counter.
        Lens (PTGenState' x r t) (PTGenState' x r t) Int Int
-> (Int -> Int) -> State (PTGenState' x r t) ()
forall s (m :: * -> *) a.
MonadState s m =>
Lens s s a a -> (a -> a) -> m ()
modifying (Int -> f Int) -> PTGenState' x r t -> f (PTGenState' x r t)
forall x r t (f :: * -> *).
Functor f =>
(Int -> f Int) -> PTGenState' x r t -> f (PTGenState' x r t)
Lens (PTGenState' x r t) (PTGenState' x r t) Int Int
stNext Int -> Int
forall a. Enum a => a -> a
succ
        -- Save updated dictionary.
        Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
-> (PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ()
forall s (m :: * -> *) a.
MonadState s m =>
Lens s s a a -> (a -> a) -> m ()
modifying (PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
forall x r t (f :: * -> *).
Functor f =>
(PSDict' x r t -> f (PSDict' x r t))
-> PTGenState' x r t -> f (PTGenState' x r t)
Lens
  (PTGenState' x r t)
  (PTGenState' x r t)
  (PSDict' x r t)
  (PSDict' x r t)
stPSDict ((PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ())
-> (PSDict' x r t -> PSDict' x r t) -> State (PTGenState' x r t) ()
forall a b. (a -> b) -> a -> b
$ LR0State' x r t
-> (Int, ParseState' x r t) -> PSDict' x r t -> PSDict' x r t
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LR0State' x r t
k (Int
snew, ParseState' x r t
is) -- (const dict')
        (Maybe (ParseState' x r t), (a, Int))
-> StateT
     (PTGenState' x r t) Identity (Maybe (ParseState' x r t), (a, Int))
forall a. a -> StateT (PTGenState' x r t) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseState' x r t -> Maybe (ParseState' x r t)
forall a. a -> Maybe a
Just ParseState' x r t
is, (a
a, Int
snew))

-- | Shift over reduce.
--   First reduce action out of several ones.

chooseAction :: ISRAction' x r t -> Maybe (Either PState (Rule' x r t))
chooseAction :: forall x r t. ISRAction' x r t -> Maybe (Either Int (Rule' x r t))
chooseAction (ISRAction (Just Int
s) Set (Rule' x r t)
rs) = Either Int (Rule' x r t) -> Maybe (Either Int (Rule' x r t))
forall a. a -> Maybe a
Just (Int -> Either Int (Rule' x r t)
forall a b. a -> Either a b
Left Int
s)
chooseAction (ISRAction Maybe Int
Nothing  Set (Rule' x r t)
rs) = Rule' x r t -> Either Int (Rule' x r t)
forall a b. b -> Either a b
Right (Rule' x r t -> Either Int (Rule' x r t))
-> Maybe (Rule' x r t) -> Maybe (Either Int (Rule' x r t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Rule' x r t) -> Maybe (Rule' x r t)
forall a. Set a -> Maybe a
Set.lookupMin Set (Rule' x r t)
rs

-- | Construct the extensional parse table.
constructParseTable' :: forall x r t. (Ord r, Ord t) => IPT' x r t -> ParseTable' x r t PState
constructParseTable' :: forall x r t. (Ord r, Ord t) => IPT' x r t -> ParseTable' x r t Int
constructParseTable' (IPT IntMap (ISRActions' x r t)
sr IntMap IGotoActions
goto) = (Int -> Maybe t -> Maybe (Either Int (Rule' x r t)))
-> (Int -> NT' x -> Maybe Int) -> Int -> ParseTable' x r t Int
forall x r t s.
(s -> Maybe t -> Maybe (Either s (Rule' x r t)))
-> (s -> NT' x -> Maybe s) -> s -> ParseTable' x r t s
ParseTable Int -> Maybe t -> Maybe (Either Int (Rule' x r t))
tabSR Int -> NT' x -> Maybe Int
forall {x}. Int -> NT' x -> Maybe Int
tabGoto Int
tabInit
  where
  tabSR :: Int -> Maybe t -> Maybe (Either Int (Rule' x r t))
tabSR Int
s Maybe t
Nothing  = ISRAction' x r t -> Maybe (Either Int (Rule' x r t))
forall x r t. ISRAction' x r t -> Maybe (Either Int (Rule' x r t))
chooseAction (ISRAction' x r t -> Maybe (Either Int (Rule' x r t)))
-> Maybe (ISRAction' x r t) -> Maybe (Either Int (Rule' x r t))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do Getting (ISRAction' x r t) (ISRActions' x r t) (ISRAction' x r t)
-> ISRActions' x r t -> ISRAction' x r t
forall a s. Getting a s a -> s -> a
view Getting (ISRAction' x r t) (ISRActions' x r t) (ISRAction' x r t)
forall x r t (f :: * -> *).
Functor f =>
(ISRAction' x r t -> f (ISRAction' x r t))
-> ISRActions' x r t -> f (ISRActions' x r t)
iactEof (ISRActions' x r t -> ISRAction' x r t)
-> Maybe (ISRActions' x r t) -> Maybe (ISRAction' x r t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap (ISRActions' x r t) -> Maybe (ISRActions' x r t)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
s IntMap (ISRActions' x r t)
sr
  tabSR Int
s (Just t
t) = ISRAction' x r t -> Maybe (Either Int (Rule' x r t))
forall x r t. ISRAction' x r t -> Maybe (Either Int (Rule' x r t))
chooseAction (ISRAction' x r t -> Maybe (Either Int (Rule' x r t)))
-> Maybe (ISRAction' x r t) -> Maybe (Either Int (Rule' x r t))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> Map t (ISRAction' x r t) -> Maybe (ISRAction' x r t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup t
t (Map t (ISRAction' x r t) -> Maybe (ISRAction' x r t))
-> Maybe (Map t (ISRAction' x r t)) -> Maybe (ISRAction' x r t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do Getting
  (Map t (ISRAction' x r t))
  (ISRActions' x r t)
  (Map t (ISRAction' x r t))
-> ISRActions' x r t -> Map t (ISRAction' x r t)
forall a s. Getting a s a -> s -> a
view Getting
  (Map t (ISRAction' x r t))
  (ISRActions' x r t)
  (Map t (ISRAction' x r t))
forall x r t (f :: * -> *).
Functor f =>
(Map t (ISRAction' x r t) -> f (Map t (ISRAction' x r t)))
-> ISRActions' x r t -> f (ISRActions' x r t)
iactTerm (ISRActions' x r t -> Map t (ISRAction' x r t))
-> Maybe (ISRActions' x r t) -> Maybe (Map t (ISRAction' x r t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap (ISRActions' x r t) -> Maybe (ISRActions' x r t)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
s IntMap (ISRActions' x r t)
sr
  tabGoto :: Int -> NT' x -> Maybe Int
tabGoto Int
s NT' x
x = Int -> IGotoActions -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
x) (IGotoActions -> Maybe Int) -> Maybe IGotoActions -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IntMap IGotoActions -> Maybe IGotoActions
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
s IntMap IGotoActions
goto
  tabInit :: Int
tabInit = Int
0

-- | Construct the extensional parse table.
constructParseTable :: forall x r t. (Ord r, Ord t) => EGrammar' x r t -> ParseTable' x r t PState
constructParseTable :: forall x r t.
(Ord r, Ord t) =>
EGrammar' x r t -> ParseTable' x r t Int
constructParseTable = IPT' x r t -> ParseTable' x r t Int
forall x r t. (Ord r, Ord t) => IPT' x r t -> ParseTable' x r t Int
constructParseTable' (IPT' x r t -> ParseTable' x r t Int)
-> (EGrammar' x r t -> IPT' x r t)
-> EGrammar' x r t
-> ParseTable' x r t Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EGrammar' x r t -> IPT' x r t
forall x r t. (Ord r, Ord t) => EGrammar' x r t -> IPT' x r t
ptGen

-- | Add rule @%start -> S@ for new start symbol.
addNewStart :: forall x r t. x -> r -> EGrammar' x r t -> EGrammar' x r t
addNewStart :: forall x r t. x -> r -> EGrammar' x r t -> EGrammar' x r t
addNewStart x
x r
r (EGrammar Grammar' x r t
grm NT' x
start FirstSets t
fs) = Grammar' x r t -> NT' x -> FirstSets t -> EGrammar' x r t
forall x r t.
Grammar' x r t -> NT' x -> FirstSets t -> EGrammar' x r t
EGrammar (Grammar' x r t -> Grammar' x r t
forall {t2}. Grammar' x r t2 -> Grammar' x r t2
add Grammar' x r t
grm) NT' x
newstart FirstSets t
fs
  where
  add :: Grammar' x r t2 -> Grammar' x r t2
add = ASetter
  (Grammar' x r t2)
  (Grammar' x r t2)
  (IntMap (NTDef' x r t2))
  (IntMap (NTDef' x r t2))
-> (IntMap (NTDef' x r t2) -> IntMap (NTDef' x r t2))
-> Grammar' x r t2
-> Grammar' x r t2
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Grammar' x r t2)
  (Grammar' x r t2)
  (IntMap (NTDef' x r t2))
  (IntMap (NTDef' x r t2))
forall x r1 t1 r2 t2 (f :: * -> *).
Functor f =>
(IntMap (NTDef' x r1 t1) -> f (IntMap (NTDef' x r2 t2)))
-> Grammar' x r1 t1 -> f (Grammar' x r2 t2)
grmNTDefs ((IntMap (NTDef' x r t2) -> IntMap (NTDef' x r t2))
 -> Grammar' x r t2 -> Grammar' x r t2)
-> (IntMap (NTDef' x r t2) -> IntMap (NTDef' x r t2))
-> Grammar' x r t2
-> Grammar' x r t2
forall a b. (a -> b) -> a -> b
$ Int
-> NTDef' x r t2
-> IntMap (NTDef' x r t2)
-> IntMap (NTDef' x r t2)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
newstart) (NTDef' x r t2 -> IntMap (NTDef' x r t2) -> IntMap (NTDef' x r t2))
-> NTDef' x r t2
-> IntMap (NTDef' x r t2)
-> IntMap (NTDef' x r t2)
forall a b. (a -> b) -> a -> b
$
          x -> [Alt' x r t2] -> NTDef' x r t2
forall x r t. x -> [Alt' x r t] -> NTDef' x r t
NTDef x
x ([Alt' x r t2] -> NTDef' x r t2) -> [Alt' x r t2] -> NTDef' x r t2
forall a b. (a -> b) -> a -> b
$ [r -> Form' x t2 -> Alt' x r t2
forall x r t. r -> Form' x t -> Alt' x r t
Alt r
r (Form' x t2 -> Alt' x r t2) -> Form' x t2 -> Alt' x r t2
forall a b. (a -> b) -> a -> b
$ [Symbol' x t2] -> Form' x t2
forall x t. [Symbol' x t] -> Form' x t
Form [NT' x -> Symbol' x t2
forall x t. NT' x -> Symbol' x t
NonTerm NT' x
start]]
  newstart :: NT' x
  newstart :: NT' x
newstart = Int -> x -> NT' x
forall x. Int -> x -> NT' x
NT (Int
0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) x
x