cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification

1 files changed, 73 insertions, 73 deletions

diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index e02ccd9ca..61035bd92 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -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