a major refactoring in the C and the Haskell runtimes. Note incompatible change in the PGF format!!!

The following are the outcomes:

   - Predef.nonExist is fully supported by both the Haskell and the C runtimes

   - Predef.BIND is now an internal compiler defined token. For now
     it behaves just as usual for the Haskell runtime, i.e. it generates &+.
     However, the special treatment will let us to handle it properly in 
     the C runtime.

   - This required a major change in the PGF format since both 
     nonExist and BIND may appear inside 'pre' and this was not supported
     before.

9 files changed, 73 insertions, 54 deletions

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 865f98417..3c9dcc265 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -76,10 +76,6 @@ instance Binary Concr where
                         , cnccats=cnccats, totalCats=totalCats

                         })

 

-instance Binary Alternative where

-  put (Alt v x) = put (v,x)

-  get = liftM2 Alt get get

-

 instance Binary Expr where

   put (EAbs b x exp)  = putWord8 0 >> put (b,x,exp)

   put (EApp e1 e2)    = putWord8 1 >> put (e1,e2)

@@ -153,6 +149,7 @@ instance Binary Symbol where
   put (SymKS ts)         = putWord8 3 >> put ts

   put (SymKP d vs)       = putWord8 4 >> put (d,vs)

   put SymNE              = putWord8 5

+  put SymBIND            = putWord8 6

   get = do tag <- getWord8

            case tag of

              0 -> liftM2 SymCat get get

@@ -161,6 +158,7 @@ instance Binary Symbol where
              3 -> liftM  SymKS  get

              4 -> liftM2 (\d vs -> SymKP d vs) get get

              5 -> return SymNE

+             6 -> return SymBIND

              _ -> decodingError

 

 instance Binary PArg where

diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 58ced6a1e..e86b02778 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -58,9 +58,10 @@ data Symbol
   = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
   | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
   | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
-  | SymKS [Token]
-  | SymKP [Token] [Alternative]
+  | SymKS Token
   | SymNE                           -- non exist
+  | SymBIND                         -- the special BIND token
+  | SymKP [Symbol] [([Symbol],[String])]
   deriving (Eq,Ord,Show)
 data Production
   = PApply  {-# UNPACK #-} !FunId [PArg]
@@ -75,10 +76,6 @@ type FunId = Int
 type SeqId = Int
 type BCAddr = Int
 
-data Alternative =
-   Alt [Token] [String]
-  deriving (Eq,Ord,Show)
-
 
 -- merge two PGFs; fails is differens absnames; priority to second arg
 
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 9c47583ad..e6e3c1136 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -80,7 +80,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
                                                  ltable = mkLinTable cnc isTrusted [] funid largs

                                              in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

         descend forest (PCoerce fid)       = render forest (PArg [] fid)

-        descend forest (PConst cat e ts)   = ((cat,fid),wildCId,[e],([],listArray (0,0) [[LeafKS ts]]))

+        descend forest (PConst cat e ts)   = ((cat,fid),wildCId,[e],([],listArray (0,0) [map LeafKS ts]))

 

     getVar (fid,_)

       | fid == fidVar = wildCId

diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index cf4c78193..7ff7d9c7a 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -82,7 +82,7 @@ linTree pgf lang e =
                                                    LInt n -> return (n_fid+1,((cidInt,   n_fid),wildCId,[e0],([],ss (show n))))
                                                    LFlt f -> return (n_fid+1,((cidFloat, n_fid),wildCId,[e0],([],ss (show f))))
 
-    ss s = listArray (0,0) [[LeafKS [s]]]
+    ss s = listArray (0,0) [[LeafKS s]]
 
     apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, CId, [Expr], LinTable))]
     apply mb_cty n_fid e0 ys xs f es =
@@ -115,7 +115,7 @@ linTree pgf lang e =
                                   let args = [((wildCId, n_fid),wildCId,[e0],([],ss s))]
                                   return (n_fid+2,((cat,n_fid+1),wildCId,[e0],mkLinTable cnc (const True) xs funid args))
         Nothing
-          | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),wildCId,[e0],(xs,listArray (0,0) [[LeafKS [s]]])))
+          | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
           | otherwise       -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
                                   def (Just (cat,fid)) n_fid e0 ys xs s
     def Nothing          n_fid e0 ys xs s = []
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 2497d53ae..ffec9279f 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -156,9 +156,11 @@ data BracketedString
                                                                                -- that represents the same constituent.
 
 data BracketedTokn
