From 4573d104425a79b8b00ebcccb2e94c62275285ea Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 14 Oct 2008 08:00:50 +0000 Subject: the new optimized incremental parser and the common subexpression elimination optimization in PMCFG --- src/PGF/Parsing/FCFG/Active.hs | 135 ++++++++++++---------- src/PGF/Parsing/FCFG/Incremental.hs | 224 ++++++++++++++++++++++-------------- src/PGF/Parsing/FCFG/Utilities.hs | 4 +- 3 files changed, 214 insertions(+), 149 deletions(-) (limited to 'src/PGF/Parsing/FCFG') diff --git a/src/PGF/Parsing/FCFG/Active.hs b/src/PGF/Parsing/FCFG/Active.hs index 4386bfdd1..0927a719b 100644 --- a/src/PGF/Parsing/FCFG/Active.hs +++ b/src/PGF/Parsing/FCFG/Active.hs @@ -17,17 +17,22 @@ import qualified GF.Data.MultiMap as MM import PGF.CId import PGF.Data import PGF.Parsing.FCFG.Utilities +import PGF.BuildParser import Control.Monad (guard) import qualified Data.List as List import qualified Data.Map as Map +import qualified Data.IntMap as IntMap import qualified Data.Set as Set -import Data.Array +import Data.Array.IArray +import Debug.Trace ---------------------------------------------------------------------- -- * parsing +type FToken = String + makeFinalEdge cat 0 0 = (cat, [EmptyRange]) makeFinalEdge cat i j = (cat, [makeRange i j]) @@ -36,77 +41,79 @@ parse :: String -> ParserInfo -> CId -> [FToken] -> [Tree] parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees where inTokens = input toks - starts = Map.findWithDefault [] start (startupCats pinfo) + starts = Map.findWithDefault [] start (startCats pinfo) schart = xchart2syntaxchart chart pinfo (i,j) = inputBounds inTokens finalEdges = [makeFinalEdge cat i j | cat <- starts] forests = chart2forests schart (const False) finalEdges filteredForests = forests >>= applyProfileToForest - chart = process strategy pinfo inTokens axioms emptyXChart - axioms | isBU strategy = literals pinfo inTokens ++ initialBU pinfo inTokens - | isTD strategy = literals pinfo inTokens ++ initialTD pinfo starts inTokens + pinfoex = buildParserInfo pinfo + + chart = process strategy pinfo pinfoex inTokens axioms emptyXChart + axioms | isBU strategy = literals pinfoex inTokens ++ initialBU pinfo pinfoex inTokens + | isTD strategy = literals pinfoex inTokens ++ initialTD pinfo starts inTokens isBU s = s=="b" isTD s = s=="t" -- used in prediction -emptyChildren :: RuleId -> ParserInfo -> SyntaxNode RuleId RangeRec -emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) - where - FRule _ _ rhs _ _ = allRules pinfo ! ruleid +emptyChildren :: FunId -> [FCat] -> SyntaxNode FunId RangeRec +emptyChildren ruleid args = SNode ruleid (replicate (length args) []) + -process :: String -> ParserInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat -process strategy pinfo toks [] chart = chart -process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart +process :: String -> ParserInfo -> ParserInfoEx -> Input FToken -> [Item] -> XChart FCat -> XChart FCat +process strategy pinfo pinfoex toks [] chart = chart +process strategy pinfo pinfoex toks (item:items) chart = process strategy pinfo pinfoex toks items $! univRule item chart where - univRule cat item@(Active found rng lbl ppos node@(SNode ruleid recs)) chart + univRule item@(Active found rng lbl ppos node@(SNode ruleid recs) args cat) chart | inRange (bounds lin) ppos = case lin ! ppos of - FSymCat r d -> let c = args !! d + FSymCat d r -> let c = args !! d in case recs !! d of [] -> case insertXChart chart item c of Nothing -> chart - Just chart -> let items = do item@(Final found' _) <- lookupXChartFinal chart c + Just chart -> let items = do item@(Final found' _ _ _) <- lookupXChartFinal chart c rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs))) + return (Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs)) args cat) ++ do guard (isTD strategy) - ruleid <- topdownRules pinfo ? c - return (c, Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) - in process strategy pinfo toks items chart + (ruleid,args) <- topdownRules pinfo c + return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args c) + in process strategy pinfo pinfoex toks items chart found' -> let items = do rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) node) - in process strategy pinfo toks items chart - FSymTok tok -> let items = do t_rng <- inputToken toks ? tok + return (Active found rng lbl (ppos+1) node args cat) + in process strategy pinfo pinfoex toks items chart + FSymTok (KS tok) + -> let items = do t_rng <- inputToken toks ? tok rng' <- concatRange rng t_rng - return (cat, Active found rng' lbl (ppos+1) node) - in process strategy pinfo toks items chart + return (Active found rng' lbl (ppos+1) node args cat) + in process strategy pinfo pinfoex toks items chart | otherwise = if inRange (bounds lins) (lbl+1) - then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart - else univRule cat (Final (reverse (rng:found)) node) chart + then univRule (Active (rng:found) EmptyRange (lbl+1) 0 node args cat) chart + else univRule (Final (reverse (rng:found)) node args cat) chart where - (FRule _ _ args cat lins) = allRules pinfo ! ruleid - lin = lins ! lbl - univRule cat item@(Final found' node) chart = + (FFun _ _ lins) = functions pinfo ! ruleid + lin = sequences pinfo ! (lins ! lbl) + univRule item@(Final found' node args cat) chart = case insertXChart chart item cat of Nothing -> chart - Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat - let FRule _ _ args _ lins = allRules pinfo ! ruleid - FSymCat r d = lins ! l ! ppos + Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _) args c) <- lookupXChartAct chart cat + let FFun _ _ lins = functions pinfo ! ruleid + FSymCat d r = (sequences pinfo ! (lins ! l)) ! ppos rng <- concatRange rng (found' !! r) - return (args !! d, Active found rng l (ppos+1) (updateChildren node d found')) + return (Active found rng l (ppos+1) (updateChildren node d found') args c) ++ do guard (isBU strategy) - ruleid <- leftcornerCats pinfo ? cat - let FRule _ _ args _ lins = allRules pinfo ! ruleid - FSymCat r d = lins ! 0 ! 0 - return (args !! d, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) + (ruleid,args,c) <- leftcornerCats pinfoex ? cat + let FFun _ _ lins = functions pinfo ! ruleid + FSymCat d r = (sequences pinfo ! (lins ! 0)) ! 0 + return (Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid args) d found') args c) - updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> SyntaxNode RuleId RangeRec + updateChildren :: SyntaxNode FunId RangeRec -> Int -> RangeRec -> SyntaxNode FunId RangeRec updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs - in process strategy pinfo toks items chart + in process strategy pinfo pinfoex toks items chart ---------------------------------------------------------------------- -- * XChart @@ -116,21 +123,23 @@ data Item Range {-# UNPACK #-} !FIndex {-# UNPACK #-} !FPointPos - (SyntaxNode RuleId RangeRec) - | Final RangeRec (SyntaxNode RuleId RangeRec) - deriving (Eq, Ord) + (SyntaxNode FunId RangeRec) + [FCat] + FCat + | Final RangeRec (SyntaxNode FunId RangeRec) [FCat] FCat + deriving (Eq, Ord, Show) data XChart c = XChart !(MM.MultiMap c Item) !(MM.MultiMap c Item) emptyXChart :: Ord c => XChart c emptyXChart = XChart MM.empty MM.empty -insertXChart (XChart actives finals) item@(Active _ _ _ _ _) c = +insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _ _) c = case MM.insert' c item actives of Nothing -> Nothing Just actives -> Just (XChart actives finals) -insertXChart (XChart actives finals) item@(Final _ _) c = +insertXChart (XChart actives finals) item@(Final _ _ _ _) c = case MM.insert' c item finals of Nothing -> Nothing Just finals -> Just (XChart actives finals) @@ -142,17 +151,17 @@ xchart2syntaxchart :: XChart FCat -> ParserInfo -> SyntaxChart (CId,[Profile]) ( xchart2syntaxchart (XChart actives finals) pinfo = accumAssoc groupSyntaxNodes $ [ case node of - SNode ruleid rrecs -> let FRule fun prof rhs cat _ = allRules pinfo ! ruleid + SNode ruleid rrecs -> let FFun fun prof _ = functions pinfo ! ruleid in ((cat,found), SNode (fun,prof) (zip rhs rrecs)) SString s -> ((cat,found), SString s) SInt n -> ((cat,found), SInt n) SFloat f -> ((cat,found), SFloat f) - | (cat, Final found node) <- MM.toList finals + | (Final found node rhs cat) <- MM.elems finals ] -literals :: ParserInfo -> Input FToken -> [(FCat,Item)] -literals pinfo toks = - [let (c,node) = lexer t in (c,Final [rng] node) | (t,rngs) <- aAssocs (inputToken toks), rng <- rngs, not (t `elem` grammarToks pinfo)] +literals :: ParserInfoEx -> Input FToken -> [Item] +literals pinfoex toks = + [let (c,node) = lexer t in (Final [rng] node [] c) | (t,rngs) <- aAssocs (inputToken toks), rng <- rngs, not (t `elem` grammarToks pinfoex)] where lexer t = case reads t of @@ -166,24 +175,30 @@ literals pinfo toks = -- Earley -- -- called with all starting categories -initialTD :: ParserInfo -> [FCat] -> Input FToken -> [(FCat,Item)] +initialTD :: ParserInfo -> [FCat] -> Input FToken -> [Item] initialTD pinfo starts toks = do cat <- starts - ruleid <- topdownRules pinfo ? cat - return (cat,Active [] (Range 0 0) 0 0 (emptyChildren ruleid pinfo)) + (ruleid,args) <- topdownRules pinfo cat + return (Active [] (Range 0 0) 0 0 (emptyChildren ruleid args) args cat) + +topdownRules pinfo cat = f cat [] + where + f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions pinfo)) + + g (FApply ruleid args) rules = (ruleid,args) : rules + g (FCoerce cat) rules = f cat rules ---------------------------------------------------------------------- -- Kilbury -- -initialBU :: ParserInfo -> Input FToken -> [(FCat,Item)] -initialBU pinfo toks = +initialBU :: ParserInfo -> ParserInfoEx -> Input FToken -> [Item] +initialBU pinfo pinfoex toks = do (tok,rngs) <- aAssocs (inputToken toks) - ruleid <- leftcornerTokens pinfo ? tok - let FRule _ _ _ cat _ = allRules pinfo ! ruleid + (ruleid,args,cat) <- leftcornerTokens pinfoex ? tok rng <- rngs - return (cat,Active [] rng 0 1 (emptyChildren ruleid pinfo)) + return (Active [] rng 0 1 (emptyChildren ruleid args) args cat) ++ - do ruleid <- epsilonRules pinfo - let FRule _ _ _ cat _ = allRules pinfo ! ruleid - return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) + do (ruleid,args,cat) <- epsilonRules pinfoex + let FFun _ _ _ = functions pinfo ! ruleid + return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args cat) diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index 23b0424cc..4f35ed169 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -8,55 +8,54 @@ module PGF.Parsing.FCFG.Incremental , parse ) where -import Data.Array +import Data.Array.IArray import Data.Array.Base (unsafeAt) import Data.List (isPrefixOf, foldl') -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybe) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified Data.Set as Set import Control.Monad -import GF.Data.Assoc import GF.Data.SortedList -import qualified GF.Data.MultiMap as MM import PGF.CId import PGF.Data -import PGF.Parsing.FCFG.Utilities import Debug.Trace -parse :: ParserInfo -> CId -> [FToken] -> [Tree] -parse pinfo start toks = extractExps (foldl' nextState (initState pinfo start) toks) start +parse :: ParserInfo -> CId -> [String] -> [Tree] +parse pinfo start toks = maybe [] (\ps -> extractExps ps start) (foldM nextState (initState pinfo start) toks) initState :: ParserInfo -> CId -> ParseState initState pinfo start = let items = do - c <- Map.findWithDefault [] start (startupCats pinfo) - ruleid <- topdownRules pinfo ? c - let (FRule fn _ args cat lins) = allRules pinfo ! ruleid - lbl <- indices lins - return (Active 0 lbl 0 ruleid args cat) + cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) + (funid,args) <- foldForest (\funid args -> (:) (funid,args)) [] cat (productions pinfo) + let FFun fn _ lins = functions pinfo ! funid + (lbl,seqid) <- assocs lins + return (Active 0 0 funid seqid args (AK cat lbl)) - forest = IntMap.fromListWith Set.union [(cat, Set.singleton (Passive ruleid args)) | (ruleid, FRule _ _ args cat _) <- assocs (allRules pinfo)] - - max_fid = maximum (0:[maximum (cat:args) | (ruleid, FRule _ _ args cat _) <- assocs (allRules pinfo)])+1 + max_fid = maximum (0:[maximum (cat:args) | (cat, set) <- IntMap.toList (productions pinfo) + , p <- Set.toList set + , let args = case p of {FApply _ args -> args; FCoerce cat -> [cat]}])+1 in State pinfo - (Chart MM.empty [] Map.empty forest max_fid 0) + (Chart emptyAC [] emptyPC (productions pinfo) max_fid 0) (Set.fromList items) -- | From the current state and the next token -- 'nextState' computes a new state where the token -- is consumed and the current position shifted by one. -nextState :: ParseState -> String -> ParseState +nextState :: ParseState -> String -> Maybe ParseState nextState (State pinfo chart items) t = - let (items1,chart1) = process add (allRules pinfo) (Set.toList items) (Set.empty,chart) - chart2 = chart1{ active =MM.empty + let (items1,chart1) = process add (sequences pinfo) (functions pinfo) (Set.toList items) Set.empty chart + chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 - , passive=Map.empty + , passive=emptyPC , offset =offset chart1+1 } - in State pinfo chart2 items1 + in if Set.null items1 + then Nothing + else Just (State pinfo chart2 items1) where add tok item set | tok == t = Set.insert item set @@ -68,107 +67,157 @@ nextState (State pinfo chart items) t = -- the GF interpreter. getCompletions :: ParseState -> String -> Map.Map String ParseState getCompletions (State pinfo chart items) w = - let (map',chart1) = process add (allRules pinfo) (Set.toList items) (MM.empty,chart) - chart2 = chart1{ active =MM.empty + let (map',chart1) = process add (sequences pinfo) (functions pinfo) (Set.toList items) Map.empty chart + chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 - , passive=Map.empty + , passive=emptyPC , offset =offset chart1+1 } in fmap (State pinfo chart2) map' where add tok item map - | isPrefixOf w tok = fromMaybe map (MM.insert' tok item map) + | isPrefixOf w tok = Map.insertWith Set.union tok (Set.singleton item) map | otherwise = map extractExps :: ParseState -> CId -> [Tree] extractExps (State pinfo chart items) start = exps where - (_,st) = process (\_ _ -> id) (allRules pinfo) (Set.toList items) ((),chart) + (_,st) = process (\_ _ -> id) (sequences pinfo) (functions pinfo) (Set.toList items) () chart exps = nubsort $ do - c <- Map.findWithDefault [] start (startupCats pinfo) - ruleid <- topdownRules pinfo ? c - let (FRule fn _ args cat lins) = allRules pinfo ! ruleid + cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) + (funid,args) <- foldForest (\funid args -> (:) (funid,args)) [] cat (productions pinfo) + let FFun fn _ lins = functions pinfo ! funid lbl <- indices lins - fid <- Map.lookup (PK c lbl 0) (passive st) + Just fid <- [lookupPC (PK cat lbl 0) (passive st)] go Set.empty fid - go rec fid - | Set.member fid rec = mzero - | otherwise = do set <- IntMap.lookup fid (forest st) - Passive ruleid args <- Set.toList set - let (FRule fn _ _ cat lins) = allRules pinfo ! ruleid - if fn == wildCId - then go (Set.insert fid rec) (head args) - else do args <- mapM (go (Set.insert fid rec)) args - return (Fun fn args) - -process fn !rules [] acc_chart = acc_chart -process fn !rules (item:items) acc_chart = univRule item acc_chart + go rec fcat + | Set.member fcat rec = mzero + | otherwise = do (funid,args) <- foldForest (\funid args -> (:) (funid,args)) [] fcat (forest st) + let FFun fn _ lins = functions pinfo ! funid + args <- mapM (go (Set.insert fcat rec)) args + return (Fun fn args) + +process fn !seqs !funs [] acc chart = (acc,chart) +process fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart + | inRange (bounds lin) ppos = + case unsafeAt lin ppos of + FSymCat d r -> let !fid = args !! d + key = AK fid r + + items2 = case lookupPC (mkPK key k) (passive chart) of + Nothing -> items + Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items + items3 = foldForest (\funid args -> (:) (Active k 0 funid (rhs funid r) args key)) items2 fid (forest chart) + in case lookupAC key (active chart) of + Nothing -> process fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} + Just set | Set.member item set -> process fn seqs funs items acc chart + | otherwise -> process fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} + FSymTok (KS tok) -> let !acc' = fn tok (Active j (ppos+1) funid seqid args key0) acc + in process fn seqs funs items acc' chart + | otherwise = + case lookupPC (mkPK key0 j) (passive chart) of + Nothing -> let fid = nextId chart + + items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of + Nothing -> items + Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> + let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos + in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set + in process fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) + ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) + ,nextId =nextId chart+1 + } + Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items + in process fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} where - univRule (Active j lbl ppos ruleid args fid0) acc_chart@(acc,chart) - | inRange (bounds lin) ppos = - case unsafeAt lin ppos of - FSymCat r d -> let !fid = args !! d - in case MM.insert' (AK fid r) item (active chart) of - Nothing -> process fn rules items $ acc_chart - Just actCat -> (case Map.lookup (PK fid r k) (passive chart) of - Nothing -> id - Just id -> process fn rules [Active j lbl (ppos+1) ruleid (updateAt d id args) fid0]) $ - (case IntMap.lookup fid (forest chart) of - Nothing -> id - Just set -> process fn rules (Set.fold (\(Passive ruleid args) -> (:) (Active k r 0 ruleid args fid)) [] set)) $ - process fn rules items $ - (acc,chart{active=actCat}) - FSymTok tok -> process fn rules items $ - (fn tok (Active j lbl (ppos+1) ruleid args fid0) acc,chart) - | otherwise = case Map.lookup (PK fid0 lbl j) (passive chart) of - Nothing -> let fid = nextId chart - in process fn rules [Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc - | Active j' lbl ppos ruleid args fidc <- ((active chart:actives chart) !! (k-j)) MM.! (AK fid0 lbl), - let FSymCat _ d = unsafeAt (rhs ruleid lbl) ppos] $ - process fn rules items $ - (acc,chart{passive=Map.insert (PK fid0 lbl j) fid (passive chart) - ,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest chart) - ,nextId =nextId chart+1 - }) - Just id -> process fn rules items $ - (acc,chart{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest chart)}) - where - !lin = rhs ruleid lbl - !k = offset chart + !lin = unsafeAt seqs seqid + !k = offset chart - rhs ruleid lbl = unsafeAt lins lbl + mkPK (AK fid lbl) j = PK fid lbl j + + rhs funid lbl = unsafeAt lins lbl where - (FRule _ _ _ cat lins) = unsafeAt rules ruleid + FFun _ _ lins = unsafeAt funs funid updateAt :: Int -> a -> [a] -> [a] updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] +---------------------------------------------------------------- +-- Active Chart +---------------------------------------------------------------- + data Active = Active {-# UNPACK #-} !Int - {-# UNPACK #-} !FIndex {-# UNPACK #-} !FPointPos - {-# UNPACK #-} !RuleId + {-# UNPACK #-} !FunId + {-# UNPACK #-} !SeqId [FCat] - {-# UNPACK #-} !FCat + {-# UNPACK #-} !ActiveKey deriving (Eq,Show,Ord) -data Passive - = Passive {-# UNPACK #-} !RuleId - [FCat] - deriving (Eq,Ord,Show) - data ActiveKey = AK {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex deriving (Eq,Ord,Show) +type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active)) + +emptyAC :: ActiveChart +emptyAC = IntMap.empty + +lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active) +lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l + +labelsAC :: FCat -> ActiveChart -> [FIndex] +labelsAC fcat chart = + case IntMap.lookup fcat chart of + Nothing -> [] + Just map -> IntMap.keys map + +insertAC :: ActiveKey -> Set.Set Active -> ActiveChart -> ActiveChart +insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart + + +---------------------------------------------------------------- +-- Passive Chart +---------------------------------------------------------------- + data PassiveKey = PK {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int deriving (Eq,Ord,Show) +type PassiveChart = Map.Map PassiveKey FCat + +emptyPC :: PassiveChart +emptyPC = Map.empty + +lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat +lookupPC key chart = Map.lookup key chart + +insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart +insertPC key fcat chart = Map.insert key fcat chart + + +---------------------------------------------------------------- +-- Forest +---------------------------------------------------------------- + +foldForest :: (FunId -> [FCat] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b +foldForest f b fcat forest = + case IntMap.lookup fcat forest of + Nothing -> b + Just set -> Set.fold foldPassive b set + where + foldPassive (FCoerce fcat) b = foldForest f b fcat forest + foldPassive (FApply funid args) b = f funid args b + + +---------------------------------------------------------------- +-- Parse State +---------------------------------------------------------------- -- | An abstract data type whose values represent -- the current state in an incremental parser. @@ -176,10 +225,11 @@ data ParseState = State ParserInfo Chart (Set.Set Active) data Chart = Chart - { active :: MM.MultiMap ActiveKey Active - , actives :: [MM.MultiMap ActiveKey Active] - , passive :: Map.Map PassiveKey FCat - , forest :: IntMap.IntMap (Set.Set Passive) + { active :: ActiveChart + , actives :: [ActiveChart] + , passive :: PassiveChart + , forest :: IntMap.IntMap (Set.Set Production) , nextId :: {-# UNPACK #-} !FCat , offset :: {-# UNPACK #-} !Int } + deriving Show diff --git a/src/PGF/Parsing/FCFG/Utilities.hs b/src/PGF/Parsing/FCFG/Utilities.hs index 4187d0f24..6a2c13c0a 100644 --- a/src/PGF/Parsing/FCFG/Utilities.hs +++ b/src/PGF/Parsing/FCFG/Utilities.hs @@ -31,7 +31,7 @@ type RangeRec = [Range] data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int | EmptyRange - deriving (Eq, Ord) + deriving (Eq, Ord, Show) makeRange :: Int -> Int -> Range makeRange = Range @@ -83,7 +83,7 @@ data SyntaxNode n e = SMeta | SString String | SInt Integer | SFloat Double - deriving (Eq,Ord) + deriving (Eq,Ord,Show) groupSyntaxNodes :: Ord n => [SyntaxNode n e] -> [SyntaxNode n [e]] groupSyntaxNodes [] = [] -- cgit v1.2.3