From 53f7d4ecfb7b101c29115d3ba7285757808bbb9c Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 22 Jun 2004 12:33:31 +0000 Subject: [PATCH] fixes in parsing --- grammars/prelude/Prelude.gf | 2 +- src/GF/API.hs | 5 +++-- src/GF/CF/Profile.hs | 22 +++++++++------------- src/GF/Infra/Option.hs | 1 + src/GF/Shell/ShellCommands.hs | 7 ++++--- src/GF/UseGrammar/Linear.hs | 9 +++++---- src/GF/UseGrammar/Parsing.hs | 9 ++++++++- 7 files changed, 31 insertions(+), 24 deletions(-) diff --git a/grammars/prelude/Prelude.gf b/grammars/prelude/Prelude.gf index 4f8ad78c5..385a734ec 100644 --- a/grammars/prelude/Prelude.gf +++ b/grammars/prelude/Prelude.gf @@ -1,6 +1,6 @@ -- language-independent prelude facilities -resource Prelude = { +resource Prelude = open (Predef=Predef) in { oper -- to construct records and tables 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= 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