-  = LeafKS [Token]
-  | LeafKP [Token] [Alternative]
-  | Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn]    -- Invariant: the list is not empty
+  = Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn]    -- Invariant: the list is not empty
+  | LeafKS Token
+  | LeafNE
+  | LeafBIND
+  | LeafKP [BracketedTokn] [([BracketedTokn],[String])]
   deriving Eq
 
 type LinTable = ([CId],Array.Array LIndex [BracketedTokn])
@@ -178,21 +180,30 @@ lengthBracketedString (Leaf _)              = 1
 lengthBracketedString (Bracket _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
 
 untokn :: Maybe String -> BracketedTokn -> (Maybe String,[BracketedString])
-untokn nw (LeafKS ts)   = (has_tok nw ts,map Leaf ts)
-untokn nw (LeafKP d vs) = let ts = filter (not . null) (sel d vs nw)
-                          in (has_tok nw ts,map Leaf ts)
-                          where
-                            sel d vs Nothing  = d
-                            sel d vs (Just w) =
-                              case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
-                                v:_ -> v
-                                _   -> d
-untokn nw (Bracket_ cat fid index fun es bss) =
-  let (nw',bss') = mapAccumR untokn nw bss
-  in (nw',[Bracket cat fid index fun es (concat bss')])
-
-has_tok nw []     = nw
-has_tok nw (t:ts) = Just t
+untokn nw bs = 
+  case untokn nw bs of
+    (nw,Nothing ) -> (nw,[] )
+    (nw,Just bss) -> (nw,bss)
+  where
+    untokn nw (Bracket_ cat fid index fun es bss) =
+      let (nw',bss') = mapAccumR untokn nw bss
+      in case sequence bss' of
+           Just bss -> (nw',Just [Bracket cat fid index fun es (concat bss)])
+           Nothing  -> (Nothing, Nothing)
+    untokn nw (LeafKS t)
+      | null t              = (nw,Just [])
+      | otherwise           = (Just t,Just [Leaf t])
+    untokn nw LeafNE        = (Nothing, Nothing)
+    untokn nw (LeafKP d vs) = let (nw',bss') = mapAccumR untokn nw (sel d vs nw)
+                              in case sequence bss' of
+                                   Just bss -> (nw',Just (concat bss))
+                                   Nothing  -> (Nothing, Nothing)
+                              where
+                                sel d vs Nothing  = d
+                                sel d vs (Just w) =
+                                  case [v | (v,cs) <- vs, any (\c -> isPrefixOf c w) cs] of
+                                    v:_ -> v
+                                    _   -> d
 
 type CncType = (CId, FId)    -- concrete type is the abstract type (the category) + the forest id
 
@@ -204,11 +215,13 @@ mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq fi
 computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,CId,[Expr],LinTable)] -> [BracketedTokn]
 computeSeq filter seq args = concatMap compute seq
   where
-    compute (SymCat d r)    = getArg d r
-    compute (SymLit d r)    = getArg d r
-    compute (SymVar d r)    = getVar d r
-    compute (SymKS ts)      = [LeafKS ts]
-    compute (SymKP ts alts) = [LeafKP ts alts]
+    compute (SymCat d r)      = getArg d r
+    compute (SymLit d r)      = getArg d r
+    compute (SymVar d r)      = getVar d r
+    compute (SymKS t)         = [LeafKS t]
+    compute SymNE             = [LeafNE]
+    compute SymBIND           = [LeafKS "&+"]
+    compute (SymKP syms alts) = [LeafKP (concatMap compute syms) [(concatMap compute syms,cs) | (syms,cs) <- alts]]
 
     getArg d r
       | not (null arg_lin) &&
@@ -218,7 +231,7 @@ computeSeq filter seq args = concatMap compute seq
         arg_lin                    = lin ! r
         (ct@(cat,fid),fun,es,(xs,lin)) = args !! d
 
-    getVar d r = [LeafKS [showCId (xs !! r)]]
+    getVar d r = [LeafKS (showCId (xs !! r))]
       where
         (ct,fun,es,(xs,lin)) = args !! d
 
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index 2f8fdecc2..894b64dfb 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -36,8 +36,8 @@ collectWords pinfo = Map.fromListWith (++)
                          , sym <- elems (sequences pinfo ! seqid)
                          , t <- sym2tokns sym]
   where
