diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/tools/gftest/Grammar.hs | 76 | ||||
| -rw-r--r-- | src/tools/gftest/Main.hs | 11 | ||||
| -rw-r--r-- | src/tools/gftest/README.md | 16 |
3 files changed, 76 insertions, 27 deletions
diff --git a/src/tools/gftest/Grammar.hs b/src/tools/gftest/Grammar.hs index f8333e78b..f8c507acd 100644 --- a/src/tools/gftest/Grammar.hs +++ b/src/tools/gftest/Grammar.hs @@ -931,7 +931,8 @@ data Comparison = Comparison { funTree :: String, linTree :: [LinTree] } instance Show Comparison where show c = unlines $ funTree c : map showLinTree (linTree c) -dummyHole = App (Symbol "∅" [] ([], "") ([], CC Nothing 99999999)) [] +dummyCCat = CC Nothing 99999999 +dummyHole = App (Symbol "∅" [] ([], "") ([], dummyCCat)) [] showLinTree :: LinTree -> String showLinTree ((an,hl),(l1,t1),(l2,t2),(_l,[])) = unlines ["", an++hl, l1++t1, l2++t2] @@ -967,42 +968,65 @@ testFun :: Bool -> Grammar -> [Grammar] -> Cat -> Name -> Result testFun debug gr trans startcat funname = let test = testTree debug gr trans in unlines [ test t n cs - | (n,(t,cs)) <- zip [1..] trees_Ctxs ] + | (n,(t,cs)) <- zip [1..] testcase_ctxs ] where - trees_Ctxs = [ (t,commonCtxs) | t <- reducedTrees - , not $ null commonCtxs ] ++ - [ (t,uniqueCtxs) | t <- allTrees - , not $ null uniqueCtxs ] - + testcase_ctxs = M.toList $ M.fromListWith (++) $ uniqueTCs++commonTCs + + uniqueTCs = [ (testcase,uniqueCtxs) + | (testcase,ctxs) <- M.elems cat_testcase_ctxs + , let uniqueCtxs = deleteFirstsBy applyHole ctxs commonCtxs + , not $ null uniqueCtxs + ] + commonTCs = [ (App newTop subtrees,ctxs) + | (coe,cats,ctxs) <- coercion_goalcats_commonCtxs + , let testcases_ctxs = catMaybes [ M.lookup cat cat_testcase_ctxs + | cat <- cats ] + , not $ null testcases_ctxs + , let fstLen = \(a,_) (b,_) -> length (flatten a) `compare` length (flatten b) + , let (App tp subtrees,_) = -- pick smallest test case to be the representative + head $ sortBy fstLen testcases_ctxs + , let newTop = -- debug: put coerced contexts under a separate test case + if debug then tp { ctyp = (fst $ ctyp tp, coe)} else tp + ] + + -- Usually start category is a single {s:Str}, i.e. only one concrete category. + -- If you try this out for start categories with more parameters and fields, + -- you probably get wrong or missing results. (start:_) = ccats gr startcat + hl f c1 c2 = f (c1 dummyHole) == f (c2 dummyHole) -- applyHole = hl id -- TODO why doesn't this work for equality of contexts? applyHole = hl show -- :: (Tree -> Tree) -> (Tree -> Tree) -> Bool - goalcats = map ccatOf allTrees :: [ConcrCat] -- these are not coercions (coercions can't be goals) - - coercionsThatCoverAllGoalcats = [ (c,fs) - | (c,fs) <- contexts gr start - , all (coerces gr c) goalcats ] funs = case lookupSymbol gr funname of [] -> error $ "Function "++funname++" not found" fs -> fs - allTrees = treesUsingFun gr funs - ctxs = nubBy applyHole $ concatMap (contextsFor gr start) goalcats :: [Tree->Tree] - (commonCtxs,reducedTrees) = case coercionsThatCoverAllGoalcats of - [] -> ([],[]) -- no coercion covers all goal cats -> all contexts are relevant - cs -> (cCtxs,rTrees) -- all goal cats coerce into same -> find redundant contexts - where - (coe,coercedCtxs) = head coercionsThatCoverAllGoalcats - cCtxs = intersectBy applyHole ctxs coercedCtxs - rTrees = concat $ bestExamples (head funs) gr - [ [ App newTop subtrees ] - | (App tp subtrees) <- allTrees - , let newTop = tp { ctyp = (fst $ ctyp tp, coe)} ] - uniqueCtxs = deleteFirstsBy applyHole ctxs commonCtxs - showCtx f = let t = f dummyHole in show t ++ "\t\t\t" ++ showConcrFun gr (top t) + cat_testcase_ctxs = M.fromList + [ (goalcat,(testcase,ctxs)) + | testcase <- treesUsingFun gr funs + , let goalcat = ccatOf testcase -- never a coercion (coercions can't be goals) + , let ctxs = contextsFor gr start goalcat ] :: M.Map ConcrCat (Tree,[Tree->Tree]) + goalcats = M.keys cat_testcase_ctxs + + coercion_goalcats_commonCtxs = + [ (coe,coveredGoalcats,ctxs) + | coe@(CC Nothing _) <- S.toList $ nonEmptyCats gr -- only coercions + , let coveredGoalcats = filter (coerces gr coe) goalcats + , let ctxs = [ ctx -- Contexts that have + | ctx <- contextsFor gr start coe -- a) hole of coercion, and are + , any (applyHole ctx) allCtxs ] -- b) relevant for the function we test + , length coveredGoalcats >= 2 -- no use if the coercion covers 0 or 1 categories + , not $ null ctxs ] + + + allCtxs = [ ctx | (_,ctxs) <- M.elems cat_testcase_ctxs + , ctx <- ctxs ] :: [Tree->Tree] + + commonCtxs = nubBy applyHole [ ctx | (_,_,ctxs) <- coercion_goalcats_commonCtxs + , ctx <- ctxs ] :: [Tree->Tree] + testTree :: Bool -> Grammar -> [Grammar] -> Tree -> Int -> [Tree -> Tree] -> Result testTree debug gr tgrs t n ctxs = unlines diff --git a/src/tools/gftest/Main.hs b/src/tools/gftest/Main.hs index fcabb33c3..afcf17830 100644 --- a/src/tools/gftest/Main.hs +++ b/src/tools/gftest/Main.hs @@ -30,6 +30,7 @@ data GfTest , start_cat :: Maybe Cat , show_cats :: Bool , show_funs :: Bool + , funs_of_arity :: Maybe Int , show_coercions:: Bool , concr_string :: String @@ -57,7 +58,8 @@ gftest = GfTest &= help "Concrete syntax + optional translations" , tree = def &= A.typ "\"UseN tree_N\"" &= A.name "t" &= help "Test the given tree" - , function = def &= A.typ "UseN" &= help "Test the given function(s)" + , function = def &= A.typ "UseN" + &= A.name "f" &= help "Test the given function(s)" , category = def &= A.typ "NP" &= A.name "c" &= help "Test all functions with given goal category" , start_cat = def &= A.typ "Utt" @@ -65,6 +67,7 @@ gftest = GfTest , concr_string = def &= A.typ "the" &= help "Show all functions that include given string" , show_cats = def &= help "Show all available categories" , 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" , debug = def &= help "Show debug output" , equal_fields = def &= A.name "q" &= help "Show fields whose strings are always identical" @@ -184,6 +187,12 @@ main = do putStrLn "* Coercions in the grammar:" putStrLn $ unlines [ show cat++"--->"++show coe | (cat,coe) <- coercions gr ] + case funs_of_arity args of + Nothing -> return () + Just n -> do + putStrLn $ "* Functions in the grammar of arity " ++ show n ++ ":" + putStrLn $ unlines $ nub [ show s | s <- symbols gr, arity s == n ] + -- Show all functions that contain the given string -- (e.g. English "it" appears in DefArt, ImpersCl, it_Pron, …) case concr_string args of diff --git a/src/tools/gftest/README.md b/src/tools/gftest/README.md index a71017004..5134300fd 100644 --- a/src/tools/gftest/README.md +++ b/src/tools/gftest/README.md @@ -69,6 +69,7 @@ Common flags: -s --start-cat=Utt Use the given category as start category --show-cats Show all available categories --show-funs Show all available functions + --funs-of-arity=2 Show all functions of arity 2 --show-coercions Show coercions in the grammar --concr-string=the Show all functions that include given string -q --equal-fields Show fields whose strings are always identical @@ -428,3 +429,18 @@ For example: * AdAdv very_AdA (PositAdvAdj young_A) * PrepNP above_Prep (UsePron they_Pron) ``` + +### --funs-of-arity + +Show all functions of given arity (not up to). + +Example: + +``` +> gftest -g Phrasebook --funs-of-arity 3 +* Functions in the grammar of arity 3: +ADoVerbPhrasePlace +AModVerbPhrase +HowFarFromBy +QWhereModVerbPhrase +``` |