Merge remote-tracking branch 'upstream/master' into por

3 files changed, 75 insertions, 27 deletions

diff --git a/src/tools/gftest/Grammar.hs b/src/tools/gftest/Grammar.hs
index f8333e78b..4e6d0c6e9 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,64 @@ 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
+   ]
+
+  starts = ccats gr startcat
 
-  (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 = [ ctx | st <- starts
+                 , ctx <- contextsFor gr st 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 | st <- starts            -- Contexts that have
+                 , ctx <- contextsFor gr st 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
+```