From a0849d8a5a54ef7321c291c0a6e55065f8cf0d5e Mon Sep 17 00:00:00 2001
From: Inari Listenmaa <inari.listenmaa@gmail.com>
Date: Thu, 24 May 2018 22:36:23 +0200
Subject: (gftest) Add --show-context + combine -o with -f,-c,-b

---
 src/tools/gftest/Grammar.hs | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

(limited to 'src/tools/gftest/Grammar.hs')

diff --git a/src/tools/gftest/Grammar.hs b/src/tools/gftest/Grammar.hs
index 4e6d0c6e9..0724987b2 100644
--- a/src/tools/gftest/Grammar.hs
+++ b/src/tools/gftest/Grammar.hs
@@ -9,7 +9,7 @@ module Grammar
     -- Categories, coercions
     , ccats, ccatOf, arity
     , coerces, uncoerce
-    , uncoerceAbsCat
+    , uncoerceAbsCat, mkCC
 
     -- Testing and comparison
     , testTree, testFun
@@ -17,7 +17,7 @@ module Grammar
     , treesUsingFun
 
     -- Contexts
-    , contextsFor
+    , contextsFor, dummyHole
 
     -- FEAT
     , featIth, featCard
@@ -327,6 +327,13 @@ toGrammar pgf langName =
   cseq2Either (I.SymCat x y) = Right (x,y)
   cseq2Either x              = Left (show x)
 
+
+mkCC gr fid = CC ccat fid
+ where ccat = case [ cat | (cat,bg,end,_) <- concrCats gr
+                         , fid `elem` [bg..end] ] of
+                [] -> Nothing -- means it's coercion
+                xs -> Just $ the xs
+
 -- parsing and reading trees
 mkTree :: Grammar -> PGF2.Expr -> Tree
 mkTree gr = disambTree . ambTree
@@ -983,9 +990,9 @@ testFun debug gr trans startcat funname =
    , 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 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
+           minimumBy 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
    ]
-- 
cgit v1.2.3