diff options
Diffstat (limited to 'src/tools/gftest/Main.hs')
| -rw-r--r-- | src/tools/gftest/Main.hs | 139 |
1 files changed, 88 insertions, 51 deletions
diff --git a/src/tools/gftest/Main.hs b/src/tools/gftest/Main.hs index afcf17830..d68d78457 100644 --- a/src/tools/gftest/Main.hs +++ b/src/tools/gftest/Main.hs @@ -32,6 +32,7 @@ data GfTest , show_funs :: Bool , funs_of_arity :: Maybe Int , show_coercions:: Bool + , show_contexts :: Maybe Int , concr_string :: String -- Information about fields @@ -69,6 +70,7 @@ gftest = GfTest , show_funs = def &= help "Show all available functions" , funs_of_arity = def &= A.typ "2" &= help "Show all functions of arity 2" , show_coercions= def &= help "Show coercions in the grammar" + , show_contexts = def &= A.typ "8410" &= help "Show contexts for a given concrete type (given as FId)" , debug = def &= help "Show debug output" , equal_fields = def &= A.name "q" &= help "Show fields whose strings are always identical" , empty_fields = def &= A.name "e" &= help "Show fields whose strings are always empty" @@ -103,7 +105,7 @@ main = do gr <- readGrammar langName grName grTrans <- sequence [ readGrammar lt grName | lt <- langTrans ] - -- in case the language given by the user was not valid, use some language that *is* in the grammar + -- if language given by the user was not valid, use default language from Grammar let langName = concrLang gr let startcat = startCat gr `fromMaybe` start_cat args @@ -143,39 +145,66 @@ main = do , xs@(_:_) <- [ S.toList vs ] ] ----------------------------------------------------------------------------- -- Testing functions - + -- Test a tree - case tree args of - [] -> return () - t -> output $ testTree' (readTree gr t) 1 + let trees = case tree args of + [] -> [] + ts -> lines ts + output $ + unlines [ testTree' (readTree gr tree) 1 | tree <- trees ] -- Test a function - case category args of - [] -> return () - cat -> output $ unlines - [ testTree' t n - | (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]] + let substrs xs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') xs + let cats = case category args of + [] -> [] + cs -> if '*' `elem` cs + then let subs = substrs cs + in nub [ cat | (cat,_,_,_) <- concrCats gr + , all (`isInfixOf` cat) subs ] + else words cs + output $ + unlines [ testTree' t n + | cat <- cats + , (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]] -- Test all functions in a category - case function args of - [] -> return () - fs -> let funs = if '*' `elem` fs - then let subs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') fs - in nub [ f | s <- symbols gr, let f = show s - , all (`isInfixOf` f) subs - , arity s >= 1 ] - else words fs - in output $ unlines - [ testFun (debug args) gr grTrans startcat f - | f <- funs ] + let funs = case function args of + [] -> [] + fs -> if '*' `elem` fs + then let subs = substrs fs + in nub [ f | s <- symbols gr, let f = show s + , all (`isInfixOf` f) subs + , arity s >= 1 ] + else words fs + output $ + unlines [ testFun (debug args) gr grTrans startcat f + | f <- funs ] ----------------------------------------------------------------------------- -- Information about the grammar + -- Show contexts for a particular concrete category + case show_contexts args of + Nothing -> return () + Just fid -> mapM_ print + [ ctx dummyHole + | start <- ccats gr startcat + , ctx <- contextsFor gr start (mkCC gr fid) ] + -- Show available categories when (show_cats args) $ do putStrLn "* Categories in the grammar:" - putStrLn $ unlines [ cat | (cat,_,_,_) <- concrCats gr ] + let concrcats = sortBy (\(_,a,_,_) (_,b,_,_) -> a `compare` b) (concrCats gr) + sequence_ [ do putStrLn cat + when (debug args) $ + putStrLn $ unwords $ + [ " Compiles to concrete" ] ++ + [ "categories " ++ show bg++"—"++show end + | bg/=end ] ++ + [ "category " ++ show bg + | bg==end ] + | (cat,bg,end,_) <- concrcats + , end >= 0] -- Show available functions when (show_funs args) $ do @@ -279,6 +308,19 @@ main = do putStrLn $ "* " ++ show (featIth gr start n 0) putStrLn $ "* " ++ show (featIth gr start n (i-1)) + +------------------------------------------------------------------------------- +-- Read trees from treebank. + + treebank' <- + case treebank args of + Nothing -> return [] + Just fp -> do + tb <- readFile fp + return [ readTree gr s + | s <- lines tb ] + mapM_ print treebank' + ------------------------------------------------------------------------------- -- Comparison with old grammar @@ -308,36 +350,44 @@ main = do [ appendFile ccatChangeFile $ unlines $ ("* All concrete cats in the "++age++" grammar:"): - [ show cats | cats <- concrCats g ] + [ show cts | cts <- concrCats g ] | (g,age) <- [(ogr,"old"),(gr,"new")] ] putStrLn $ "Created file " ++ ccatChangeFile -------------------------------------------------------------------------- - -- print out tests for all functions in the changed cats - - let changedFuns = - if only_changed_cats args - then [ (cat,functionsByCat gr cat) | (cat,_,_,_) <- difcats ] - else - case category args of - [] -> case function args of - [] -> [ (cat,functionsByCat gr cat) - | (cat,_,_,_) <- concrCats gr ] - fn -> [ (snd $ Grammar.typ f, [f]) - | f <- lookupSymbol gr fn ] - ct -> [ (ct,functionsByCat gr ct) ] + -- Print out tests for all functions in the changed cats. + -- If -f, -c or --treebank specified, use them. + + let f cat = (cat, treesUsingFun gr $ functionsByCat gr cat) + + byCat = [ f cat | cat <- cats ] -- from command line arg -c + changed = [ f cat | (cat,_,_,_) <- difcats + , only_changed_cats args ] + byFun = [ (cat, treesUsingFun gr fs) + | funName <- funs -- comes from command line arg -f + , let fs@(s:_) = lookupSymbol gr funName + , let cat = snd $ Grammar.typ s ] + fromTb = [ (cat,[tree]) | tree <- treebank' + , let (CC (Just cat) _) = ccatOf tree ] + + treesToTest = + case concat [byFun, byCat, changed, fromTb] of + [] -> [ f cat -- nothing else specified -> test all functions + | (cat,_,_,_) <- concrCats gr ] + xs -> S.toList $ S.fromList xs + writeLinFile file grammar otherGrammar = do writeFile file "" putStrLn "Testing functions in… " diff <- concat `fmap` sequence [ do let cs = [ compareTree grammar otherGrammar grTrans t - | t <- treesUsingFun grammar funs ] + | t <- trees ] putStr $ cat ++ " \r" -- prevent lazy evaluation; make printout accurate appendFile ("/tmp/"++file) (unwords $ map show cs) return cs - | (cat,funs) <- changedFuns ] + | (cat,trees) <- treesToTest ] let relevantDiff = go [] [] diff where go res seen [] = res go res seen (Comparison f ls:cs) = @@ -379,19 +429,6 @@ main = do putStrLn $ "Created files " ++ langName ++ "-(old|new)-funs.org" -------------------------------------------------------------------------------- --- Read trees from treebank. No fancier functionality yet. - - case treebank args of - Nothing -> return () - Just fp -> do - tb <- readFile fp - sequence_ [ do let tree = readTree gr str - ccat = ccatOf tree - putStrLn $ unlines [ "", showTree tree ++ " : " ++ show ccat] - putStrLn $ linearize gr tree - | str <- lines tb ] - where |