-    sym2tokns (SymKS ts)      = ts
-    sym2tokns (SymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
+    sym2tokns (SymKS t)       = [t]
+    sym2tokns (SymKP ts alts) = concat (map sym2tokns ts ++ [sym2tokns sym | (syms,ps) <- alts, sym <- syms])
     sym2tokns _               = []
 
 lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs
index a339c9add..f04a8b04c 100644
--- a/src/runtime/haskell/PGF/Optimize.hs
+++ b/src/runtime/haskell/PGF/Optimize.hs
@@ -221,9 +221,13 @@ splitLexicalRules cnc p_prods =
         
         wf ts = (ts,IntSet.singleton funid)
         
-        seq2prefix []                   = TrieMap.fromList [wf []]
-        seq2prefix (SymKS ts     :syms) = TrieMap.fromList [wf ts]
-        seq2prefix (SymKP ts alts:syms) = TrieMap.fromList (wf ts : [wf ts | Alt ts ps <- alts])
+        seq2prefix []                      = TrieMap.fromList [wf []]
+        seq2prefix (SymKS t         :syms) = TrieMap.fromList [wf [t]]
+        seq2prefix (SymKP syms0 alts:syms) = TrieMap.unionsWith IntSet.union
+                                                (seq2prefix (syms0++syms) : 
+                                                  [seq2prefix (syms1 ++ syms) | (syms1,ps) <- alts])
+        seq2prefix (SymNE           :syms) = TrieMap.empty
+        seq2prefix (SymBIND         :syms) = TrieMap.fromList [wf ["&+"]]
 
 updateConcrete abs cnc = 
   let p_prods0      = filterProductions IntMap.empty IntSet.empty (productions cnc)
diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index 7057db3bc..e50f8436e 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -244,14 +244,12 @@ getParseOutput (PState abs cnc chart cnt) ty@(DTyp _ start _) dp =
     flit _    = Nothing

     ftok toks = TrieMap.unionWith Set.union (TrieMap.compose Nothing toks)

 

-    cutAt ppos toks seqid  = 

+    cutAt ppos toks seqid =

       let seq  = unsafeAt (sequences cnc) seqid

           init = take (ppos-1) (elems seq)

           tail = case unsafeAt seq (ppos-1) of

-                   SymKS ts   -> let ts' = reverse (drop (length toks) (reverse ts))

-                                 in if null ts' then [] else [SymKS ts']

-		   SymKP ts _ -> let ts' = reverse (drop (length toks) (reverse ts))

-                                 in if null ts' then [] else [SymKS ts']

+                   SymKS t    -> drop (length toks) [SymKS t]

+                   SymKP ts _ -> reverse (drop (length toks) (reverse ts))

                    sym        -> []

       in init ++ tail

 

@@ -307,11 +305,18 @@ process flit ftok cnc (item@(Active j ppos funid seqid args key0):items) acc cha
                            Nothing                             -> process flit ftok cnc items4 acc' chart{active=insertAC key (Set.singleton item,new_sc) (active chart)}

                            Just (set,sc) | Set.member item set -> process flit ftok cnc items  acc  chart

                                          | otherwise           -> process flit ftok cnc items2 acc  chart{active=insertAC key (Set.insert item set,IntMap.unionWith Set.union new_sc sc) (active chart)}

-      	SymKS toks -> let !acc' = ftok_ toks (Active j (ppos+1) funid seqid args key0) acc

+      	SymKS tok  -> let !acc' = ftok_ [tok] (Active j (ppos+1) funid seqid args key0) acc

       	              in process flit ftok cnc items acc' chart

-      	SymKP strs vars

-      	           -> let !acc' = foldl (\acc toks -> ftok_ toks (Active j (ppos+1) funid seqid args key0) acc) acc

-                                        (strs:[strs' | Alt strs' _ <- vars])

+      	SymNE      -> process flit ftok cnc items acc chart

+      	SymBIND    -> let !acc' = ftok_ ["&+"] (Active j (ppos+1) funid seqid args key0) acc

+      	              in process flit ftok cnc items acc' chart

+      	SymKP syms vars

+      	           -> let to_tok (SymKS t) = [t]

+      	                  to_tok SymBIND   = ["&+"]

+      	                  to_tok _         = []

+

+      	                  !acc' = foldl (\acc syms -> ftok_ (concatMap to_tok syms) (Active j (ppos+1) funid seqid args key0) acc) acc

+                                        (syms:[syms' | (syms',_) <- vars])

                       in process flit ftok cnc items acc' chart

         SymLit d r -> let PArg hypos fid = args !! d

                           key   = AK fid r

diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index c0529b116..9385e81c4 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -89,10 +89,12 @@ ppPrintName (id,name) =
 ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
 ppSymbol (SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
 ppSymbol (SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
-ppSymbol (SymKS ts)   = ppStrs ts
-ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
+ppSymbol (SymKS t)    = doubleQuotes (text t)
+ppSymbol SymNE        = text "nonExist"
+ppSymbol SymBIND      = text "BIND"
+ppSymbol (SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
 
-ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
+ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
 
 ppStrs ss = doubleQuotes (hsep (map text ss))