module Text.GrammarCombinators.Utils.CalcFirst (
FirstSet (FS, firstSet, canBeEmpty, canBeEOI),
FSCalculator, FirstSetGrammar, calcFS,
calcFirst
) where
import Data.Set (Set, union, singleton)
import Data.Enumerable (enumerate)
import qualified Data.Set as Set
import Text.GrammarCombinators.Base
data (Token t) => FirstSet t =
FS {
firstSet :: Set t,
canBeEmpty :: Bool,
canBeEOI :: Bool
} deriving (Show)
newtype FSCalculator phi (r :: * -> *) t rr v = MkFSCalculator {
calcFS :: FirstSetGrammar phi r t rr -> FirstSet t
}
type FirstSetGrammar phi r t rr =
forall ix. phi ix -> FSCalculator phi r t rr (rr ix)
instance (Token t) => ProductionRule (FSCalculator phi r t rr) where
a >>> b = MkFSCalculator $ \g ->
let FS fsa ea fa = calcFS a g
FS fsb eb fb = calcFS b g
in FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb))
a ||| b = MkFSCalculator $ \g ->
let fa = calcFS a g
fb = calcFS b g
in FS {
firstSet = firstSet fa `union` firstSet fb,
canBeEmpty = canBeEmpty fa || canBeEmpty fb,
canBeEOI = canBeEOI fa || canBeEOI fb }
die = MkFSCalculator $ \_ -> FS Set.empty False False
endOfInput = MkFSCalculator $ \_ -> FS Set.empty False True
instance (Token t) => EpsProductionRule (FSCalculator phi r t rr) where
epsilon _ = MkFSCalculator $ \_ -> FS Set.empty True False
instance (Token t) => LiftableProductionRule (FSCalculator phi r t rr) where
epsilonL _ _ = MkFSCalculator $ \_ -> FS Set.empty True False
newtype WrapFSC phi r t rr ix = WFSC { unWFSC :: FSCalculator phi r t rr (rr ix) }
blockRecurse :: (EqFam phi, Token t) =>
FirstSetGrammar phi r t rr -> phi idx -> FirstSetGrammar phi r t rr
blockRecurse gram idx = unWFSC . overrideIdx (WFSC . gram) idx (WFSC die)
instance (Token t) => TokenProductionRule (FSCalculator phi r t rr) t where
token c = MkFSCalculator $ \_ -> FS (singleton c) False False
anyToken = MkFSCalculator $ \_ -> FS allTokens False False
where allTokens = Set.fromList enumerate
instance (Token t, EqFam phi) => RecProductionRule (FSCalculator phi r t rr) phi r where
ref idx = MkFSCalculator $ \g -> calcFS (g idx) $ blockRecurse g idx
instance (Token t, EqFam phi) => LoopProductionRule (FSCalculator phi r t rr) phi r where
many1Ref idx = MkFSCalculator $ \g -> calcFS (ref idx) g
calcFirst :: (Domain phi, Token t) =>
GExtendedContextFreeGrammar phi t r rr ->
phi ix -> FirstSet t
calcFirst g idx = calcFS (ref idx) g