mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-29 22:42:52 -06:00
cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification
This commit is contained in:
krasimir
@@ -56,14 +56,14 @@ parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ)
|
||||
-- startup category.
|
||||
initState :: PGF -> Language -> Type -> ParseState
|
||||
initState pgf lang (DTyp _ start _) =
|
||||
let items = case Map.lookup start (startCats cnc) of
|
||||
Just (s,e,labels) -> do cat <- range (s,e)
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
[] cat (pproductions cnc)
|
||||
let FFun fn lins = functions cnc ! funid
|
||||
(lbl,seqid) <- assocs lins
|
||||
return (Active 0 0 funid seqid args (AK cat lbl))
|
||||
Nothing -> mzero
|
||||
let items = case Map.lookup start (cnccats cnc) of
|
||||
Just (CncCat s e labels) -> do cat <- range (s,e)
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
[] cat (pproductions cnc)
|
||||
let CncFun fn lins = cncfuns cnc ! funid
|
||||
(lbl,seqid) <- assocs lins
|
||||
return (Active 0 0 funid seqid args (AK cat lbl))
|
||||
Nothing -> mzero
|
||||
|
||||
cnc = lookConcr pgf lang
|
||||
|
||||
@@ -82,7 +82,7 @@ nextState (PState pgf cnc chart items) t =
|
||||
let (mb_agenda,map_items) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
acc = fromMaybe TMap.empty (Map.lookup t map_items)
|
||||
(acc1,chart1) = process (Just t) add (sequences cnc) (functions cnc) agenda acc chart
|
||||
(acc1,chart1) = process (Just t) add (sequences cnc) (cncfuns cnc) agenda acc chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, passive=emptyPC
|
||||
@@ -105,7 +105,7 @@ getCompletions (PState pgf cnc chart items) w =
|
||||
let (mb_agenda,map_items) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
|
||||
(acc',chart1) = process Nothing add (sequences cnc) (functions cnc) agenda acc chart
|
||||
(acc',chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda acc chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, passive=emptyPC
|
||||
@@ -121,7 +121,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState
|
||||
recoveryStates open_types (EState pgf cnc chart) =
|
||||
let open_fcats = concatMap type2fcats open_types
|
||||
agenda = foldl (complete open_fcats) [] (actives chart)
|
||||
(acc,chart1) = process Nothing add (sequences cnc) (functions cnc) agenda Map.empty chart
|
||||
(acc,chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda Map.empty chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, passive=emptyPC
|
||||
@@ -129,9 +129,9 @@ recoveryStates open_types (EState pgf cnc chart) =
|
||||
}
|
||||
in (PState pgf cnc chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf cnc chart2) acc)
|
||||
where
|
||||
type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats cnc) of
|
||||
Just (s,e,labels) -> range (s,e)
|
||||
Nothing -> []
|
||||
type2fcats (DTyp _ cat _) = case Map.lookup cat (cnccats cnc) of
|
||||
Just (CncCat s e labels) -> range (s,e)
|
||||
Nothing -> []
|
||||
|
||||
complete open_fcats items ac =
|
||||
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
|
||||
@@ -151,23 +151,23 @@ extractTrees (PState pgf cnc chart items) ty@(DTyp _ start _) =
|
||||
where
|
||||
(mb_agenda,acc) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
(_,st) = process Nothing (\_ _ -> id) (sequences cnc) (functions cnc) agenda () chart
|
||||
(_,st) = process Nothing (\_ _ -> id) (sequences cnc) (cncfuns cnc) agenda () chart
|
||||
|
||||
exps =
|
||||
case Map.lookup start (startCats cnc) of
|
||||
Just (s,e,lbls) -> do cat <- range (s,e)
|
||||
lbl <- indices lbls
|
||||
Just fid <- [lookupPC (PK cat lbl 0) (passive st)]
|
||||
(fvs,tree) <- go Set.empty 0 (0,fid)
|
||||
guard (Set.null fvs)
|
||||
return tree
|
||||
Nothing -> mzero
|
||||
case Map.lookup start (cnccats cnc) of
|
||||
Just (CncCat s e lbls) -> do cat <- range (s,e)
|
||||
lbl <- indices lbls
|
||||
Just fid <- [lookupPC (PK cat lbl 0) (passive st)]
|
||||
(fvs,tree) <- go Set.empty 0 (0,fid)
|
||||
guard (Set.null fvs)
|
||||
return tree
|
||||
Nothing -> mzero
|
||||
|
||||
go rec fcat' (d,fcat)
|
||||
| fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
|
||||
| Set.member fcat rec = mzero
|
||||
| otherwise = foldForest (\funid args trees ->
|
||||
do let FFun fn lins = functions cnc ! funid
|
||||
do let CncFun fn lins = cncfuns cnc ! funid
|
||||
args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args)
|
||||
check_ho_fun fn args
|
||||
`mplus`
|
||||
@@ -193,36 +193,36 @@ process mbt fn !seqs !funs [] ac
|
||||
process mbt 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
|
||||
SymCat 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 items -> Active k 0 funid (rhs funid r) args key : items)
|
||||
(\_ _ items -> items)
|
||||
items2 fid (forest chart)
|
||||
in case lookupAC key (active chart) of
|
||||
Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}
|
||||
Just set | Set.member item set -> process mbt fn seqs funs items acc chart
|
||||
| otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
|
||||
FSymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
FSymKP strs vars
|
||||
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc
|
||||
(strs:[strs' | Alt strs' _ <- vars])
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
FSymLit d r -> let !fid = args !! d
|
||||
in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of
|
||||
(toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
[] -> case litCatMatch fid mbt of
|
||||
Just (toks,lit) -> let fid' = nextId chart
|
||||
!acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
|
||||
in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit toks)) (forest chart)
|
||||
,nextId=nextId chart+1
|
||||
}
|
||||
Nothing -> process mbt fn seqs funs items acc chart
|
||||
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 items -> Active k 0 funid (rhs funid r) args key : items)
|
||||
(\_ _ items -> items)
|
||||
items2 fid (forest chart)
|
||||
in case lookupAC key (active chart) of
|
||||
Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}
|
||||
Just set | Set.member item set -> process mbt fn seqs funs items acc chart
|
||||
| otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
|
||||
SymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
SymKP strs vars
|
||||
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc
|
||||
(strs:[strs' | Alt strs' _ <- vars])
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
SymLit d r -> let !fid = args !! d
|
||||
in case [ts | PConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of
|
||||
(toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
[] -> case litCatMatch fid mbt of
|
||||
Just (toks,lit) -> let fid' = nextId chart
|
||||
!acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
|
||||
in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (PConst lit toks)) (forest chart)
|
||||
,nextId=nextId chart+1
|
||||
}
|
||||
Nothing -> process mbt fn seqs funs items acc chart
|
||||
| otherwise =
|
||||
case lookupPC (mkPK key0 j) (passive chart) of
|
||||
Nothing -> let fid = nextId chart
|
||||
@@ -230,14 +230,14 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
|
||||
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
|
||||
let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
|
||||
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set
|
||||
in process mbt 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)
|
||||
,forest =IntMap.insert fid (Set.singleton (PApply 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 mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)}
|
||||
in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
|
||||
where
|
||||
!lin = unsafeAt seqs seqid
|
||||
!k = offset chart
|
||||
@@ -246,7 +246,7 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
|
||||
|
||||
rhs funid lbl = unsafeAt lins lbl
|
||||
where
|
||||
FFun _ lins = unsafeAt funs funid
|
||||
CncFun _ lins = unsafeAt funs funid
|
||||
|
||||
|
||||
updateAt :: Int -> a -> [a] -> [a]
|
||||
@@ -268,15 +268,15 @@ litCatMatch _ _ = Nothing
|
||||
|
||||
data Active
|
||||
= Active {-# UNPACK #-} !Int
|
||||
{-# UNPACK #-} !FPointPos
|
||||
{-# UNPACK #-} !DotPos
|
||||
{-# UNPACK #-} !FunId
|
||||
{-# UNPACK #-} !SeqId
|
||||
[FCat]
|
||||
[FId]
|
||||
{-# UNPACK #-} !ActiveKey
|
||||
deriving (Eq,Show,Ord)
|
||||
data ActiveKey
|
||||
= AK {-# UNPACK #-} !FCat
|
||||
{-# UNPACK #-} !FIndex
|
||||
= AK {-# UNPACK #-} !FId
|
||||
{-# UNPACK #-} !LIndex
|
||||
deriving (Eq,Ord,Show)
|
||||
type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active))
|
||||
|
||||
@@ -286,13 +286,13 @@ emptyAC = IntMap.empty
|
||||
lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active)
|
||||
lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l
|
||||
|
||||
lookupACByFCat :: FCat -> ActiveChart -> [Set.Set Active]
|
||||
lookupACByFCat :: FId -> ActiveChart -> [Set.Set Active]
|
||||
lookupACByFCat fcat chart =
|
||||
case IntMap.lookup fcat chart of
|
||||
Nothing -> []
|
||||
Just map -> IntMap.elems map
|
||||
|
||||
labelsAC :: FCat -> ActiveChart -> [FIndex]
|
||||
labelsAC :: FId -> ActiveChart -> [LIndex]
|
||||
labelsAC fcat chart =
|
||||
case IntMap.lookup fcat chart of
|
||||
Nothing -> []
|
||||
@@ -307,20 +307,20 @@ insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.sin
|
||||
----------------------------------------------------------------
|
||||
|
||||
data PassiveKey
|
||||
= PK {-# UNPACK #-} !FCat
|
||||
{-# UNPACK #-} !FIndex
|
||||
= PK {-# UNPACK #-} !FId
|
||||
{-# UNPACK #-} !LIndex
|
||||
{-# UNPACK #-} !Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
type PassiveChart = Map.Map PassiveKey FCat
|
||||
type PassiveChart = Map.Map PassiveKey FId
|
||||
|
||||
emptyPC :: PassiveChart
|
||||
emptyPC = Map.empty
|
||||
|
||||
lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat
|
||||
lookupPC :: PassiveKey -> PassiveChart -> Maybe FId
|
||||
lookupPC key chart = Map.lookup key chart
|
||||
|
||||
insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart
|
||||
insertPC :: PassiveKey -> FId -> PassiveChart -> PassiveChart
|
||||
insertPC key fcat chart = Map.insert key fcat chart
|
||||
|
||||
|
||||
@@ -328,15 +328,15 @@ insertPC key fcat chart = Map.insert key fcat chart
|
||||
-- Forest
|
||||
----------------------------------------------------------------
|
||||
|
||||
foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b
|
||||
foldForest :: (FunId -> [FId] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b
|
||||
foldForest f g b fcat forest =
|
||||
case IntMap.lookup fcat forest of
|
||||
Nothing -> b
|
||||
Just set -> Set.fold foldProd b set
|
||||
where
|
||||
foldProd (FCoerce fcat) b = foldForest f g b fcat forest
|
||||
foldProd (FApply funid args) b = f funid args b
|
||||
foldProd (FConst const toks) b = g const toks b
|
||||
foldProd (PCoerce fcat) b = foldForest f g b fcat forest
|
||||
foldProd (PApply funid args) b = f funid args b
|
||||
foldProd (PConst const toks) b = g const toks b
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
@@ -353,7 +353,7 @@ data Chart
|
||||
, actives :: [ActiveChart]
|
||||
, passive :: PassiveChart
|
||||
, forest :: IntMap.IntMap (Set.Set Production)
|
||||
, nextId :: {-# UNPACK #-} !FCat
|
||||
, nextId :: {-# UNPACK #-} !FId
|
||||
, offset :: {-# UNPACK #-} !Int
|
||||
}
|
||||
deriving Show
|
||||
|
||||
Reference in New Issue
Block a user