GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-24 10:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Add more helpful printouts if no grammar provided

Browse Source
This commit is contained in:
Inari Listenmaa
2018-04-06 16:55:41 +02:00
parent b9d0012f6b
commit fcdcb23b35
1 changed files with 249 additions and 248 deletions
Download Patch File Download Diff File Expand all files Collapse all files

497
src/tools/gftest/Main.hs
View File

@@ -83,304 +83,305 @@ gftest = GfTest
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
args <- cmdArgs gftest args <- cmdArgs gftest
let (absName,grName) = case grammar args of case grammar args of
Just fp -> (takeFileName $ stripPGF fp, stripPGF fp ++ ".pgf") --doesn't matter if the name is given with or without ".pgf" Nothing -> putStrLn "Usage: `gftest -g <PGF grammar> [OPTIONS]'\nTo see available commands, run `gftest --help' or visit https://github.com/GrammaticalFramework/GF/blob/master/src/tools/gftest/README.md"
Nothing -> ("TestLang","TestLang.pgf") -- feel free to add your own default paths here Just fp -> do
(langName:langTrans) = case lang args of let (absName,grName) = (takeFileName $ stripPGF fp, stripPGF fp ++ ".pgf") --doesn't matter if the name is given with or without ".pgf"
[] -> [ absName ++ "Eng" ] -- if no English grammar found, it will be given a default value later
langs -> [ absName ++ t | t <- words langs ]
-- Read grammar and translations (langName:langTrans) = case lang args of
gr <- readGrammar langName grName [] -> [ absName ++ "Eng" ] -- if no English grammar found, it will be given a default value later
grTrans <- sequence [ readGrammar lt grName | lt <- langTrans ] langs -> [ absName ++ t | t <- words langs ]
-- in case the language given by the user was not valid, use some language that *is* in the grammar -- Read grammar and translations
let langName = concrLang gr gr <- readGrammar langName grName
grTrans <- sequence [ readGrammar lt grName | lt <- langTrans ]
let startcat = startCat gr `fromMaybe` start_cat args -- in case the language given by the user was not valid, use some language that *is* in the grammar
let langName = concrLang gr
testTree' t n = testTree False gr grTrans t n ctxs let startcat = startCat gr `fromMaybe` start_cat args
where
s = top t testTree' t n = testTree False gr grTrans t n ctxs
c = snd (ctyp s) where
ctxs = concat [ contextsFor gr sc c s = top t
c = snd (ctyp s)
ctxs = concat [ contextsFor gr sc c
| sc <- ccats gr startcat ] | sc <- ccats gr startcat ]
output = -- Print to stdout or write to a file output = -- Print to stdout or write to a file
if write_to_file args if write_to_file args
then \x -> then \x ->
do let fname = concat [ langName, "_", function args, category args, ".org" ] do let fname = concat [ langName, "_", function args, category args, ".org" ]
writeFile fname x writeFile fname x
putStrLn $ "Wrote results in " ++ fname putStrLn $ "Wrote results in " ++ fname
else putStrLn else putStrLn
intersectConcrCats cats_fields intersection = intersectConcrCats cats_fields intersection =
M.fromListWith intersection M.fromListWith intersection
([ (c,fields) ([ (c,fields)
| (CC (Just c) _,fields) <- cats_fields | (CC (Just c) _,fields) <- cats_fields
] ++ ] ++
[ (cat,fields) [ (cat,fields)
| (c@(CC Nothing _),fields) <- cats_fields | (c@(CC Nothing _),fields) <- cats_fields
, (CC (Just cat) _,coe) <- coercions gr , (CC (Just cat) _,coe) <- coercions gr
, c == coe , c == coe
]) ])
printStats tab = printStats tab =
sequence_ [ do putStrLn $ "==> " ++ c ++ ": " sequence_ [ do putStrLn $ "==> " ++ c ++ ": "
putStrLn $ unlines (map (fs!!) xs) putStrLn $ unlines (map (fs!!) xs)
| (c,vs) <- M.toList tab | (c,vs) <- M.toList tab
, let fs = fieldNames gr c , let fs = fieldNames gr c
, xs@(_:_) <- [ S.toList vs ] ] , xs@(_:_) <- [ S.toList vs ] ]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Testing functions -- Testing functions
-- Test a tree -- Test a tree
case tree args of case tree args of
[] -> return () [] -> return ()
t -> output $ testTree' (readTree gr t) 1 t -> output $ testTree' (readTree gr t) 1
-- Test a function -- Test a function
case category args of case category args of
[] -> return () [] -> return ()
cat -> output $ unlines cat -> output $ unlines
[ testTree' t n [ testTree' t n
| (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]] | (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]]
-- Test all functions in a category -- Test all functions in a category
case function args of case function args of
[] -> return () [] -> return ()
fs -> let funs = if '*' `elem` fs fs -> let funs = if '*' `elem` fs
then let subs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') fs then let subs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') fs
in nub [ f | s <- symbols gr, let f = show s in nub [ f | s <- symbols gr, let f = show s
, all (`isInfixOf` f) subs , all (`isInfixOf` f) subs
, arity s >= 1 ] , arity s >= 1 ]
else words fs else words fs
in output $ unlines in output $ unlines
[ testFun (debug args) gr grTrans startcat f [ testFun (debug args) gr grTrans startcat f
| f <- funs ] | f <- funs ]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Information about the grammar -- Information about the grammar
-- Show available categories -- Show available categories
when (show_cats args) $ do when (show_cats args) $ do
putStrLn "* Categories in the grammar:" putStrLn "* Categories in the grammar:"
putStrLn $ unlines [ cat | (cat,_,_,_) <- concrCats gr ] putStrLn $ unlines [ cat | (cat,_,_,_) <- concrCats gr ]
-- Show available functions -- Show available functions
when (show_funs args) $ do when (show_funs args) $ do
putStrLn "* Functions in the grammar:" putStrLn "* Functions in the grammar:"
putStrLn $ unlines $ nub [ show s | s <- symbols gr ] putStrLn $ unlines $ nub [ show s | s <- symbols gr ]
-- Show coercions in the grammar -- Show coercions in the grammar
when (show_coercions args) $ do when (show_coercions args) $ do
putStrLn "* Coercions in the grammar:" putStrLn "* Coercions in the grammar:"
putStrLn $ unlines [ show cat++"--->"++show coe | (cat,coe) <- coercions gr ] putStrLn $ unlines [ show cat++"--->"++show coe | (cat,coe) <- coercions gr ]
-- Show all functions that contain the given string -- Show all functions that contain the given string
-- (e.g. English "it" appears in DefArt, ImpersCl, it_Pron, …) -- (e.g. English "it" appears in DefArt, ImpersCl, it_Pron, …)
case concr_string args of case concr_string args of
[] -> return () [] -> return ()
str -> do putStrLn $ "### The following functions contain the string '" ++ str ++ "':" str -> do putStrLn $ "### The following functions contain the string '" ++ str ++ "':"
putStr "==> " putStr "==> "
putStrLn $ intercalate ", " $ nub [ name s | s <- hasConcrString gr str] putStrLn $ intercalate ", " $ nub [ name s | s <- hasConcrString gr str]
-- Show empty fields -- Show empty fields
when (empty_fields args) $ do when (empty_fields args) $ do
putStrLn "### Empty fields:" putStrLn "### Empty fields:"
printStats $ intersectConcrCats (emptyFields gr) S.intersection printStats $ intersectConcrCats (emptyFields gr) S.intersection
putStrLn "" putStrLn ""
-- Show erased trees -- Show erased trees
when (erased_trees args) $ do when (erased_trees args) $ do
putStrLn "* Erased trees:" putStrLn "* Erased trees:"
sequence_ sequence_
[ do putStrLn ("** " ++ intercalate "," erasedTrees ++ " : " ++ uncoerceAbsCat gr c) [ do putStrLn ("** " ++ intercalate "," erasedTrees ++ " : " ++ uncoerceAbsCat gr c)
sequence_ sequence_
[ do putStrLn ("- Tree: " ++ showTree t) [ do putStrLn ("- Tree: " ++ showTree t)
putStrLn ("- Lin: " ++ s) putStrLn ("- Lin: " ++ s)
putStrLn $ unlines putStrLn $ unlines
[ "- Trans: "++linearize tgr t [ "- Trans: "++linearize tgr t
| tgr <- grTrans ] | tgr <- grTrans ]
| t <- ts | t <- ts
, let s = linearize gr t , let s = linearize gr t
, let erasedSymbs = [ sym | sym <- flatten t, c==snd (ctyp sym) ] , let erasedSymbs = [ sym | sym <- flatten t, c==snd (ctyp sym) ]
] ]
| top <- take 1 $ ccats gr startcat | top <- take 1 $ ccats gr startcat
, (c,ts) <- forgets gr top , (c,ts) <- forgets gr top
, let erasedTrees = , let erasedTrees =
concat [ [ showTree subtree concat [ [ showTree subtree
| sym <- flatten t | sym <- flatten t
, let csym = snd (ctyp sym) , let csym = snd (ctyp sym)
, c == csym || coerces gr c csym , c == csym || coerces gr c csym
, let Just subtree = subTree sym t ] , let Just subtree = subTree sym t ]
| t <- ts ] | t <- ts ]
] ]
putStrLn "" putStrLn ""
-- Show unused fields -- Show unused fields
when (unused_fields args) $ do when (unused_fields args) $ do
let unused = let unused =
[ (c,S.fromList notUsed) [ (c,S.fromList notUsed)
| tp <- ccats gr startcat | tp <- ccats gr startcat
, (c,is) <- reachableFieldsFromTop gr tp , (c,is) <- reachableFieldsFromTop gr tp
, let ar = head $ , let ar = head $
[ length (seqs f) [ length (seqs f)
| f <- symbols gr, snd (ctyp f) == c ] ++ | f <- symbols gr, snd (ctyp f) == c ] ++
[ length (seqs f) [ length (seqs f)
| (b,a) <- coercions gr, a == c | (b,a) <- coercions gr, a == c
, f <- symbols gr, snd (ctyp f) == b ] , f <- symbols gr, snd (ctyp f) == b ]
notUsed = [ i | i <- [0..ar-1], i `notElem` is ] notUsed = [ i | i <- [0..ar-1], i `notElem` is ]
, not (null notUsed) , not (null notUsed)
] ]
putStrLn "### Unused fields:" putStrLn "### Unused fields:"
printStats $ intersectConcrCats unused S.intersection printStats $ intersectConcrCats unused S.intersection
putStrLn "" putStrLn ""
-- Show equal fields -- Show equal fields
let tab = intersectConcrCats (equalFields gr) (/\) let tab = intersectConcrCats (equalFields gr) (/\)
when (equal_fields args) $ do when (equal_fields args) $ do
putStrLn "### Equal fields:" putStrLn "### Equal fields:"
sequence_ sequence_
[ putStrLn ("==> " ++ c ++ ":\n" ++ cl) [ putStrLn ("==> " ++ c ++ ":\n" ++ cl)
| (c,eqr) <- M.toList tab | (c,eqr) <- M.toList tab
, let fs = fieldNames gr c , let fs = fieldNames gr c
, cl <- case eqr of , cl <- case eqr of
Top -> ["TOP"] Top -> ["TOP"]
Classes xss -> [ unlines (map (fs!!) xs) Classes xss -> [ unlines (map (fs!!) xs)
| xs@(_:_:_) <- xss ] | xs@(_:_:_) <- xss ]
] ]
putStrLn "" putStrLn ""
case count_trees args of case count_trees args of
Nothing -> return () Nothing -> return ()
Just n -> do let start = head $ ccats gr startcat Just n -> do let start = head $ ccats gr startcat
let i = featCard gr start n let i = featCard gr start n
let iTot = sum [ featCard gr start m | m <- [1..n] ] let iTot = sum [ featCard gr start m | m <- [1..n] ]
putStr $ "There are "++show iTot++" trees up to size "++show n putStr $ "There are "++show iTot++" trees up to size "++show n
putStrLn $ ", and "++show i++" of exactly size "++show n++".\nFor example: " putStrLn $ ", and "++show i++" of exactly size "++show n++".\nFor example: "
putStrLn $ "* " ++ show (featIth gr start n 0) putStrLn $ "* " ++ show (featIth gr start n 0)
putStrLn $ "* " ++ show (featIth gr start n (i-1)) putStrLn $ "* " ++ show (featIth gr start n (i-1))
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Comparison with old grammar -- Comparison with old grammar
case old_grammar args of case old_grammar args of
Nothing -> return () Nothing -> return ()
Just fp -> do Just fp -> do
oldgr <- readGrammar langName (stripPGF fp ++ ".pgf") oldgr <- readGrammar langName (stripPGF fp ++ ".pgf")
let ogr = oldgr { concrLang = concrLang oldgr ++ "-OLD" } let ogr = oldgr { concrLang = concrLang oldgr ++ "-OLD" }
difcats = diffCats ogr gr -- (acat, [#o, #n], olabels, nlabels) difcats = diffCats ogr gr -- (acat, [#o, #n], olabels, nlabels)
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- generate statistics of the changes in the concrete categories -- generate statistics of the changes in the concrete categories
let ccatChangeFile = langName ++ "-ccat-diff.org" let ccatChangeFile = langName ++ "-ccat-diff.org"
writeFile ccatChangeFile "" writeFile ccatChangeFile ""
sequence_
[ appendFile ccatChangeFile $ unlines
[ "* " ++ acat
, show o ++ " concrete categories in the old grammar,"
, show n ++ " concrete categories in the new grammar."
, "** Labels only in old (" ++ show (length ol) ++ "):"
, intercalate ", " ol
, "** Labels only in new (" ++ show (length nl) ++ "):"
, intercalate ", " nl ]
| (acat, [o,n], ol, nl) <- difcats ]
when (debug args) $
sequence_ sequence_
[ appendFile ccatChangeFile $ [ appendFile ccatChangeFile $ unlines
unlines $ [ "* " ++ acat
("* All concrete cats in the "++age++" grammar:"): , show o ++ " concrete categories in the old grammar,"
[ show cats | cats <- concrCats g ] , show n ++ " concrete categories in the new grammar."
| (g,age) <- [(ogr,"old"),(gr,"new")] ] , "** Labels only in old (" ++ show (length ol) ++ "):"
, intercalate ", " ol
, "** Labels only in new (" ++ show (length nl) ++ "):"
, intercalate ", " nl ]
| (acat, [o,n], ol, nl) <- difcats ]
when (debug args) $
sequence_
[ appendFile ccatChangeFile $
unlines $
("* All concrete cats in the "++age++" grammar:"):
[ show cats | cats <- concrCats g ]
| (g,age) <- [(ogr,"old"),(gr,"new")] ]
putStrLn $ "Created file " ++ ccatChangeFile putStrLn $ "Created file " ++ ccatChangeFile
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- print out tests for all functions in the changed cats -- print out tests for all functions in the changed cats
let changedFuns = let changedFuns =
if only_changed_cats args if only_changed_cats args
then [ (cat,functionsByCat gr cat) | (cat,_,_,_) <- difcats ] then [ (cat,functionsByCat gr cat) | (cat,_,_,_) <- difcats ]
else else
case category args of case category args of
[] -> case function args of [] -> case function args of
[] -> [ (cat,functionsByCat gr cat) [] -> [ (cat,functionsByCat gr cat)
| (cat,_,_,_) <- concrCats gr ] | (cat,_,_,_) <- concrCats gr ]
fn -> [ (snd $ Grammar.typ f, [f]) fn -> [ (snd $ Grammar.typ f, [f])
| f <- lookupSymbol gr fn ] | f <- lookupSymbol gr fn ]
ct -> [ (ct,functionsByCat gr ct) ] ct -> [ (ct,functionsByCat gr ct) ]
writeLinFile file grammar otherGrammar = do writeLinFile file grammar otherGrammar = do
writeFile file "" writeFile file ""
putStrLn "Testing functions in… " putStrLn "Testing functions in… "
diff <- concat `fmap` diff <- concat `fmap`
sequence [ do let cs = [ compareTree grammar otherGrammar grTrans t sequence [ do let cs = [ compareTree grammar otherGrammar grTrans t
| t <- treesUsingFun grammar funs ] | t <- treesUsingFun grammar funs ]
putStr $ cat ++ " \r" putStr $ cat ++ " \r"
-- prevent lazy evaluation; make printout accurate -- prevent lazy evaluation; make printout accurate
appendFile ("/tmp/"++file) (unwords $ map show cs) appendFile ("/tmp/"++file) (unwords $ map show cs)
return cs return cs
| (cat,funs) <- changedFuns ] | (cat,funs) <- changedFuns ]
let relevantDiff = go [] [] diff where let relevantDiff = go [] [] diff where
go res seen [] = res go res seen [] = res
go res seen (Comparison f ls:cs) = go res seen (Comparison f ls:cs) =
if null uniqLs then go res seen cs if null uniqLs then go res seen cs
else go (Comparison f uniqLs:res) (uniqLs++seen) cs else go (Comparison f uniqLs:res) (uniqLs++seen) cs
where uniqLs = deleteFirstsBy ctxEq ls seen where uniqLs = deleteFirstsBy ctxEq ls seen
ctxEq (a,_,_,_) (b,_,_,_) = a==b ctxEq (a,_,_,_) (b,_,_,_) = a==b
shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2) shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2)
writeFile file $ unlines writeFile file $ unlines
[ show comp [ show comp
| comp <- sortBy shorterTree relevantDiff ] | comp <- sortBy shorterTree relevantDiff ]
writeLinFile (langName ++ "-lin-diff.org") gr ogr writeLinFile (langName ++ "-lin-diff.org") gr ogr
putStrLn $ "Created file " ++ (langName ++ "-lin-diff.org") putStrLn $ "Created file " ++ (langName ++ "-lin-diff.org")
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
-- Print statistics about the functions: e.g., in the old grammar, -- Print statistics about the functions: e.g., in the old grammar,
-- all these 5 functions used to be in the same category: -- all these 5 functions used to be in the same category:
-- [DefArt,PossPron,no_Quant,this_Quant,that_Quant] -- [DefArt,PossPron,no_Quant,this_Quant,that_Quant]
-- but in the new grammar, they are split into two: -- but in the new grammar, they are split into two:
-- [DefArt,PossPron,no_Quant] and [this_Quant,that_Quant]. -- [DefArt,PossPron,no_Quant] and [this_Quant,that_Quant].
let groupFuns grammar = -- :: Grammar -> [[Symbol]] let groupFuns grammar = -- :: Grammar -> [[Symbol]]
concat [ groupBy sameCCat $ sortBy compareCCat funs concat [ groupBy sameCCat $ sortBy compareCCat funs
| (cat,_,_,_) <- difcats | (cat,_,_,_) <- difcats
, let funs = functionsByCat grammar cat ] , let funs = functionsByCat grammar cat ]
sortByName = sortBy (\s t -> name s `compare` name t)
writeFunFile groupedFuns file grammar = do
writeFile file ""
sequence_ [ do appendFile file "---\n"
appendFile file $ unlines
[ showConcrFun gr fun
| fun <- sortByName funs ]
| funs <- groupedFuns ]
sortByName = sortBy (\s t -> name s `compare` name t) writeFunFile (groupFuns ogr) (langName ++ "-old-funs.org") ogr
writeFunFile groupedFuns file grammar = do writeFunFile (groupFuns gr) (langName ++ "-new-funs.org") gr
writeFile file ""
sequence_ [ do appendFile file "---\n"
appendFile file $ unlines
[ showConcrFun gr fun
| fun <- sortByName funs ]
| funs <- groupedFuns ]
writeFunFile (groupFuns ogr) (langName ++ "-old-funs.org") ogr putStrLn $ "Created files " ++ langName ++ "-(old|new)-funs.org"
writeFunFile (groupFuns gr) (langName ++ "-new-funs.org") gr
putStrLn $ "Created files " ++ langName ++ "-(old|new)-funs.org"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Read trees from treebank. No fancier functionality yet. -- Read trees from treebank. No fancier functionality yet.
case treebank args of case treebank args of
Nothing -> return () Nothing -> return ()
Just fp -> do Just fp -> do
tb <- readFile fp tb <- readFile fp
sequence_ [ do let tree = readTree gr str sequence_ [ do let tree = readTree gr str
ccat = ccatOf tree ccat = ccatOf tree
putStrLn $ unlines [ "", showTree tree ++ " : " ++ show ccat] putStrLn $ unlines [ "", showTree tree ++ " : " ++ show ccat]
putStrLn $ linearize gr tree putStrLn $ linearize gr tree
| str <- lines tb ] | str <- lines tb ]
where where