module Text.GrammarCombinators.Parser.RealLL1 (
FirstSet(FS,firstTokens,canBeEmpty,canBeEOI),
BranchSelectorMemo(DefaultBranchSelectorMemo,SplitBranchSelectorMemoL, FlipBS),
RealLL1Table (MkRealLL1Table),
parseRealLL1,
prepareLL1Parser,
) where
import Text.GrammarCombinators.Base
import Control.Monad.Maybe
import Control.Monad.State
import Data.Set
import Data.Enumerable (enumerate)
import qualified Data.Set as Set
data (Token t) => FirstSet t =
FS {
firstTokens :: Set t,
canBeEmpty :: Bool,
canBeEOI :: Bool
} deriving (Show)
data BranchSelector t = MkBS {
selectBranch :: forall a. [ConcreteToken t] -> a -> a -> (a, BranchSelector t)
}
defaultBranchSelector :: BranchSelector t
defaultBranchSelector =
MkBS (error "defaultBranchSelector selecting branch???")
data BranchSelectorMemo t =
DefaultBranchSelectorMemo
| SplitBranchSelectorMemoL (FirstSet t) (BranchSelectorMemo t) (BranchSelectorMemo t)
| FlipBS (BranchSelectorMemo t)
unBranchSelectorMemo :: forall t. (Token t) => BranchSelectorMemo t -> BranchSelector t
unBranchSelectorMemo DefaultBranchSelectorMemo = defaultBranchSelector
unBranchSelectorMemo (SplitBranchSelectorMemoL fs bsm1 bsm2) =
let bs1 = unBranchSelectorMemo bsm1
bs2 = unBranchSelectorMemo bsm2
selBranch :: Set t -> Bool -> [ConcreteToken t] -> a -> a -> (a, BranchSelector t)
selBranch fts _ (t:_) b1 b2 = if classify t `member` fts then (b1,bs1) else (b2,bs2)
selBranch _ f [] b1 b2 = if f then (b1,bs1) else (b2,bs2)
in MkBS $ selBranch (firstTokens fs) (canBeEOI fs)
unBranchSelectorMemo (FlipBS bsm) =
let bs = unBranchSelectorMemo bsm
in MkBS $ \s b1 b2 -> selectBranch bs s b2 b1
data BranchData t = MkBD {
branchSelector :: BranchSelectorMemo t,
seqBS :: BranchSelectorMemo t -> BranchSelectorMemo t,
firstSet :: FirstSet t
}
type BranchSelectorGrammar phi t = forall ix. phi ix -> BranchData t
newtype (Domain phi, Token t) => BranchSelectorComputer phi (r :: * -> *) t v = MkBSC {
branchData :: BranchSelectorGrammar phi t -> BranchData t
}
type BSCGrammar phi r t rr = forall ix. phi ix -> BranchSelectorComputer phi r t (rr ix)
instance (Domain phi, Token t) => ProductionRule (BranchSelectorComputer phi r t) where
a >>> b = MkBSC $ \g ->
let
bs = seqBS (branchData a g) (branchSelector (branchData b g))
(FS fsa ea fa) = firstSet $ branchData a g
(FS fsb eb fb) = firstSet $ branchData b g
fs = FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb))
nseqbs = seqBS (branchData a g) . seqBS (branchData b g)
in MkBD bs nseqbs fs
a ||| b = MkBSC $ \g ->
let
fsa = firstSet $ branchData a g
fsb = firstSet $ branchData b g
(FS ftsa ea fa) = fsa
(FS ftsb eb fb) = fsb
fs = FS (ftsa `union` ftsb) (ea || eb) (fa || fb)
bsa = branchSelector $ branchData a g
bsb = branchSelector $ branchData b g
sb bsa' bsb' = if not ea
then SplitBranchSelectorMemoL fsa bsa' bsb'
else FlipBS $ SplitBranchSelectorMemoL fsb bsb' bsa'
seqbs rbs = sb (seqBS (branchData a g) rbs) (seqBS (branchData a g) rbs)
in MkBD (sb bsa bsb) seqbs fs
die = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False False
endOfInput = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False True
instance (Domain phi, Token t) => LiftableProductionRule (BranchSelectorComputer phi r t) where
epsilonL v _ = epsilon v
instance (Domain phi, Token t) => EpsProductionRule (BranchSelectorComputer phi r t) where
epsilon _ = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty True False
instance (Token t, Domain phi) => TokenProductionRule (BranchSelectorComputer phi r t) t where
token tt = MkBSC $ \_ ->
MkBD DefaultBranchSelectorMemo id $ FS (singleton tt) False False
anyToken = MkBSC $ \_ ->
MkBD DefaultBranchSelectorMemo id $ FS (fromList enumerate) False False
instance (Token t, Domain phi) => RecProductionRule (BranchSelectorComputer phi r t) phi r where
ref idx = MkBSC $ \g ->
MkBD DefaultBranchSelectorMemo id $ firstSet $ g idx
instance (Token t, Domain phi) => LoopProductionRule (BranchSelectorComputer phi r t) phi r where
manyRef idx = MkBSC $ \g ->
let
singleFS = firstSet $ g idx
multFS = FS (firstTokens singleFS) True (canBeEOI singleFS)
in MkBD DefaultBranchSelectorMemo id multFS
fixBSC :: (Domain phi, Token t) => BSCGrammar phi r t rr -> BranchSelectorGrammar phi t
fixBSC gram idx = branchData (gram idx) (fixBSC gram)
data RealLL1Rule phi ixT r t v = MkRealLL1Rule {
runLL1Rule :: BranchSelector t ->
(forall ix. phi ix -> BranchSelector t) ->
(forall ix. phi ix -> RealLL1Rule phi ixT r t (r ix)) ->
MaybeT (State [ConcreteToken t]) v
}
type RealLL1Grammar phi ixT rr r t = (Domain phi, Token t) => phi ix -> RealLL1Rule phi ixT r t (rr ix)
instance ProductionRule (RealLL1Rule phi ixT r t) where
a >>> b = MkRealLL1Rule $ \cs selg g -> do f <- runLL1Rule a cs selg g
x <- runLL1Rule b cs selg g
return $ f x
a ||| b = MkRealLL1Rule $ \cs selg g ->
do s <- get
let (r,ns) = selectBranch cs s a b
runLL1Rule r ns selg g
die = MkRealLL1Rule $ \_ _ _ -> fail "die"
endOfInput = MkRealLL1Rule $ \_ _ _ -> do [] <- get; return ()
instance LiftableProductionRule (RealLL1Rule phi ixT r t) where
epsilonL v _ = epsilon v
instance EpsProductionRule (RealLL1Rule phi ixT r t) where
epsilon v = MkRealLL1Rule $ \_ _ _ -> return v
instance (Token t) => TokenProductionRule (RealLL1Rule phi ixT r t) t where
token tt = MkRealLL1Rule $ \_ _ _ ->
let
errWrongToken c = show c ++ " read when " ++ show tt ++ " expected."
in do (c:r) <- get
if classify c == tt
then put r >> return c
else fail $ errWrongToken c
anyToken = MkRealLL1Rule $ \_ _ _ ->
do (c:r) <- get
put r >> return c
instance RecProductionRule (RealLL1Rule phi ixT r t) phi r where
ref idx = MkRealLL1Rule $ \_ selg g ->
runLL1Rule (g idx) (selg idx) selg g
newtype RealLL1Table phi t = MkRealLL1Table {
unRealLL1Table :: Memo phi (K0 (BranchSelectorMemo t))
}
prepareLL1Parser :: (Domain phi, Token t) => BSCGrammar phi r t rr -> RealLL1Table phi t
prepareLL1Parser gram = MkRealLL1Table $ toMemoK $ branchSelector . fixBSC gram
parseRealLL1 :: forall phi ixT t r ix. (Domain phi, Token t) => RealLL1Grammar phi ixT r r t -> RealLL1Table phi t ->
phi ix -> [ConcreteToken t] -> Maybe (r ix)
parseRealLL1 gram selgmemo idx s =
let
selg :: phi ix' -> BranchSelector t
selg = unBranchSelectorMemo . fromMemoK (unRealLL1Table selgmemo)
m :: MaybeT (State [ConcreteToken t]) (r ix)
m = runLL1Rule (gram idx) (selg idx) selg gram
in evalState (runMaybeT m) s