forked from GitHub/gf-core
Redesign and opimize the incremental parser
This commit is contained in:
krasimir
@@ -1,4 +1,4 @@
|
|||||||
{-# OPTIONS -fbang-patterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
module PGF.Parsing.FCFG.Incremental
|
module PGF.Parsing.FCFG.Incremental
|
||||||
( State
|
( State
|
||||||
, initState
|
, initState
|
||||||
@@ -10,6 +10,8 @@ module PGF.Parsing.FCFG.Incremental
|
|||||||
|
|
||||||
import Data.Array
|
import Data.Array
|
||||||
import Data.Array.Base (unsafeAt)
|
import Data.Array.Base (unsafeAt)
|
||||||
|
import Data.List (isPrefixOf)
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.IntMap as IntMap
|
import qualified Data.IntMap as IntMap
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
@@ -44,24 +46,42 @@ initState pinfo start =
|
|||||||
Just ((fid,_), _) -> fid+1
|
Just ((fid,_), _) -> fid+1
|
||||||
Nothing -> 0
|
Nothing -> 0
|
||||||
|
|
||||||
in process (allRules pinfo) items (State MM.empty [] MM.empty Map.empty forest max_fid 0)
|
in State (Chart MM.empty [] Map.empty forest max_fid 0)
|
||||||
|
(Set.fromList items)
|
||||||
|
|
||||||
nextState :: ParserInfo -> FToken -> State -> State
|
nextState :: ParserInfo -> FToken -> State -> State
|
||||||
nextState pinfo t state =
|
nextState pinfo t (State chart items) =
|
||||||
process (allRules pinfo) (tokens state MM.! t) state{ chart=MM.empty
|
let (items1,chart1) = process add (allRules pinfo) (Set.toList items) (Set.empty,chart)
|
||||||
, charts=chart state : charts state
|
chart2 = chart1{ active =MM.empty
|
||||||
, tokens=MM.empty
|
, actives=active chart1 : actives chart1
|
||||||
, passive=Map.empty
|
, passive=Map.empty
|
||||||
, currOffset=currOffset state+1
|
, offset =offset chart1+1
|
||||||
}
|
}
|
||||||
|
in State chart2 items1
|
||||||
|
where
|
||||||
|
add tok item set
|
||||||
|
| tok == t = Set.insert item set
|
||||||
|
| otherwise = set
|
||||||
|
|
||||||
getCompletions :: State -> FToken -> [FToken]
|
getCompletions :: ParserInfo -> FToken -> State -> Map.Map FToken State
|
||||||
getCompletions state w =
|
getCompletions pinfo w (State chart items) =
|
||||||
[t | t <- MM.keys (tokens state), take (length w) t == w]
|
let (map',chart1) = process add (allRules pinfo) (Set.toList items) (MM.empty,chart)
|
||||||
|
chart2 = chart1{ active =MM.empty
|
||||||
|
, actives=active chart1 : actives chart1
|
||||||
|
, passive=Map.empty
|
||||||
|
, offset =offset chart1+1
|
||||||
|
}
|
||||||
|
in fmap (State chart2) map'
|
||||||
|
where
|
||||||
|
add tok item map
|
||||||
|
| isPrefixOf w tok = fromMaybe map (MM.insert' tok item map)
|
||||||
|
| otherwise = map
|
||||||
|
|
||||||
extractExps :: ParserInfo -> CId -> State -> [Exp]
|
extractExps :: ParserInfo -> CId -> State -> [Exp]
|
||||||
extractExps pinfo start st = exps
|
extractExps pinfo start (State chart items) = exps
|
||||||
where
|
where
|
||||||
|
(_,st) = process (\_ _ -> id) (allRules pinfo) (Set.toList items) ((),chart)
|
||||||
|
|
||||||
exps = nubsort $ do
|
exps = nubsort $ do
|
||||||
c <- Map.findWithDefault [] start (startupCats pinfo)
|
c <- Map.findWithDefault [] start (startupCats pinfo)
|
||||||
ruleid <- topdownRules pinfo ? c
|
ruleid <- topdownRules pinfo ? c
|
||||||
@@ -77,46 +97,42 @@ extractExps pinfo start st = exps
|
|||||||
args <- mapM go args
|
args <- mapM go args
|
||||||
return (EApp fn args)
|
return (EApp fn args)
|
||||||
|
|
||||||
process !rules [] state = state
|
process fn !rules [] acc_chart = acc_chart
|
||||||
process !rules (item:items) state = process rules items $! univRule item state
|
process fn !rules (item:items) acc_chart = process fn rules items $! univRule item acc_chart
|
||||||
where
|
where
|
||||||
univRule (Active j lbl ppos ruleid args fid0) state
|
univRule (Active j lbl ppos ruleid args fid0) acc_chart@(acc,chart)
|
||||||
| inRange (bounds lin) ppos =
|
| inRange (bounds lin) ppos =
|
||||||
case unsafeAt lin ppos of
|
case unsafeAt lin ppos of
|
||||||
FSymCat r d -> {-# SCC "COND11" #-}
|
FSymCat r d -> let !fid = args !! d
|
||||||
let !fid = args !! d
|
in case MM.insert' (AK fid r) item (active chart) of
|
||||||
in case MM.insert' (AK fid r) item (chart state) of
|
Nothing -> acc_chart
|
||||||
Nothing -> state
|
Just actCat -> (case Map.lookup (PK fid r k) (passive chart) of
|
||||||
Just actCat -> (case Map.lookup (PK fid r k) (passive state) of
|
|
||||||
Nothing -> id
|
Nothing -> id
|
||||||
Just id -> process rules [Active j lbl (ppos+1) ruleid (updateAt d id args) fid0]) $
|
Just id -> process fn rules [Active j lbl (ppos+1) ruleid (updateAt d id args) fid0]) $
|
||||||
(case IntMap.lookup fid (forest state) of
|
(case IntMap.lookup fid (forest chart) of
|
||||||
Nothing -> id
|
Nothing -> id
|
||||||
Just set -> process rules (Set.fold (\(Passive ruleid args) -> (:) (Active k r 0 ruleid args fid)) [] set)) $
|
Just set -> process fn rules (Set.fold (\(Passive ruleid args) -> (:) (Active k r 0 ruleid args fid)) [] set)) $
|
||||||
state{chart=actCat}
|
(acc,chart{active=actCat})
|
||||||
FSymTok tok -> {-# SCC "COND12" #-}
|
FSymTok tok -> (fn tok (Active j lbl (ppos+1) ruleid args fid0) acc,chart)
|
||||||
case MM.insert' tok (Active j lbl (ppos+1) ruleid args fid0) (tokens state) of
|
| otherwise = case Map.lookup (PK fid0 lbl j) (passive chart) of
|
||||||
Nothing -> state
|
Nothing -> let fid = nextId chart
|
||||||
Just actTok -> state{tokens=actTok}
|
in process fn rules [Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc
|
||||||
| otherwise = {-# SCC "COND2" #-}
|
| Active j' lbl ppos ruleid args fidc <- ((active chart:actives chart) !! (k-j)) MM.! (AK fid0 lbl),
|
||||||
case Map.lookup (PK fid0 lbl j) (passive state) of
|
let FSymCat _ d = unsafeAt (rhs ruleid lbl) ppos] $
|
||||||
Nothing -> let fid = nextId state
|
(acc,chart{passive=Map.insert (PK fid0 lbl j) fid (passive chart)
|
||||||
in process rules [Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc
|
,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest chart)
|
||||||
| Active j' lbl ppos ruleid args fidc <- ((chart state:charts state) !! (k-j)) MM.! (AK fid0 lbl),
|
,nextId =nextId chart+1
|
||||||
let FSymCat _ d = unsafeAt (rhs ruleid lbl) ppos] $
|
})
|
||||||
state{passive=Map.insert (PK fid0 lbl j) fid (passive state)
|
Just id -> (acc,chart{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest chart)})
|
||||||
,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest state)
|
|
||||||
,nextId =nextId state+1
|
|
||||||
}
|
|
||||||
Just id -> state{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest state)}
|
|
||||||
where
|
where
|
||||||
!lin = rhs ruleid lbl
|
!lin = rhs ruleid lbl
|
||||||
!k = currOffset state
|
!k = offset chart
|
||||||
|
|
||||||
rhs ruleid lbl = unsafeAt lins lbl
|
rhs ruleid lbl = unsafeAt lins lbl
|
||||||
where
|
where
|
||||||
(FRule _ _ _ cat lins) = unsafeAt rules ruleid
|
(FRule _ _ _ cat lins) = unsafeAt rules ruleid
|
||||||
|
|
||||||
|
updateAt :: Int -> a -> [a] -> [a]
|
||||||
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
|
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
|
||||||
|
|
||||||
|
|
||||||
@@ -143,14 +159,15 @@ data PassiveKey
|
|||||||
{-# UNPACK #-} !Int
|
{-# UNPACK #-} !Int
|
||||||
deriving (Eq,Ord,Show)
|
deriving (Eq,Ord,Show)
|
||||||
|
|
||||||
data State
|
|
||||||
= State
|
data State = State Chart (Set.Set Active)
|
||||||
{ chart :: MM.MultiMap ActiveKey Active
|
|
||||||
, charts :: [MM.MultiMap ActiveKey Active]
|
data Chart
|
||||||
, tokens :: MM.MultiMap FToken Active
|
= Chart
|
||||||
, passive :: Map.Map PassiveKey FCat
|
{ active :: MM.MultiMap ActiveKey Active
|
||||||
, forest :: IntMap.IntMap (Set.Set Passive)
|
, actives :: [MM.MultiMap ActiveKey Active]
|
||||||
, nextId :: {-# UNPACK #-} !FCat
|
, passive :: Map.Map PassiveKey FCat
|
||||||
, currOffset :: {-# UNPACK #-} !Int
|
, forest :: IntMap.IntMap (Set.Set Passive)
|
||||||
|
, nextId :: {-# UNPACK #-} !FCat
|
||||||
|
, offset :: {-# UNPACK #-} !Int
|
||||||
}
|
}
|
||||||
deriving Show
|
|
||||||
|
|||||||
Reference in New Issue
Block a user