now the parser could return partial parse results

3 files changed, 55 insertions, 27 deletions

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 26a727a47..128a58a35 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -154,10 +154,10 @@ parseAll     :: PGF -> Type -> String -> [[Tree]]
 parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
 
 -- | The same as 'parse' but returns more detailed information
-parse_       :: PGF -> Language -> Type -> String -> (Parse.ParseResult,Maybe BracketedString)
+parse_       :: PGF -> Language -> Type -> String -> (Parse.ParseResult,BracketedString)
 
 -- | This is an experimental function. Use it on your own risk
-parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseResult,Maybe BracketedString)
+parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseResult,BracketedString)
 
 -- | The same as 'generateAllDepth' but does not limit
 -- the depth in the generation, and doesn't give an initial expression.
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 428ee276a..4c59ce0d9 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -32,8 +32,7 @@ data Forest
       { abstr  :: Abstr

       , concr  :: Concr

       , forest :: IntMap.IntMap (Set.Set Production)

-      , root   :: {-# UNPACK #-} !FId

-      , label  :: {-# UNPACK #-} !LIndex

+      , root   :: [([Symbol],[FId])]

       }

 

 --------------------------------------------------------------------

@@ -49,11 +48,13 @@ linearizeWithBrackets = head . snd . untokn "" . bracketedTokn
 --

 

 bracketedTokn :: Forest -> BracketedTokn

-bracketedTokn (Forest abs cnc forest root label) =

-  let (fid,cat,lin) = render IntMap.empty root

-  in Bracket_ cat fid label (lin ! label)

+bracketedTokn (Forest abs cnc forest root) =

+  case [computeSeq seq (map (render IntMap.empty) args) | (seq,args) <- root] of

+    ([bs@(Bracket_ cat fid label lin)]:_) -> bs

+    (bss:_)                               -> Bracket_ wildCId 0 0 bss

+    []                                    -> Bracket_ wildCId 0 0 []

   where

-    trusted = trustedSpots IntSet.empty root

+    trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root]

 

     render parents fid =

       case (IntMap.lookup fid parents) `mplus` (fmap Set.toList $ IntMap.lookup fid forest) of

@@ -63,12 +64,16 @@ bracketedTokn (Forest abs cnc forest root label) =
         descend parents (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid

                                                   Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs)

                                                   largs = map (render parents) args

-                                              in (fid,cat,listArray (bounds lins) [computeSeq seqid largs | seqid <- elems lins])

+                                                  ltable = listArray (bounds lins)

+                                                                     [computeSeq (elems (sequences cnc ! seqid)) largs |

+                                                                                                         seqid <- elems lins]

+                                              in (fid,cat,ltable)

         descend parents (PCoerce fid)       = render parents fid

         descend parents (PConst cat _ ts)   = (fid,cat,listArray (0,0) [[LeafKS ts]])

 

     trustedSpots parents fid

-      | IntSet.member fid parents

+      | fid < totalCats cnc ||                  -- forest ids from the grammar correspond to metavariables

+        IntSet.member fid parents               -- this avoids loops in the grammar

                   = IntSet.empty

       | otherwise = IntSet.insert fid $

                       case IntMap.lookup fid forest of

@@ -81,11 +86,9 @@ bracketedTokn (Forest abs cnc forest root label) =
         descend (PCoerce fid)       = trustedSpots parents' fid

         descend (PConst c e _)      = IntSet.empty

 

-    computeSeq :: SeqId -> [(FId,CId,LinTable)] -> [BracketedTokn]

-    computeSeq seqid args = concatMap compute (elems seq)

+    computeSeq :: [Symbol] -> [(FId,CId,LinTable)] -> [BracketedTokn]

+    computeSeq seq args = concatMap compute seq

       where

-        seq = sequences cnc ! seqid

-

         compute (SymCat d r)    = getArg d r

         compute (SymLit d r)    = getArg d r

         compute (SymKS ts)      = [LeafKS ts]

diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index 9ae28bdab..ce195f752 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -38,16 +38,16 @@ data ParseResult
                                    -- if there are many analizes for some phrase but they all are not type correct.

   | ParseResult [Tree]             -- ^ If the parsing was successful we get a list of abstract syntax trees. The list should be non-empty.

 

-parse :: PGF -> Language -> Type -> [String] -> (ParseResult,Maybe BracketedString)

+parse :: PGF -> Language -> Type -> [String] -> (ParseResult,BracketedString)

 parse pgf lang typ toks = loop (initState pgf lang typ) toks

   where

     loop ps []     = getParseResult ps typ

     loop ps (t:ts) = case nextState ps t of

                        Left  es -> case es of

-                                     EState _ _ chart -> (ParseFailed (offset chart),Nothing)

+                                     EState _ _ chart -> (ParseFailed (offset chart),snd (getParseResult ps typ))

                        Right ps -> loop ps ts

 

-parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseResult,Maybe BracketedString)

+parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseResult,BracketedString)

 parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks

   where

     accept ps []     = getParseResult ps typ

@@ -155,11 +155,13 @@ recoveryStates open_types (EState pgf cnc chart) =
 -- that spans the whole input consumed so far. The trees are also

 -- limited by the category specified, which is usually

 -- the same as the startup category.

-getParseResult :: ParseState -> Type -> (ParseResult,Maybe BracketedString)

+getParseResult :: ParseState -> Type -> (ParseResult,BracketedString)

 getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =

-  let mb_bs = case roots of

-                ((AK fid lbl):_) -> Just $ linearizeWithBrackets $ Forest (abstract pgf) cnc (forest st) fid lbl

-                _                -> Nothing

+  let froots | null roots = getPartialSeq (sequences cnc) (reverse (active st : actives st)) acc1

+             | otherwise  = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots]

+

+      bs    = linearizeWithBrackets (Forest (abstract pgf) cnc (forest st) froots)

+              

                 

       exps  = nubsort $ do

                 (AK fid lbl) <- roots

@@ -172,11 +174,15 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
                 then ParseFailed (offset chart)

                 else ParseResult exps

 

-  in (res,mb_bs)

+  in (res,bs)

   where

     (mb_agenda,acc) = TMap.decompose items

     agenda = maybe [] Set.toList mb_agenda

-    (_,st) = process Nothing (\_ _ -> id) (sequences cnc) (cncfuns cnc) agenda () chart

+    (acc1,st) = process Nothing add (sequences cnc) (cncfuns cnc) agenda [] chart

+

+    add _ (Active j ppos funid seqid args key) items = (j,lin,args,key) : items

+      where

+        lin  = take (ppos-1) (elems (unsafeAt (sequences cnc) seqid))

 

     roots = case Map.lookup start (cnccats cnc) of

               Just (CncCat s e lbls) -> do cat <- range (s,e)

@@ -187,18 +193,18 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
 

     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 -> 

+      | Set.member fcat rec  = mzero

+      | otherwise            = foldForest (\funid args trees -> 

                                                   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`

                                                   trees)

-                                            (\const _ trees ->

+                                          (\const _ trees ->

                                                   return (freeVar const,const)

                                                   `mplus`

                                                   trees)

-                                            [] fcat (forest st)

+                                          [] fcat (forest st)

 

     check_ho_fun fun args

       | fun == _V = return (head args)

@@ -211,6 +217,25 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
     freeVar (EFun v) = Set.singleton v

     freeVar _        = Set.empty

 

+getPartialSeq seqs actives = expand Set.empty

+  where

+    expand acc [] = 

+      [(lin,args) | (j,lin,args,key) <- Set.toList acc, j == 0]

+    expand acc (item@(j,lin,args,key) : items)

+      | item `Set.member` acc = expand acc  items

+      | otherwise             = expand acc' items'

+      where

+        acc'   = Set.insert item acc

+        items' = case lookupAC key (actives !! j) of

+                   Nothing  -> items

+                   Just set -> [if j' < j

+                                  then let lin' = take ppos (elems (unsafeAt seqs seqid))

+                                       in (j',lin'++map (inc (length args')) lin,args'++args,key')

+                                  else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items

+

+    inc n (SymCat d r) = SymCat (n+d) r

+    inc n (SymLit d r) = SymLit (n+d) r

+    inc n s            = s

 

 process mbt fn !seqs !funs []                                                 acc chart = (acc,chart)

 process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart