fixes in parsing

6 files changed, 30 insertions, 23 deletions

diff --git a/src/GF/API.hs b/src/GF/API.hs
index ca97af146..62318c743 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -201,9 +201,10 @@ optLinearizeTree opts0 gr t = case getOptVal opts transferFun of
 
   lin mk
     | oElem showRecord opts = liftM prt . linearizeNoMark g c
-    | oElem tableLin opts   = liftM (unlines . map untok . prLinTable) . 
+    | oElem tableLin opts   = liftM (unlines . map untok . prLinTable True) . 
+                                allLinTables g c
+    | oElem showAll opts    = liftM (unlines . map untok . prLinTable False) . 
                                 allLinTables g c
-    | oElem showAll opts    = return . unlines . linTree2strings mk g c
     | otherwise             = return . unlines . optIntOrOne . linTree2strings mk g c
   g = grammar gr
   c = cncId gr
diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs
index edd35a18d..5c73bb594 100644
--- a/src/GF/CF/Profile.hs
+++ b/src/GF/CF/Profile.hs
@@ -56,20 +56,16 @@ tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
                    then Bad "arity error" 
                    else return xs'
            where xs' = [t | t@(ITerm _ _) <- xs]
-   unif [] = return $ IMeta
-   unif xs@(ITerm fp@(f,_) xx : ts) = do
-     let hs = [h | ITerm (h,_) _ <- ts]
-     testErr (all (==f) hs)                 -- if fails, hs must be nonempty
-        ("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
-     xx' <- mapM unifArg [0 .. length xx - 1]
-     return $ ITerm fp xx'
+   unif xs = case [t | t@(ITerm _ _) <- xs] of 
+    [] -> return $ IMeta
+    (ITerm fp@(f,_) xx : ts) -> do
+      let hs = [h | ITerm (h,_) _ <- ts, h /= f]
+      testErr (null hs)                 -- if fails, hs must be nonempty
+              ("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
+      xx' <- mapM unifArg [0 .. length xx - 1]
+      return $ ITerm fp xx'
     where
-      unifArg i = tryUnif [zz !! i | ITerm _ zz <- xs]
-   tryUnif xx = case [t | t@(ITerm _ _) <- xx] of
-     [] -> return IMeta
-     x:xs -> if all (==x) xs 
-             then return x 
-             else Bad "failed to unify"
+      unifArg i = unif [zz !! i | ITerm _ zz <- xs]
 
    mkBinds (xss,_) = mapM mkBind xss
    mkBind xs = do
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index dcfbc3b17..fff5f5fc1 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -230,6 +230,7 @@ flagDepth  = aOpt "depth"
 flagAlts   = aOpt "alts"
 flagLength = aOpt "length"
 flagNumber = aOpt "number"
+flagRawtrees = aOpt "rawtrees"
 
 caseYesNo :: Options -> OptFun -> Maybe Bool
 caseYesNo opts f = do
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index 03e8fafbd..971097d71 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/src/GF/Shell/ShellCommands.hs
@@ -105,6 +105,7 @@ testValidFlag st f x = case f of
   "lexer"   -> testInc customTokenizer
   "unlexer" -> testInc customUntokenizer
   "depth"   -> testN
+  "rawtrees"-> testN
   "parser"  -> testInc customParser
   "alts"    -> testN
   "transform" -> testInc customTermCommand
@@ -129,14 +130,14 @@ testValidFlag st f x = case f of
 optionsOfCommand :: Command -> ([String],[String])
 optionsOfCommand co = case co of
   CImport _ -> both "old v s opt src retain nocf nocheckcirc cflexer"
-                    "abs cnc res"
+                    "abs cnc res path"
   CRemoveLanguage _ -> none
   CEmptyState -> none
   CStripState -> none
   CTransformGrammar _ -> flags "printer"
   CConvertLatex _ -> none
-  CLinearize _ -> both "table struct record" "lang number unlexer"
-  CParse -> both "new n ign raw v" "cat lang lexer parser number"
+  CLinearize _ -> both "table struct record all" "lang number unlexer"
+  CParse -> both "new n ign raw v" "cat lang lexer parser number rawtrees"
   CTranslate _ _ -> opts "cat lexer parser"
   CGenerateRandom -> flags "cat lang number depth"
   CGenerateTrees -> both "metas" "depth alts cat lang number"
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
index 954500822..da1eefe09 100644
--- a/src/GF/UseGrammar/Linear.hs
+++ b/src/GF/UseGrammar/Linear.hs
@@ -161,10 +161,11 @@ allLinTables gr c t = do
    gets (ps,t) = liftM (curry id ps . cc . map str2strings) $ strsFromTerm t
    cc = concat . intersperse ["/"]
 
-prLinTable :: [[(Label,[([Patt],[String])])]] -> [String]
-prLinTable = concatMap prOne . concat where
-  prOne (lab,pss) = prt lab : map pr pss ----
-  pr (ps,ss) = unwords (map prt_ ps) +++ ":" +++ unwords ss
+prLinTable :: Bool -> [[(Label,[([Patt],[String])])]] -> [String]
+prLinTable pars = concatMap prOne . concat where
+  prOne (lab,pss) = (if pars then ((prt lab) :) else id) (map pr pss) ----
+  pr (ps,ss) = (if pars then ((unwords (map prt_ ps) +++ ":") +++)
+                             else id) (unwords ss)
 
 {-
 -- the value is a list of strs
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
index 380b58ae7..1e736d24e 100644
--- a/src/GF/UseGrammar/Parsing.hs
+++ b/src/GF/UseGrammar/Parsing.hs
@@ -71,7 +71,14 @@ trees2trms opts sg cn as ts0 info = do
       ts1 <- return (map cf2trm0 ts0) ----- should not need annot
       mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated; often fails
     _ -> do
-      (ts1,ss) <- checkErr $ mapErrN 10 postParse ts0
+      let num = optIntOrN opts flagRawtrees 99999
+      let (ts01,rest) = splitAt num ts0
+      if null rest then return () 
+         else checkWarn ("Warning: only" +++ show num +++ "raw parses out of" +++ 
+                          show (length ts0) +++ 
+                          "considered; use -rawtrees=<Int> to see more"
+                     )
+      (ts1,ss) <- checkErr $ mapErrN 10 postParse ts01
       if null ts1 then raise ss else return ()
       ts2 <- mapM (checkErr . annotate gr . refreshMetas [] . trExp) ts1 ---- 
       if forgive then return ts2 else do