added explicit depth parameter to the parsing API and the corresponding command in the shell

3 files changed, 27 insertions, 27 deletions

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index c750e66fe..9165f01ef 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -182,10 +182,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.ParseOutput,BracketedString)
+parse_       :: PGF -> Language -> Type -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
 
 -- | This is an experimental function. Use it on your own risk
-parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseOutput,BracketedString)
+parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
 
 -- | List of all languages available in the given grammar.
 languages    :: PGF -> [Language]
@@ -227,21 +227,21 @@ functionType :: PGF -> CId -> Maybe Type
 readPGF f = decodeFile f
 
 parse pgf lang typ s =
-  case parse_ pgf lang typ s of
+  case parse_ pgf lang typ (Just 4) s of
     (Parse.ParseOk ts,_) -> ts
     _                    -> []
 
 parseAll mgr typ = map snd . parseAllLang mgr typ
 
 parseAllLang mgr typ s = 
-  [(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ s]]
+  [(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ (Just 4) s]]
 
-parse_ pgf lang typ s = 
+parse_ pgf lang typ dp s = 
   case Map.lookup lang (concretes pgf) of
-    Just cnc -> Parse.parse pgf lang typ (words s)
+    Just cnc -> Parse.parse pgf lang typ dp (words s)
     Nothing  -> error ("Unknown language: " ++ showCId lang)
 
-parseWithRecovery pgf lang typ open_typs s = Parse.parseWithRecovery pgf lang typ open_typs (words s)
+parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s)
 
 groupResults :: [[(Language,String)]] -> [(Language,[String])]
 groupResults = Map.toList . foldr more Map.empty . start . concat
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 97cfbfa21..af8ccc5e4 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -47,16 +47,16 @@ data Forest
 -- Rendering of bracketed strings

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

 

-linearizeWithBrackets :: Forest -> BracketedString

-linearizeWithBrackets = head . snd . untokn "" . bracketedTokn

+linearizeWithBrackets :: Maybe Int -> Forest -> BracketedString

+linearizeWithBrackets dp = head . snd . untokn "" . bracketedTokn dp

 

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

 -- Internally we have to do everything with Tokn first because

 -- we must handle the pre {...} construction.

 --

 

-bracketedTokn :: Forest -> BracketedTokn

-bracketedTokn f@(Forest abs cnc forest root) =

+bracketedTokn :: Maybe Int -> Forest -> BracketedTokn

+bracketedTokn dp f@(Forest abs cnc forest root) =

   case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of

     ([bs@(Bracket_ _ _ _ _ _)]:_) -> bs

     (bss:_)                       -> Bracket_ wildCId 0 0 [] bss

@@ -79,7 +79,7 @@ bracketedTokn f@(Forest abs cnc forest root) =
                                                                        Just (DTyp _ cat _,_,_,_) -> cat

                                                  largs  = map (render forest) args

                                                  ltable = mkLinTable cnc isTrusted [] funid largs

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

+                                             in ((cat,fid),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),[e],([],listArray (0,0) [[LeafKS ts]]))

 

@@ -116,10 +116,10 @@ isLindefCId id
 -- 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.

-getAbsTrees :: Forest -> PArg -> Maybe Type -> Either [(FId,TcError)] [Expr]

-getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty =

+getAbsTrees :: Forest -> PArg -> Maybe Type -> Maybe Int -> Either [(FId,TcError)] [Expr]

+getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty dp =

   let (err,res) = runTcM abs (do e <- go Set.empty emptyScope (fmap (TTyp []) ty) arg

-                                 generateForForest (prove (Just 20)) e) fid IntMap.empty

+                                 generateForForest (prove dp) e) fid IntMap.empty

   in if null res

        then Left  (nub err)

        else Right (nubsort [e | (_,_,e) <- res])

diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index 3ed3d7a72..7c5b1a22f 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -52,25 +52,25 @@ data ParseOutput
                                    -- The list should be non-empty.

   | ParseIncomplete                -- ^ The sentence is not complete. Only partial output is produced

 

-parse :: PGF -> Language -> Type -> [Token] -> (ParseOutput,BracketedString)

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

+parse :: PGF -> Language -> Type -> Maybe Int -> [Token] -> (ParseOutput,BracketedString)

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

   where

-    loop ps []     = getParseOutput ps typ

+    loop ps []     = getParseOutput ps typ dp

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

                        Left  es -> case es of

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

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

                        Right ps -> loop ps ts

 

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

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

+parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> [String] -> (ParseOutput,BracketedString)

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

   where

-    accept ps []     = getParseOutput ps typ

+    accept ps []     = getParseOutput ps typ dp

     accept ps (t:ts) =

       case nextState ps (simpleParseInput t) of

         Right ps -> accept ps ts

         Left  es -> skip (recoveryStates open_typs es) ts

 

-    skip ps_map []     = getParseOutput (fst ps_map) typ

+    skip ps_map []     = getParseOutput (fst ps_map) typ dp

     skip ps_map (t:ts) =

       case Map.lookup t (snd ps_map) of

         Just ps -> accept ps ts

@@ -210,19 +210,19 @@ 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.

-getParseOutput :: ParseState -> Type -> (ParseOutput,BracketedString)

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

+getParseOutput :: ParseState -> Type -> Maybe Int -> (ParseOutput,BracketedString)

+getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) dp =

   let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq

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

 

       f     = Forest (abstract pgf) cnc (forest chart1) froots

       

-      bs    = linearizeWithBrackets f

+      bs    = linearizeWithBrackets dp f

                 

       res   | not (null es)   = ParseOk es

             | not (null errs) = TypeError errs

             | otherwise       = ParseIncomplete

-            where xs   = [getAbsTrees f (PArg [] fid) (Just ty) | (AK fid lbl) <- roots]

+            where xs   = [getAbsTrees f (PArg [] fid) (Just ty) dp | (AK fid lbl) <- roots]

                   es   = concat [es   | Right es   <- xs]

                   errs = concat [errs | Left  errs <- xs]