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