From 9d2b92dbc1d9e221ce180497cd7d04e0757650a9 Mon Sep 17 00:00:00 2001 From: Inari Listenmaa Date: Fri, 15 Jun 2018 14:31:21 +0200 Subject: [PATCH] Split gftest to a new repo --- src/tools/gf-tools.cabal | 21 +- src/tools/gftest/EqRel.hs | 32 - src/tools/gftest/FMap.hs | 62 -- src/tools/gftest/Grammar.hs | 1123 ----------------------------------- src/tools/gftest/Graph.hs | 193 ------ src/tools/gftest/Main.hs | 444 -------------- src/tools/gftest/Mu.hs | 113 ---- src/tools/gftest/README.md | 564 +----------------- 8 files changed, 2 insertions(+), 2550 deletions(-) delete mode 100644 src/tools/gftest/EqRel.hs delete mode 100644 src/tools/gftest/FMap.hs delete mode 100644 src/tools/gftest/Grammar.hs delete mode 100644 src/tools/gftest/Graph.hs delete mode 100644 src/tools/gftest/Main.hs delete mode 100644 src/tools/gftest/Mu.hs diff --git a/src/tools/gf-tools.cabal b/src/tools/gf-tools.cabal index 47ce0f01c..1f89f3a85 100644 --- a/src/tools/gf-tools.cabal +++ b/src/tools/gf-tools.cabal @@ -9,23 +9,4 @@ Executable gfdoc Executable htmls main-is: Htmls.hs - build-depends: base - - -library - hs-source-dirs: gftest - exposed-modules: Grammar - other-modules: Mu, Graph, FMap, EqRel - build-depends: base - , containers - , pgf2 - -executable gftest - hs-source-dirs: gftest - main-is: Main.hs - build-depends: base - , pgf2 - , cmdargs - , containers - , filepath - , gf-tools \ No newline at end of file + build-depends: base \ No newline at end of file diff --git a/src/tools/gftest/EqRel.hs b/src/tools/gftest/EqRel.hs deleted file mode 100644 index 823900ae0..000000000 --- a/src/tools/gftest/EqRel.hs +++ /dev/null @@ -1,32 +0,0 @@ -module EqRel where - -import qualified Data.Map as M -import Data.List ( sort ) - -data EqRel a = Top | Classes [[a]] deriving (Eq,Ord,Show) - -(/\) :: (Ord a) => EqRel a -> EqRel a -> EqRel a -Top /\ r = r -r /\ Top = r -Classes xss /\ Classes yss = Classes $ sort $ map sort $ concat -- maybe throw away singleton lists? - [ M.elems tabXs - | xs <- xss - , let tabXs = M.fromListWith (++) - [ (tabYs M.! x, [x]) - | x <- xs ] - ] - - where - tabYs = M.fromList [ (y,representative) - | ys <- yss - , let representative = head ys - , y <- ys ] - -basic :: (Ord a) => [a] -> EqRel Int -basic xs = Classes $ sort $ map sort $ M.elems $ M.fromListWith (++) - [ (x,[i]) | (x,i) <- zip xs [0..] ] - -rep :: EqRel Int -> Int -> Int -rep Top j = 0 -rep (Classes xss) j = head [ head xs | xs <- xss, j `elem` xs ] - diff --git a/src/tools/gftest/FMap.hs b/src/tools/gftest/FMap.hs deleted file mode 100644 index f3a511706..000000000 --- a/src/tools/gftest/FMap.hs +++ /dev/null @@ -1,62 +0,0 @@ -module FMap where - --------------------------------------------------------------------------------- --- implementation - -data FMap a b = Ask a (FMap a b) (FMap a b) | Nil | Answer b - deriving ( Eq, Ord, Show ) - -toList :: FMap a b -> [([a],b)] -toList t = go [([],t)] - where - go [] = [] - go ((xs,Ask x yes no):xts) = go ((x:xs,yes):(xs,no):xts) - go ((_ ,Nil) :xts) = go xts - go ((xs,Answer z) :xts) = (reverse xs,z) : go xts - -isNil :: FMap a b -> Bool -isNil = null . toList - -nil :: FMap a b -nil = Nil - -unit :: [a] -> b -> FMap a b -unit [] y = Answer y -unit (x:xs) y = Ask x (unit xs y) Nil - -covers :: Ord a => FMap a b -> [a] -> Bool -Nil `covers` _ = False -_ `covers` [] = True -Answer _ `covers` _ = False -Ask x yes no `covers` zs@(y:ys) = - case x `compare` y of - LT -> (yes `covers` zs) || (no `covers` zs) - EQ -> yes `covers` ys - GT -> False - -ask :: a -> FMap a b -> FMap a b -> FMap a b -ask x Nil Nil = Nil -ask x s t = Ask x s t - -del :: Ord a => [a] -> FMap a b -> FMap a b -del _ Nil = Nil -del _ (Answer _) = Nil -del [] (Ask x yes no) = ask x yes (del [] no) -del (x:xs) t@(Ask y yes no) = - case x `compare` y of - LT -> del xs t - EQ -> ask y (del xs yes) (del xs no) - GT -> ask y yes (del (x:xs) no) - -add :: Ord a => [a] -> b -> FMap a b -> FMap a b -add [] y Nil = Answer y -add (x:xs) y Nil = Ask x (add xs y Nil) Nil -add xs@(_:_) y (Answer _) = add xs y Nil -add (x:xs) y t@(Ask z yes no) = - case x `compare` z of - LT -> Ask x (add xs y Nil) (del xs t) - EQ -> Ask x (add xs y yes) (del xs no) - GT -> Ask z yes (add (x:xs) y no) - --------------------------------------------------------------------------------- - diff --git a/src/tools/gftest/Grammar.hs b/src/tools/gftest/Grammar.hs deleted file mode 100644 index a72bc1686..000000000 --- a/src/tools/gftest/Grammar.hs +++ /dev/null @@ -1,1123 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module Grammar - ( Grammar(..), readGrammar - , Tree, top, Symbol(..), showTree - , Cat, ConcrCat(..) - , Lang, Name - - -- Categories, coercions - , ccats, ccatOf, arity - , coerces, uncoerce - , uncoerceAbsCat, mkCC - - -- Testing and comparison - , testTree, testFun - , compareTree, Comparison(..) - , treesUsingFun - - -- Contexts - , contextsFor, dummyHole - - -- FEAT - , featIth, featCard - - -- Fields - , forgets, reachableFieldsFromTop - , emptyFields, equalFields, fieldNames - - -- misc - , showConcrFun, subTree, flatten - , diffCats, hasConcrString -) where - -import Data.Either ( lefts ) -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Char -import qualified Data.Set as S -import qualified Mu -import qualified FMap as F -import qualified Data.Tree as T -import EqRel - -import GHC.Exts ( the ) -import Debug.Trace - -import qualified PGF2 -import qualified PGF2.Internal as I - --------------------------------------------------------------------------------- --- grammar types - --- name - -type Name = String - --- concrete category - -type Cat = PGF2.Cat -- i.e. String - -data ConcrCat = CC (Maybe Cat) I.FId -- i.e. Int - deriving ( Eq ) - -instance Show ConcrCat where - show (CC (Just cat) fid) = cat ++ "_" ++ show fid - show (CC Nothing fid) = "_" ++ show fid - -instance Ord ConcrCat where - (CC _ fid1) `compare` (CC _ fid2) = fid1 `compare` fid2 - -ccatOf :: Tree -> ConcrCat -ccatOf (App tp _) = snd (ctyp tp) - --- tree - -data RoseTree a - = App { top :: a, args :: [RoseTree a] } - deriving ( Eq, Ord ) - --- from http://hackage.haskell.org/package/containers-0.5.11.0/docs/src/Data.Tree.html#foldTree -foldTree :: (a -> [b] -> b) -> RoseTree a -> b -foldTree f = go where - go (App x ts) = f x (map go ts) - -flatten :: RoseTree a -> [a] -flatten (App tp as) = tp : concatMap flatten as - -type Tree = RoseTree Symbol -type AmbTree = RoseTree [Symbol] -- used as an intermediate category for parsing - -instance Show Tree where - show = showTree - -showTree :: Tree -> String -showTree (App a []) = show a -showTree (App f xs) = unwords (show f : map showTreeArg xs) - where showTreeArg (App a []) = show a - showTreeArg t = "(" ++ showTree t ++ ")" - -subTree :: Symbol -> Tree -> Maybe Tree -subTree symb t@(App tp tr) - | symb==tp = Just t - | otherwise = listToMaybe $ mapMaybe (subTree symb) tr - --- symbol - -type SeqId = Int - -data Symbol - = Symbol - { name :: Name - , seqs :: [SeqId] - , typ :: ([Cat], Cat) - , ctyp :: ([ConcrCat],ConcrCat) - } - deriving ( Eq, Ord ) - -instance Show Symbol where - show = name - -arity :: Symbol -> Int -arity = length . fst . ctyp - -hole :: ConcrCat -> Symbol -hole c = Symbol (show c) [] ([], "") ([],c) - -showConcrFun :: Grammar -> Symbol -> String -showConcrFun gr detCN = show detCN ++ " : " ++ args ++ show np_209 - where - (dets_cns,np_209) = ctyp detCN - args = concatMap (\x -> show x ++ " → ") dets_cns - --- grammar - -type Lang = String - -data Grammar - = Grammar - { - concrLang :: Lang - , parse :: String -> [Tree] - , readTree :: String -> Tree - , linearize :: Tree -> String - , tabularLin :: Tree -> [(String,String)] - , concrCats :: [(PGF2.Cat,I.FId,I.FId,[String])] - , coercions :: [(ConcrCat,ConcrCat)] - , contextsTab :: M.Map ConcrCat (M.Map ConcrCat [Tree -> Tree]) - , startCat :: Cat - , symbols :: [Symbol] - , lookupSymbol :: String -> [Symbol] - , functionsByCat :: Cat -> [Symbol] - , concrSeqs :: SeqId -> [Either String (Int,Int)] - , feat :: FEAT - , nonEmptyCats :: S.Set ConcrCat - , allCats :: [ConcrCat] - } - -fieldNames :: Grammar -> Cat -> [String] -fieldNames gr c = map fst . tabularLin gr $ t - where - t:_ = [ t - | f <- functionsByCat gr c - , let (_,c') = ctyp f - , c' `S.member` nonEmptyCats gr - , t <- featAll gr c' - ] - - --------------------------------------------------------------------------------- --- grammar - -readGrammar :: Lang -> FilePath -> IO Grammar -readGrammar lang file = - do pgf <- PGF2.readPGF file - return (toGrammar pgf lang) - -toGrammar :: PGF2.PGF -> Lang -> Grammar -toGrammar pgf langName = - let gr = - Grammar - { concrLang = lname - - , parse = \s -> - case PGF2.parse lang (PGF2.startCat pgf) s of - PGF2.ParseOk es_fs -> map (mkTree gr.fst) es_fs - PGF2.ParseFailed i s -> error s - PGF2.ParseIncomplete -> error "Incomplete parse" - - , readTree = \s -> - case PGF2.readExpr s of - Just t -> mkTree gr t - Nothing -> error "readTree: no parse" - - , linearize = \t -> - PGF2.linearize lang (mkExpr t) - - , tabularLin = \t -> - PGF2.tabularLinearize lang (mkExpr t) - - , startCat = - mkCat (PGF2.startCat pgf) - - , concrCats = - I.concrCategories lang - - , symbols = - [ Symbol { - name = nm, - seqs = sqs, - ctyp = (argsCC, goalCC), - typ = (map (uncoerceAbsCat gr) argsCC, goalcat) - } - | (goalcat,bg,end,_) <- I.concrCategories lang - , goalfid <- [bg..end] - , I.PApply funId pargs <- I.concrProductions lang goalfid - , let goalCC = CC (Just goalcat) goalfid - , let argsCC = [ mkCC argfid | I.PArg _ argfid <- pargs ] - , let (nm,sqs) = I.concrFunction lang funId ] - - , lookupSymbol = lookupAll (symb2table `map` symbols gr) - - , functionsByCat = \c -> - [ symb - | symb <- symbols gr - , snd (typ symb) == c - , snd (ctyp symb) `elem` nonEmptyCats gr ] - - , coercions = - [ ( mkCC cfid, CC Nothing afid ) - | afid <- [0..I.concrTotalCats lang] - , I.PCoerce cfid <- I.concrProductions lang afid ] - - , contextsTab = - M.fromList - [ (top, M.fromList (contexts gr top)) - | top <- allCats gr ] - - , concrSeqs = - map cseq2Either . I.concrSequence lang - - , feat = - mkFEAT gr - - , allCats = S.toList $ S.fromList $ - [ a | f <- symbols gr, let (args,goal) = ctyp f - , a <- goal:args - ] ++ - [ c | (cat,coe) <- coercions gr - , c <- [coe,cat] - ] - , nonEmptyCats = S.fromList - [ c - | let -- all functions, organized by result type - funs = M.fromListWith (++) $ - [ (cat,[Right f]) - | f <- symbols gr - , let (_,cat) = ctyp f - ] ++ - [ (coe,[Left cat]) - | (cat,coe) <- coercions gr - ] - - -- all categories, with their dependencies - defs = - [ if or [ arity f == 0 | Right f <- fs ] - then (c, [], \_ -> True) -- has a word - else (c, ys, h) -- no word - | c <- allCats gr - , let -- relevant functions for c - fs = fromMaybe [] (M.lookup c funs) - - -- categories we depend on - ys = S.toList $ S.fromList $ - [ cat | Right f <- fs, cat <- fst (ctyp f) ] ++ - [ cat | Left cat <- fs ] - - -- compute if we're empty, given the emptiness of others - h bs = or $ - [ and [ tab M.! a | a <- args ] - | Right f <- fs - , let (args,_) = ctyp f - ] ++ - [ tab M.! cat - | Left cat <- fs - ] - where - tab = M.fromList (ys `zip` bs) - ] - , (c,True) <- allCats gr `zip` Mu.mu False defs (allCats gr) - ] - - - - } - in gr - where - -- language - (lang,lname) = case M.lookup langName (PGF2.languages pgf) of - Just la -> (la,langName) - Nothing -> let (defName,defGr) = head $ M.assocs $ PGF2.languages pgf - msg = "no grammar found with name " ++ langName ++ - ", using " ++ defName - in trace msg (defGr,defName) - - -- categories and expressions - mkCat tp = cat where (_, cat, _) = PGF2.unType tp - - mkExpr (App n []) | not (null s) && all isDigit s = - PGF2.mkInt (read s) - where - s = show n - - mkExpr (App f xs) = - PGF2.mkApp (name f) [ mkExpr x | x <- xs ] - - mkCC fid = CC ccat fid - where ccat = case [ cat | (cat,bg,end,_) <- I.concrCategories lang - , fid `elem` [bg..end] ] of - [] -> Nothing -- means it's coercion - xs -> Just $ the xs - - -- misc - symb2table s = (s, name s) - - cseq2Either (I.SymKS tok) = Left tok - 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 - - where - ambTree t = -- :: PGF2.Expr -> AmbTree - case PGF2.unApp t of - Just (f,xs) -> App (lookupSymbol gr f) [ ambTree x | x <- xs ] - Nothing -> error (PGF2.showExpr [] t) - - disambTree at = -- :: AmbTree -> Tree - case foldTree reduce at of - App [x] ts -> App x [ disambTree t | t <- ts ] - App _ _ts -> error "mkTree: invalid tree" - - reduce fs as = -- :: [Symbol] -> [AmbTree] -> AmbTree - let red = [ symbol | symbol <- fs - , let argTypes = - uncoerce gr `map` fst (ctyp symbol) - , let goalTypes = - uncoerce gr `map` [ snd (ctyp s) | App [s] _ <- as ] - -- there should be only one symbol in (still ambiguous) fs - -- whose argument type matches its (already unambiguous) subtrees - , and [ intersect a r /= [] - | (a,r) <- zip argTypes goalTypes ] ] - in case red of - [x] -> App [x] as - _ -> App fs as - --- categories and coercions -ccats :: Grammar -> Cat -> [ConcrCat] -ccats gr utt = [ cc - | cc@(CC (Just cat) _) <- S.toList (nonEmptyCats gr) - , cat == utt ] - -uncoerceAbsCat :: Grammar -> ConcrCat -> Cat -uncoerceAbsCat gr c = case c of - CC (Just cat) _ -> cat - CC Nothing _ -> the [ uncoerceAbsCat gr x | x <- uncoerce gr c ] - -uncoerce :: Grammar -> ConcrCat -> [ConcrCat] -uncoerce gr c = case c of - CC Nothing _ -> lookupAll (coercions gr) c - _ -> [c] - -coerces :: Grammar -> ConcrCat -> ConcrCat -> Bool -coerces gr coe cat = (cat,coe) `elem` coercions gr - -lookupAll :: (Eq a) => [(b,a)] -> a -> [b] -lookupAll kvs key = [ v | (v,k) <- kvs, k==key ] - -singleton [x] = True -singleton xs = False - --------------------------------------------------------------------------------- --- compute categories reachable from S - -reachableCatsFromTop :: Grammar -> ConcrCat -> [ConcrCat] -reachableCatsFromTop gr top = [ c | (c,True) <- cs `zip` rs ] - where - rs = Mu.mu False defs cs - cs = S.toList (nonEmptyCats gr) - - defs = - [ if c == top - then (c, [], \_ -> True) - else (c, ys, or) - | c <- cs - , let ys = S.toList $ S.fromList $ - [ b - | f <- symbols gr - , let (as,b) = ctyp f - , all (`S.member` nonEmptyCats gr) as - , c `elem` as - ] ++ - [ b - | (a,b) <- coercions gr - , a == c - , b `S.member` nonEmptyCats gr - ] - ] - -reachableFieldsFromTop :: Grammar -> ConcrCat -> [(ConcrCat,S.Set Int)] -reachableFieldsFromTop gr top = cs `zip` rs - where - rs = Mu.mu S.empty defs cs - cs = S.toList (nonEmptyCats gr) - - defs = - [ if c == top - then (c, [], \_ -> S.fromList [0]) -- this assumes the top only has one field - else (c, ys, h) - | c <- cs - , let fs = [ Right (f,k) - | f <- symbols gr - , let (as,_) = ctyp f - , all (`S.member` nonEmptyCats gr) as - , (a,k) <- as `zip` [0..] - , c == a - ] ++ - [ Left b - | (a,b) <- coercions gr - , a == c - , b `S.member` nonEmptyCats gr - ] - - ys = S.toList $ S.fromList - [ case f of - Right (f,_) -> snd (ctyp f) - Left b -> b - | f <- fs - ] - - h rs = S.unions - [ case f of - Right (f,k) -> apply (f,k) (args M.! snd (ctyp f)) - Left b -> args M.! b - | f <- fs - ] - where - args = M.fromList (ys `zip` rs) - ] - - apply (f,k) r = - S.fromList - [ j - | (sq,i) <- seqs f `zip` [0..] - , i `S.member` r - , Right (k',j) <- concrSeqs gr sq - , k' == k - ] - --------------------------------------------------------------------------------- --- analyzing contexts - -equalFields :: Grammar -> [(ConcrCat,EqRel Int)] -equalFields gr = cs `zip` eqrels - where - eqrels = Mu.mu Top defs cs - cs = S.toList (nonEmptyCats gr) - - defs = - [ (c, depcats, h) - | c <- cs - -- fs = everything that has c as a goal category - -- there's two possibilities: - , let fs = -- 1) c is not a coercion: functions can have c as a goal category - [ Right f - | f <- symbols gr - , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) - , c == snd (ctyp f) - ] ++ - -- 2) c is a coercion: here's a list of (nonempty) categories c uncoerces into - [ Left cat - | (cat,coe) <- coercions gr - , coe == c - , cat `S.member` nonEmptyCats gr - ] - - -- all the categories c depends on - depcats = S.toList $ S.fromList $ concat - [ case f of - Right f -> fst (ctyp f) -- 1) if c is not a coercion: - -- all arg cats of the functions with c as goal cat - Left cat -> [cat] -- 2) if c is a coercion: just the cats that it uncoerces into - | f <- fs - ] - - -- Function to give to mu: - -- computes the equivalence relation, given the eq.rels of its arguments - h rs = foldr (/\) Top $ [ apply f eqs - | Right f <- fs - , let eqs = map (args M.!) (fst $ ctyp f) - ] ++ - [ args M.! cat - | Left cat <- fs - ] - where - args = M.fromList (depcats `zip` rs) - ] - where - apply f eqs = - basic [ concatMap lin (concrSeqs gr sq) - | sq <- seqs f - ] - where - lin (Left str) = [ str | not (null str) ] - lin (Right (i,j)) = [ show i ++ "#" ++ show (rep (eqs !! i) j) ] - -contextsFor :: Grammar -> ConcrCat -> ConcrCat -> [Tree -> Tree] -contextsFor gr top hole = [] `fromMaybe` M.lookup hole (contextsTab gr M.! top) - -contexts :: Grammar -> ConcrCat -> [(ConcrCat,[Tree -> Tree])] -contexts gr top = - [ (c, map (path2context . reverse . snd) (F.toList paths)) - | (c, paths) <- cs `zip` pathss - ] - where - pathss = Mu.muDiff F.nil F.isNil dif uni defs cs - cs = S.toList (nonEmptyCats gr) - - -- all symbols with at least one argument, and only good arguments - goodSyms = - [ f - | f <- symbols gr - , arity f >= 1 - , snd (ctyp f) `S.member` nonEmptyCats gr - , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) - ] - - -- definitions table for fixpoint iteration - fm1 `dif` fm2 = - [ d | d@(xs,_) <- F.toList fm1, not (fm2 `F.covers` xs) ] `ins` F.nil - - fm1 `uni` fm2 = - F.toList fm1 `ins` fm2 - - paths `ins` fm = - foldl collect fm - . map snd - . sort - $ [ (size p, p) | p <- paths ] - where - collect fm (str,p) - | fm `F.covers` str = fm - | otherwise = F.add str p fm - - size (_,p) = - sum [ if i == j then 1 else smallest gr t - | (f,i) <- p - , let (ts,_) = ctyp f - , (t,j) <- ts `zip` [0..] - ] - - defs = - [ if c == top - then (c, [], \_ -> F.unit [0] []) - else (c, ys, h) - | c <- cs - - -- everything that uses c in one of the two ways: - , let fs = -- 1) Functions that take c as the kth argument - [ Right (f,k) - | f <- goodSyms - , (t,k) <- fst (ctyp f) `zip` [0..] - , t == c - ] ++ - -- 2) coercions that uncoerce to c - [ Left coe - | (cat,coe) <- coercions gr - , cat == c - , coe `S.member` nonEmptyCats gr - ] - - -- goal categories for c - ys = S.toList $ S.fromList $ - [ case f of - Right (f,_) -> snd (ctyp f) -- 1) goal category of the function that uses c - Left coe -> coe -- 2) (category of the) coercion that uncoerces to c - | f <- fs - ] - - -- function to give to Mu - h ps = ([ (apply (f,k) str, (f,k):fis) - | Right (f,k) <- fs - , (str,fis) <- args M.! snd (ctyp f) - ] ++ - [ q - | Left a <- fs - , q <- args M.! a - ]) `ins` F.nil - where - args = M.fromList (ys `zip` map F.toList ps) - ] - where -- fields of B that make it to the top - apply :: (Symbol, Int) -> [Int] -> [Int] -- fields of A that make it to the top - apply (f,k) is = - S.toList $ S.fromList $ - [ y - | (sq,i) <- seqs f `zip` [0..] - , i `elem` is - , Right (x,y) <- concrSeqs gr sq - , x == k - ] - - path2context [] x = x - path2context ((f,i):fis) x = - App f - [ if j == i - then path2context fis x - else head (featAll gr t) - | (t,j) <- fst (ctyp f) `zip` [0..] - ] - -forgets :: Grammar -> ConcrCat -> [(ConcrCat,[Tree])] -forgets gr top = - filter (not . null . snd) - [ (c, [ path2context (reverse p) (head (featAll gr c)) - | (is,p) <- F.toList paths - , length is == fields c -- all indices forgotten - ] - ) - | (c, paths) <- cs `zip` pathss - ] - where - pathss = Mu.muDiff F.nil F.isNil dif uni defs cs - cs = S.toList (nonEmptyCats gr) - - -- all symbols with at least one argument, and only good arguments - goodSyms = - [ f - | f <- symbols gr - , arity f >= 1 - , snd (ctyp f) `S.member` nonEmptyCats gr - , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) - ] - - fieldsTab = - M.fromList $ - [ (b, length (seqs f)) - | f <- symbols gr - , let (as,b) = ctyp f - ] - - fields a = - head $ - [ n - | c <- a : [ b | (b,a') <- coercions gr, a' == a ] - , Just n <- [M.lookup c fieldsTab] - ] ++ - error (show a ++ " has no function creating it") - - -- definitions table for fixpoint iteration - fm1 `dif` fm2 = - [ d | d@(xs,_) <- F.toList fm1, not (fm2 `F.covers` xs) ] `ins` F.nil - - fm1 `uni` fm2 = - F.toList fm1 `ins` fm2 - - paths `ins` fm = - foldl collect fm - . map snd - . sort - $ [ (size p, p) | p <- paths ] - where - collect fm (str,p) - | fm `F.covers` str = fm - | otherwise = F.add str p fm - - size (_,p) = - sum [ if i == j then 1 else smallest gr t - | (f,i) <- p - , let (ts,_) = ctyp f - , (t,j) <- ts `zip` [0..] - ] - - defs = - [ if c == top - then (c, [], \_ -> F.unit [] []) - else (c, ys, h) - | c <- cs - - -- everything that uses c in one of the two ways: - , let fs = -- 1) Functions that take c as the kth argument - [ Right (f,k) - | f <- goodSyms - , (t,k) <- fst (ctyp f) `zip` [0..] - , t == c - ] ++ - -- 2) coercions that uncoerce to c - [ Left coe - | (cat,coe) <- coercions gr - , cat == c - , coe `S.member` nonEmptyCats gr - ] - - -- goal categories for c - ys = S.toList $ S.fromList $ - [ case f of - Right (f,_) -> snd (ctyp f) - Left coe -> coe - | f <- fs - ] - - h ps = ([ (apply (f,k) str, (f,k):fis) - | Right (f,k) <- fs - , (str,fis) <- args M.! snd (ctyp f) - , length str < fields c - ] ++ - [ q - | Left a <- fs - , q@(str,_) <- args M.! a - , length str < fields c - ]) `ins` F.nil - where - args = M.fromList (ys `zip` map F.toList ps) - ] - where - apply :: (Symbol, Int) -> [Int] -> [Int] - apply (f,k) is = - [ y - | y <- [0..fields (fst (ctyp f) !! k)-1] - , y `S.notMember` used - ] - where - used = S.fromList $ - [ y - | (sq,i) <- seqs f `zip` [0..] - , i `notElem` is - , Right (x,y) <- concrSeqs gr sq - , x == k - ] - - path2context [] x = x - path2context ((f,i):fis) x = - App f - [ if j == i - then path2context fis x - else head (featAll gr t) - | (t,j) <- fst (ctyp f) `zip` [0..] - ] - ---traceLength s xs = trace (s ++ ":" ++ show (length xs)) xs - -emptyFields :: Grammar -> [(ConcrCat,S.Set Int)] -emptyFields gr = cs `zip` fields - where - cs = S.toList (nonEmptyCats gr) - fields = Mu.mu (S.fromList [0..99999]) defs cs - - defs = - [ (c, ys, h) - | c <- cs - , let fs = -- everything that has c as a goal category - [ Right f - | f <- symbols gr - , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) - , c == snd (ctyp f) - ] ++ - -- 2) c is a coercion: here's a list of (nonempty) categories c uncoerces into - [ Left cat - | (cat,coe) <- coercions gr - , coe == c - , cat `S.member` nonEmptyCats gr - ] - - -- all the categories c depends on - ys = S.toList $ S.fromList $ concat - [ case f of - Right f -> fst (ctyp f) - Left cat -> [cat] - | f <- fs - ] - - -- Function to give to mu: - -- computes whether the field is empty, given the emptiness of its arguments. - -- a field in C is empty, if there's some function - -- f :: A -> B -> C - -- and it uses only empty fields from A and B. - -- we're only looking at a given C at a time, - - h :: [S.Set Int] -> S.Set Int - h vs = foldr1 S.intersection $ [ apply f emptyfields - | Right f <- fs - , let emptyfields = map (args M.!) (fst $ ctyp f) - ] ++ - [ args M.! cat - | Left cat <- fs - ] - where - args :: M.Map ConcrCat (S.Set Int) -- empty fields of each category - args = M.fromList (ys `zip` vs) - ] - where - --apply :: Symbol -- some f :: A -> B - -- -> [S.Set Int] -- for each argument type to f, which fields are empty - -- -> S.Set Int -- empty fields in B - apply f empties = - S.fromList - [ i - | (sq,i) <- seqs f `zip` [0..] - , let isEmpty s = case s of - Left str -> str == "" - Right (k,j) -> j `S.member` (empties !! k) - , all isEmpty (concrSeqs gr sq) - ] --------------------------------------------------------------------------------- --- FEAT-style generator magic - -type FEAT = [ConcrCat] -> Int -> (Integer, Integer -> [Tree]) - -smallest :: Grammar -> ConcrCat -> Int -smallest gr c = head [ n | n <- [0..], featCard gr c n > 0 ] - --- compute how many trees there are of a given size and type -featCard :: Grammar -> ConcrCat -> Int -> Integer -featCard gr c n = featCardVec gr [c] n - --- generate the i-th tree of a given size and type -featIth :: Grammar -> ConcrCat -> Int -> Integer -> Tree -featIth gr c n i = head (featIthVec gr [c] n i) - --- generate all trees (infinitely many) of a given type -featAll :: Grammar -> ConcrCat -> [Tree] -featAll gr c = [ featIth gr c n i | n <- [0..], i <- [0..featCard gr c n-1] ] - --- compute how many tree-vectors there are of a given size and type-vector -featCardVec :: Grammar -> [ConcrCat] -> Int -> Integer -featCardVec gr cs n = fst (feat gr cs n) - --- generate the i-th tree-vector of a given size and type-vector -featIthVec :: Grammar -> [ConcrCat] -> Int -> Integer -> [Tree] -featIthVec gr cs n i = snd (feat gr cs n) i - -mkFEAT :: Grammar -> FEAT -mkFEAT gr = catList - where - catList' :: FEAT - catList' [] 0 = (1, \0 -> []) - catList' [] _ = (0, error "indexing in an empty sequence") - - catList' [c] s = - parts $ - [ (n, \i -> [App f (h i)]) - | s > 0 - , f <- symbols gr - , let (xs,y) = ctyp f - , y == c - , let (n,h) = catList xs (s-1) - ] ++ - [ catList [x] s -- put (s-1) if it doesn't terminate - | s > 0 - , (x,y) <- coercions gr - , y == c - ] - - catList' (c:cs) s = - parts [ (nx*nxs, \i -> hx (i `mod` nx) ++ hxs (i `div` nx)) - | k <- [0..s] - , let (nx,hx) = catList [c] k - (nxs,hxs) = catList cs (s-k) - ] - - catList :: FEAT - catList = memoList (memoNat . catList') - where - -- all possible categories of the grammar - cats = S.toList $ S.fromList $ - [ x | f <- symbols gr - , let (xs,y) = ctyp f - , x <- y:xs ] ++ - [ z | (x,y) <- coercions gr - , z <- [x,y] ] - - memoList f = \cs -> case cs of - [] -> fNil - a:as -> fCons a as - where - fNil = f [] - fCons = (tab M.!) - tab = M.fromList [ (c, memoList (f . (c:))) | c <- cats ] - - memoNat f = (tab!!) - where - tab = [ f i | i <- [0..] ] - - parts [] = (0, error "indexing outside of a sequence") - parts ((n,h):nhs) = (n+n', \i -> if i < n then h i else h' (i-n)) - where - (n',h') = parts nhs - - --------------------------------------------------------------------------------- --- Functions used in Main - --- compare two grammars -diffCats :: Grammar -> Grammar -> [(Cat,[Int],[String],[String])] -diffCats gr1 gr2 = - [ (acat1,[difFid c1, difFid c2],labels1 \\ labels2,labels2 \\ labels1) - | c1@(acat1,_i1,_j2,labels1) <- concrCats gr1 - , c2@(acat2,_i2,_j2,labels2) <- concrCats gr2 - , difFid c1 /= difFid c2 -- different amount of concrete categories - || labels1 /= labels2 -- or the labels are different - , acat1==acat2 ] - - where - difFid (_,i,j,_) = 1 + (j-i) - - --- return a list of symbols that have a specified string, e.g. "it" in English --- grammar appears in functions CleftAdv, CleftNP, ImpersCl, DefArt, it_Pron -hasConcrString :: Grammar -> String -> [Symbol] -hasConcrString gr str = - [ symb - | symb <- symbols gr - , str `elem` concatMap (lefts . concrSeqs gr) (seqs symb) ] - --- nice printouts -type Context = String -type LinTree = ((Lang,Context),(Lang,String),(Lang,String),(Lang,String)) -data Comparison = Comparison { funTree :: String, linTree :: [LinTree] } - -instance Show Comparison where - show c = unlines $ funTree c : map showLinTree (linTree c) - -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] -showLinTree ((an,hl),(l1,t1),(l2,t2),(l3,t3)) = unlines ["", an++hl, l1++t1, l2++t2, l3++t3] - -compareTree :: Grammar -> Grammar -> [Grammar] -> Cat -> Tree -> Comparison -compareTree gr oldgr transgr startcat t = Comparison { - funTree = "* " ++ show t -, linTree = [ ( ("** ",hl), (langName gr,newLin), (langName oldgr, oldLin), transLin ) - | ctx <- ctxs - , let hl = show (ctx dummyHole) - , let newLin = linearize gr (ctx t) - , let oldLin = linearize oldgr (ctx t) - , let transLin = case transgr of - [] -> ("","") - g:_ -> (langName g, linearize g (ctx t)) - , newLin /= oldLin - ] } - where - w = top t - c = snd (ctyp w) - cs = c:[ coe - | (cat,coe) <- coercions gr - , c == cat ] - ctxs = concat - [ contextsFor gr sc cat - | sc <- ccats gr startcat - , cat <- cs ] - langName gr = concrLang gr ++ "> " - -type Result = String - -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..] testcase_ctxs ] - - where - 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 - 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 - ] - - starts = 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 - - funs = case lookupSymbol gr funname of - [] -> error $ "Function "++funname++" not found" - fs -> fs - - 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 - [ "* " ++ {- show n ++ ")" ++ -} show t - , showConcrFun gr w - , if debug then unlines $ tabularPrint gr t else "" - , unlines $ concat - [ [ "** " ++ show m ++ ") " ++ show (ctx (App (hole c) [])) - , langName gr ++ linearize gr (ctx t) - ] ++ - [ langName tgr ++ linearize tgr (ctx t) - | tgr <- tgrs ] - | (ctx,m) <- zip ctxs [1..] - ] - , "" ] - where - w = top t - c = snd (ctyp w) - langName gr = concrLang gr ++ "> " - - tabularPrint gr t = - let cseqs = [ concatMap showCSeq cseq - | cseq <- map (concrSeqs gr) (seqs $ top t) ] - tablins = tabularLin gr t :: [(String,String)] - in [ fieldname ++ ":\t" ++ lin ++ "\t" ++ s - | ((fieldname,lin),s) <- zip tablins cseqs ] - showCSeq (Left tok) = " " ++ show tok ++ " " - showCSeq (Right (i,j)) = " <" ++ show i ++ "," ++ show j ++ "> " - --------------------------------------------------------------------------------- --- Generate test trees - -treesUsingFun :: Grammar -> [Symbol] -> [Tree] -treesUsingFun gr detCNs = - [ tree - | detCN <- detCNs - , let (dets_cns,np_209) = ctyp detCN -- :: ([ConcrCat],ConcrCat) - , let bestArgs = case dets_cns of - [] -> [[]] - xs -> bestTrees detCN gr dets_cns - , tree <- App detCN `map` bestArgs ] - - -bestTrees :: Symbol -> Grammar -> [ConcrCat] -> [[Tree]] -bestTrees fun gr cats = - bestExamples fun gr $ take 200 -- change this to something else if too slow - [ featIthVec gr cats size i - | all (`S.member` nonEmptyCats gr) cats - , size <- [0..20] - , let card = featCardVec gr cats size - , i <- [0..card-1] - ] - -testsAsWellAs :: (Eq a, Eq b) => [a] -> [b] -> Bool -xs `testsAsWellAs` ys = go (xs `zip` ys) - where - go [] = - True - - go ((x,y):xys) = - and [ y' == y | (x',y') <- xys, x == x' ] && - go [ xy | xy@(x',_) <- xys, x /= x' ] - - -bestExamples :: Symbol -> Grammar -> [[Tree]] -> [[Tree]] -bestExamples fun gr vtrees = go [] vtrees_lins - where - syncategorematics = concatMap (lefts . concrSeqs gr) (seqs fun) - vtrees_lins = [ (vtree, syncategorematics ++ - concatMap (map snd . tabularLin gr) vtree) --linearise all trees at once - | vtree <- vtrees ] :: [([Tree],[String])] - - go cur [] = map fst cur - go cur (vt@(ts,lins):vts) - | any (`testsAsWellAs` lins) (map snd cur) = go cur vts - | otherwise = go' (vt:[ c | c@(_,clins) <- cur - , not (lins `testsAsWellAs` clins) ]) - vts - - go' cur vts | enough cur = map fst cur - | otherwise = go cur vts - - enough :: [([Tree],[String])] -> Bool - enough [(_,lins)] = all singleton (group $ sort lins) -- can stop earlier but let's not do that - enough _ = False - \ No newline at end of file diff --git a/src/tools/gftest/Graph.hs b/src/tools/gftest/Graph.hs deleted file mode 100644 index a440bf12d..000000000 --- a/src/tools/gftest/Graph.hs +++ /dev/null @@ -1,193 +0,0 @@ -module Graph where - -import qualified Data.Map as M -import Data.Map( Map, (!) ) -import qualified Data.Set as S -import Data.Set( Set ) -import Data.List( nub, sort, (\\) ) ---import Test.QuickCheck hiding ( generate ) - --- == almost everything in this module is inspired by King & Launchbury == - --------------------------------------------------------------------------------- --- depth-first trees - -data Tree a - = Node a [Tree a] - | Cut a - deriving ( Eq, Show ) - -type Forest a - = [Tree a] - -top :: Tree a -> a -top (Node x _) = x -top (Cut x) = x - --- pruning a possibly infinite forest -prune :: Ord a => Forest a -> Forest a -prune ts = go S.empty ts - where - go seen [] = [] - go seen (Cut x :ts) = Cut x : go seen ts - go seen (Node x vs:ts) - | x `S.member` seen = Cut x : go seen ts - | otherwise = Node x (take n ws) : drop n ws - where - n = length vs - ws = go (S.insert x seen) (vs ++ ts) - --- pre- and post-order traversals -preorder :: Tree a -> [a] -preorder t = preorderF [t] - -preorderF :: Forest a -> [a] -preorderF ts = go ts [] - where - go [] xs = xs - go (Cut x : ts) xs = go ts xs - go (Node x vs : ts) xs = x : go vs (go ts xs) - -postorder :: Tree a -> [a] -postorder t = postorderF [t] - -postorderF :: Forest a -> [a] -postorderF ts = go ts [] - where - go [] xs = xs - go (Cut x : ts) xs = go ts xs - go (Node x vs : ts) xs = go vs (x : go ts xs) - --- computing back-arrows -backs :: Ord a => Tree a -> Set a -backs t = S.fromList (go S.empty t) - where - go ups (Node x ts) = concatMap (go (S.insert x ups)) ts - go ups (Cut x) = [x | x `S.member` ups ] - --------------------------------------------------------------------------------- --- graphs - -type Graph a - = Map a [a] - -vertices :: Graph a -> [a] -vertices g = [ x | (x,_) <- M.toList g ] - -transposeG :: Ord a => Graph a -> Graph a -transposeG g = - M.fromListWith (++) $ - [ (y,[x]) | (x,ys) <- M.toList g, y <- ys ] ++ - [ (x,[]) | x <- vertices g ] - --------------------------------------------------------------------------------- --- graphs and trees - -generate :: Ord a => Graph a -> a -> Tree a -generate g x = Node x (map (generate g) (g!x)) - -dfs :: Ord a => Graph a -> [a] -> Forest a -dfs g xs = prune (map (generate g) xs) - -reach :: Ord a => Graph a -> [a] -> Graph a -reach g xs = M.fromList [ (x,g!x) | x <- preorderF (dfs g xs) ] - -dff :: Ord a => Graph a -> Forest a -dff g = dfs g (vertices g) - -preOrd :: Ord a => Graph a -> [a] -preOrd g = preorderF (dff g) - -postOrd :: Ord a => Graph a -> [a] -postOrd g = postorderF (dff g) - -scc1 :: Ord a => Graph a -> Forest a -scc1 g = reverse (dfs (transposeG g) (reverse (postOrd g))) - -scc2 :: Ord a => Graph a -> Forest a -scc2 g = dfs g (reverse (postOrd (transposeG g))) - -scc :: Ord a => Graph a -> Forest a -scc g = scc2 g - -sccs :: Ord a => Graph a -> [[a]] -sccs = map preorder . scc - --------------------------------------------------------------------------------- --- testing correctness - -{- -newtype G = G (Graph Int) deriving ( Show ) - -set :: (Ord a, Num a, Arbitrary a) => Gen [a] -set = (nub . sort . map abs) `fmap` arbitrary - -instance Arbitrary G where - arbitrary = - do xs <- set `suchThat` (not . null) - yss <- sequence [ listOf (elements xs) | x <- xs ] - return (G (M.fromList (xs `zip` yss))) - - shrink (G g) = - [ G (delNode x g) - | (x,_) <- M.toList g - ] ++ - [ G (delEdge x y g) - | (x,ys) <- M.toList g - , y <- ys - ] - where - delNode v g = - M.fromList - [ (x,filter (v/=) ys) - | (x,ys) <- M.toList g - , x /= v - ] - - delEdge v w g = - M.insert v ((g!v) \\ [w]) g - --- all vertices in a component can reach each other -prop_Scc_StronglyConnected (G g) = - whenFail (print cs) $ - and [ y `S.member` r | c <- cs, x <- c, let r = reach x, y <- c ] - where - cs = sccs g - - reach x = go S.empty [x] - where - go seen [] = seen - go seen (x:xs) - | x `S.member` seen = go seen xs - | otherwise = go (S.insert x seen) ((g!x) ++ xs) - --- vertices cannot forward-reach to other components -prop_Scc_NotConnected (G g) = - whenFail (print cs) $ - -- every vertex is somewhere - and [ or [ x `elem` c | c <- cs ] - | x <- vertices g - ] && - -- cannot foward-reach - and [ y `S.notMember` rx - | (c,d) <- pairs cs - , x <- c - , let rx = reach x - , y <- d - ] - where - cs = sccs g - - pairs (x:xs) = [ (x,y) | y <- xs ] ++ pairs xs - pairs [] = [] - - reach x = go S.empty [x] - where - go seen [] = seen - go seen (x:xs) - | x `S.member` seen = go seen xs - | otherwise = go (S.insert x seen) ((g!x) ++ xs) --} - --------------------------------------------------------------------------------- - diff --git a/src/tools/gftest/Main.hs b/src/tools/gftest/Main.hs deleted file mode 100644 index f8e122318..000000000 --- a/src/tools/gftest/Main.hs +++ /dev/null @@ -1,444 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Main where - -import Grammar -import EqRel - -import Control.Monad ( when ) -import Data.List ( intercalate, groupBy, sortBy, deleteFirstsBy, isInfixOf ) -import Data.Maybe ( fromMaybe, mapMaybe ) -import qualified Data.Set as S -import qualified Data.Map as M - -import System.Console.CmdArgs hiding ( name, args ) -import qualified System.Console.CmdArgs as A -import System.FilePath.Posix ( takeFileName ) -import System.IO ( stdout, hSetBuffering, BufferMode(..) ) - - -data GfTest - = GfTest - { grammar :: Maybe FilePath - -- Languages - , lang :: Lang - - -- Functions and cats - , function :: Name - , category :: Cat - , tree :: String - , start_cat :: Maybe Cat - , show_cats :: Bool - , show_funs :: Bool - , funs_of_arity :: Maybe Int - , show_coercions:: Bool - , show_contexts :: Maybe Int - , concr_string :: String - - -- Information about fields - , equal_fields :: Bool - , empty_fields :: Bool - , unused_fields :: Bool - , erased_trees :: Bool - - -- Compare to old grammar - , old_grammar :: Maybe FilePath - , only_changed_cats :: Bool - - -- Misc - , treebank :: Maybe FilePath - , count_trees :: Maybe Int - , debug :: Bool - , write_to_file :: Bool - - } deriving (Data,Typeable,Show,Eq) - -gftest = GfTest - { grammar = def &= typFile &= help "Path to the grammar (PGF) you want to test" - , lang = def &= A.typ "\"Eng Swe\"" - &= 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" - &= 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" - &= A.name "s" &= help "Use the given category as start category" - , 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" - , show_contexts = def &= A.typ "8410" &= help "Show contexts for a given concrete type (given as FId)" - , debug = def &= help "Show debug output" - , equal_fields = def &= A.name "q" &= help "Show fields whose strings are always identical" - , empty_fields = def &= A.name "e" &= help "Show fields whose strings are always empty" - , unused_fields = def &= help "Show fields that never make it into the top category" - , erased_trees = def &= A.name "r" &= help "Show trees that are erased" - , treebank = def &= typFile - &= A.name "b" &= help "Path to a treebank" - , count_trees = def &= A.typ "3" &= help "Number of trees of size <3>" - , old_grammar = def &= typFile - &= A.name "o" &= help "Path to an earlier version of the grammar" - , only_changed_cats = def &= help "When comparing against an earlier version of a grammar, only test functions in categories that have changed between versions" - , write_to_file = def &= help "Write the results in a file (_.org)" - } - - -main :: IO () -main = do - hSetBuffering stdout NoBuffering - - args <- cmdArgs gftest - - case grammar args of - Nothing -> putStrLn "Usage: `gftest -g [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" - - (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 ] - - -- Read grammar and translations - gr <- readGrammar langName grName - grTrans <- sequence [ readGrammar lt grName | lt <- langTrans ] - - -- if language given by the user was not valid, use default language from Grammar - let langName = concrLang gr - - 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) - cs = c:[ coe - | (cat,coe) <- coercions gr - , c == cat ] - ctxs = concat [ contextsFor gr sc cat - | sc <- ccats gr startcat - , cat <- cs ] - - 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 - ]) - - 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 - let trees = case tree args of - [] -> [] - ts -> [ readTree gr t | t <- lines ts ] - output $ - unlines [ testTree' tree 1 | tree <- trees ] - - -- Test a function - let substrs xs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') xs - let cats = case category args of - [] -> [] - cs -> if '*' `elem` cs - then let subs = substrs cs - in nub [ cat | (cat,_,_,_) <- concrCats gr - , all (`isInfixOf` cat) subs ] - else words cs - output $ - unlines [ testTree' t n - | cat <- cats - , (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]] - - -- Test all functions in a category - let funs = case function args of - [] -> [] - fs -> if '*' `elem` fs - then let subs = substrs fs - in nub [ f | s <- symbols gr, let f = show s - , all (`isInfixOf` f) subs - , arity s >= 1 ] - else words fs - output $ - unlines [ testFun (debug args) gr grTrans startcat f - | f <- funs ] - ------------------------------------------------------------------------------ --- Information about the grammar - - -- Show contexts for a particular concrete category - case show_contexts args of - Nothing -> return () - Just fid -> mapM_ print - [ ctx dummyHole - | start <- ccats gr startcat - , ctx <- contextsFor gr start (mkCC gr fid) ] - - -- Show available categories - when (show_cats args) $ do - putStrLn "* Categories in the grammar:" - let concrcats = sortBy (\(_,a,_,_) (_,b,_,_) -> a `compare` b) (concrCats gr) - sequence_ [ do putStrLn cat - when (debug args) $ - putStrLn $ unwords $ - [ " Compiles to concrete" ] ++ - [ "categories " ++ show bg++"—"++show end - | bg/=end ] ++ - [ "category " ++ show bg - | bg==end ] - | (cat,bg,end,_) <- concrcats - , end >= 0] - - -- 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 ] - - 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 - [] -> 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 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 - - 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 "" - - 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)) - - -------------------------------------------------------------------------------- --- Read trees from treebank. - - treebank' <- - case treebank args of - Nothing -> return [] - Just fp -> do - tb <- readFile fp - return [ readTree gr s - | s <- lines tb ] - mapM_ print treebank' - -------------------------------------------------------------------------------- --- 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) - - -------------------------------------------------------------------------- - -- 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) $ - sequence_ - [ appendFile ccatChangeFile $ - unlines $ - ("* All concrete cats in the "++age++" grammar:"): - [ show cts | cts <- concrCats g ] - | (g,age) <- [(ogr,"old"),(gr,"new")] ] - - putStrLn $ "Created file " ++ ccatChangeFile - - -------------------------------------------------------------------------- - -- Print out tests for all functions in the changed cats. - -- If -f, -c or --treebank specified, use them. - - let f cat = (cat, treesUsingFun gr $ functionsByCat gr cat) - - byCat = [ f cat | cat <- cats ] -- from command line arg -c - changed = [ f cat | (cat,_,_,_) <- difcats - , only_changed_cats args ] - byFun = [ (cat, treesUsingFun gr fs) - | funName <- funs -- comes from command line arg -f - , let fs@(s:_) = lookupSymbol gr funName - , let cat = snd $ Grammar.typ s ] - fromTb = [ (cat,[tree]) | tree <- treebank'++trees - , let (CC (Just cat) _) = ccatOf tree ] - - treesToTest = - case concat [byFun, byCat, changed, fromTb] of - [] -> [ f cat -- nothing else specified -> test all functions - | (cat,_,_,_) <- concrCats gr ] - xs -> S.toList $ S.fromList xs - - writeLinFile file grammar otherGrammar = do - writeFile file "" - putStrLn "Testing functions in… " - diff <- concat `fmap` - sequence [ do let cs = [ compareTree grammar otherGrammar grTrans startcat t - | t <- ttrees ] - putStr $ cat ++ " \r" - -- prevent lazy evaluation; make printout accurate - appendFile ("/tmp/"++file) (unwords $ map show cs) - return [ c | c@(Comparison f (x:xs)) <- cs ] - | (cat,ttrees) <- treesToTest ] - - let shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2) - writeFile file $ unlines - [ show comp - | comp <- sortBy shorterTree diff ] - - 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 ] - - 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 - - putStrLn $ "Created files " ++ langName ++ "-(old|new)-funs.org" - - - where - - nub = S.toList . S.fromList - - sameCCat :: Symbol -> Symbol -> Bool - sameCCat s1 s2 = snd (ctyp s1) == snd (ctyp s2) - - compareCCat :: Symbol -> Symbol -> Ordering - compareCCat s1 s2 = snd (ctyp s1) `compare` snd (ctyp s2) - - stripPGF :: String -> String - stripPGF s = case reverse s of - 'f':'g':'p':'.':name -> reverse name - name -> s - diff --git a/src/tools/gftest/Mu.hs b/src/tools/gftest/Mu.hs deleted file mode 100644 index 4aa11e316..000000000 --- a/src/tools/gftest/Mu.hs +++ /dev/null @@ -1,113 +0,0 @@ -module Mu where - -import Data.Map( Map, (!) ) -import qualified Data.Map as M -import Data.Set( Set ) -import qualified Data.Set as S -import Graph - --------------------------------------------------------------------------------- - --- naive implementation of fixpoint computation -mu0 :: (Ord x, Eq a) => a -> [(x, [x], [a] -> a)] -> [x] -> [a] -mu0 bot defs zs = [ done!z | z <- zs ] - where - xs = [ x | (x, _, _) <- defs ] - done = iter [ bot | _ <- xs ] - - iter as - | as == as' = tab - | otherwise = iter as' - where - tab = M.fromList (xs `zip` as) - as' = [ f [ tab!y | y <- ys ] - | (_,(_, ys, f)) <- as `zip` defs - ] - --------------------------------------------------------------------------------- - --- scc-based implementation of fixpoint computation -{- - a --^ initial/bottom value (smallest element) in the fixpoint computation --> [( x, [x] --^ A single category, its arguments - , [a] -> a) --^ function that takes as its argument a list of values that we want to compute for the [x] - ] --> [x] --^ All categories that you want to see the answer for --> [a] --^ Values for the given categories --} - -mu :: (Ord x, Eq a) => a -> [(x, [x], [a] -> a)] -> [x] -> [a] -mu bot defs zs = [ vtab?z | z <- zs ] - where - ftab = M.fromList [ (x,f) | (x,_,f) <- defs ] - graph = reach (M.fromList [ (x,xs) | (x,xs,_) <- defs ]) zs - vtab = foldl compute M.empty (scc graph) - - compute vtab t = fix (-1) vtab (map (vtab ?) xs) - where - xs = S.toList (backs t) - - fix 0 vtab _ = vtab - fix n vtab as - | as' == as = vtab' - | otherwise = fix (n-1) vtab' as' - where - (_,vtab') = eval t vtab - as' = map (vtab' ?) xs - - eval (Cut x) vtab = (vtab?x, vtab) - eval (Node x ts) vtab = (a, M.insert x a vtab') - where - (as, vtab') = evalList ts vtab - a = (ftab!x) as - - evalList [] vtab = ([], vtab) - evalList (t:ts) vtab = (a:as, vtab'') - where - (a, vtab') = eval t vtab - (as,vtab'') = evalList ts vtab' - - vtab ? x = case M.lookup x vtab of - Nothing -> bot - Just a -> a - --------------------------------------------------------------------------------- - --- diff/scc-based implementation of fixpoint computation -muDiff :: (Ord x, Eq a) - => a -> (a->Bool) -> (a->a->a) -> (a->a->a) - -> [(x, [x], [a] -> a)] - -> [x] -> [a] -muDiff bot isBot diff apply defs zs = [ vtab?z | z <- zs ] - where - ftab = M.fromList [ (x,f) | (x,_,f) <- defs ] - graph = reach (M.fromList [ (x,xs) | (x,xs,_) <- defs ]) zs - vtab = foldl compute M.empty (scc graph) - - compute vtab t = fix vtab M.empty - where - xs = S.toList (backs t) - - fix dtab vtab - | all isBot ds = vtab' - | otherwise = fix (M.fromList (xs `zip` ds)) vtab' - where - dtab' = eval t dtab - vtab' = foldr (\(x,d) -> M.alter (Just . apply' d) x) vtab (M.toList dtab') - ds = map (dtab' ?) xs - - apply' d Nothing = apply d bot - apply' d (Just a) = apply d a - - eval (Cut x) tab = tab - eval (Node x ts) tab = M.insert x d tab' - where - tab' = foldl (flip eval) tab ts - d = (ftab!x) [ tab'?x | x <- map top ts ] `diff` (vtab?x) - - vtab ? x = case M.lookup x vtab of - Nothing -> bot - Just a -> a - --------------------------------------------------------------------------------- - diff --git a/src/tools/gftest/README.md b/src/tools/gftest/README.md index beecaf191..f8e90551c 100644 --- a/src/tools/gftest/README.md +++ b/src/tools/gftest/README.md @@ -1,563 +1 @@ -# gftest: Automatic systematic test case generation for GF grammars - -`gftest` is a program for automatically generating systematic test -cases for GF grammars. The basic use case is to give `gftest` a -PGF grammar, a concrete language and a function; then `gftest` generates a -representative and minimal set of example sentences for a human to look at. - -There are examples of actual generated test cases later in this -document, as well as the full list of options to give to `gftest`. - -## Table of Contents - -- [Installation](#installation) - - [Prerequisites](#prerequisites) - - [Install gftest](#install-gftest) -- [Common use cases](#common-use-cases) - - [Grammar: `-g`](#grammar--g) - - [Language: `-l`](#language--l) - - [Function(s) to test: `-f`](#functions-to-test--f) - - [Start category for context: `-s`](#start-category-for-context--s) - - [Category to test: `-c`](#category-to-test--c) - - [Tree to test: `-t`](#tree-to-test--t) - - [Compare against an old version of the grammar: `-o`](#compare-against-an-old-version-of-the-grammar--o) - - [Information about a particular string: `--concr-string`](#information-about-a-particular-string---concr-string) - - [Write into a file: `-w`](#write-into-a-file--w) -- [Less common use cases](#less-common-use-cases) - - [Empty or always identical fields: `-e`, `-q`](#empty-or-always-identical-fields--e--q) - - [Unused fields: `-u`](#unused-fields--u) - - [Erased trees: `-r`](#erased-trees--r) - - [Debug information: `-d`](#debug-intormation--d) -- [Detailed information about the grammar](#detailed-information-about-the-grammar) - - [--show-cats](#--show-cats) - - [--show-funs](#--show-funs) - - [--show-coercions](#--show-coercions) - - [--show-contexts](#--show-contexts) - - [--count-trees](#--count-trees) - - [--funs-of-arity](#--funs-of-arity) - -## Installation - -### Prerequisites - -You need the library `PGF2`. Here are instructions how to install: - -1) Install C runtime: go to the directory [GF/src/runtime/c](https://github.com/GrammaticalFramework/GF/tree/master/src/runtime/c), see -instructions in INSTALL -1) Install PGF2 in one of the two ways: - * **EITHER** Go to the directory - [GF/src/runtime/haskell-bind](https://github.com/GrammaticalFramework/GF/tree/master/src/runtime/haskell-bind), - do `cabal install` - * **OR** Go to the root directory of - [GF](https://github.com/GrammaticalFramework/GF/) and compile GF - with C-runtime system support: `cabal - install -fc-runtime`, see more information [here](http://www.grammaticalframework.org/doc/gf-developers.html#toc16). - -### Install gftest - -Go to -[GF/src/tools](https://github.com/GrammaticalFramework/GF/tree/master/src/tools), -do `cabal install`. It creates an executable `gftest`. - - -## Common use cases - -Run `gftest --help` of `gftest -?` to get the list of options. - -``` -Common flags: - -g --grammar=FILE Path to the grammar (PGF) you want to test - -l --lang="Eng Swe" Concrete syntax + optional translations - -f --function=UseN Test the given function(s) - -c --category=NP Test all functions with given goal category - -t --tree="UseN tree_N" Test the given tree - -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 - --show-contexts=8410 Show contexts for a given concrete type (given as FId) - --concr-string=the Show all functions that include given string - -q --equal-fields Show fields whose strings are always identical - -e --empty-fields Show fields whose strings are always empty - -u --unused-fields Show fields that never make it into the top category - -r --erased-trees Show trees that are erased - -o --old-grammar=ITEM Path to an earlier version of the grammar - --only-changed-cats When comparing against an earlier version of a - grammar, only test functions in categories that have - changed between versions - -b --treebank=ITEM Path to a treebank - --count-trees=3 Number of trees of depth - -d --debug Show debug output - -w --write-to-file Write the results in a file (_.org) - -? --help Display help message - -V --version Print version information -``` - -### Grammar: `-g` - -Give the PGF grammar as an argument with `-g`. If the file is not in -the same directory, you need to give the full file path. - -You can give the grammar with or without `.pgf`. - -Without a concrete syntax you can't do much, but you can see the -available categories and functions with `--show-cats` and `--show-funs` - -Examples: - -* `gftest -g Foods --show-funs` -* `gftest -g /home/inari/grammars/LangEng.pgf --show-cats` - - -### Language: `-l` - -Give a concrete language. It assumes the format `AbsNameConcName`, and you should only give the `ConcName` part. - -You can give multiple languages, in which case it will create the test cases based on the first, and show translations in the rest. - -Examples: - -* `gftest -g Phrasebook -l Swe --show-cats` -* `gftest -g Foods -l "Spa Eng" -f Pizza` - -### Function(s) to test: `-f` - -Given a grammar (`-g`) and a concrete language ( `-l`), test a function or several functions. - -Examples: - -* `gftest -g Lang -l "Dut Eng" -f UseN` -* `gftest -g Phrasebook -l Spa -f "ByTransp ByFoot"` - -You can use the wildcard `*`, if you want to match multiple functions. Examples: - -* `gftest -g Lang -l Eng -f "*hat*"` - -matches `hat_N, hate_V2, that_Quant, that_Subj, whatPl_IP` and `whatSg_IP`. - -* `gftest -g Lang -l Eng -f "*hat*u*"` - -matches `that_Quant` and `that_Subj`. - -* `gftest -g Lang -l Eng -f "*"` - -matches all functions in the grammar. (As of March 2018, takes 13 -minutes for the English resource grammar, and results in ~40k -lines. You may not want to do this for big grammars.) - -### Start category for context: `-s` - -Give a start category for contexts. Used in conjunction with `-f`, -`-c`, `-t` or `--count-trees`. If not specified, contexts are created -for the start category of the grammar. - -Example: - -* `gftest -g Lang -l "Dut Eng" -f UseN -s Adv` - -This creates a hole of `CN` in `Adv`, instead of the default start category. - -### Category to test: `-c` - -Given a grammar (`-g`) and a concrete language ( `-l`), test all functions that return a given category. - -Examples: - -* `gftest -g Phrasebook -l Fre -c Modality` -* `gftest -g Phrasebook -l Fre -c ByTransport -s Action` - - -### Tree to test: `-t` - -Given a grammar (`-g`) and a concrete language ( `-l`), test a complete tree. - -Example: - -* `gftest -g Phrasebook -l Dut -t "ByTransp Bus"` - -You can combine it with any of the other flags, e.g. put it in a -different start category: - -* `gftest -g Phrasebook -l Dut -t "ByTransp Bus" -s Action` - - -This may be useful for the following case. Say you tested `PrepNP`, -and the default NP it gave you only uses the word *car*, but you -would really want to see it for some other noun—maybe `car_N` itself -is buggy, and you want to be sure that `PrepNP` works properly. So -then you can call the following: - -* `gftest -g TestLang -l Eng -t "PrepNP with_Prep (MassNP (UseN beer_N))"` - -### Compare against an old version of the grammar: `-o` - -Give a grammar, a concrete syntax, and an old version of the same -grammar as a separate PGF file. The program generates test sentences -for all functions (if no other arguments), linearises with both -grammars, and outputs those that differ between the versions. It -writes the differences into files. - -Example: - -``` -> gftest -g TestLang -l Eng -o TestLangOld -Created file TestLangEng-ccat-diff.org -Testing functions in… - -Created file TestLangEng-lin-diff.org -Created files TestLangEng-(old|new)-funs.org -``` - -* TestLangEng-ccat-diff.org: All concrete categories that have - changed. Shows e.g. if you added or removed a parameter or a - field. - -* **TestLangEng-lin-diff.org** (usually the most relevant file): All -trees that have different linearisations in the following format. - -``` - * send_V3 - - ** UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron we_Pron) (ReflVP (Slash3V3 ∅ (UsePron it_Pron)))) - TestLangDut> we sturen onszelf ernaar - TestLangDut-OLD> we sturen zichzelf ernaar - - - ** UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron we_Pron) (ReflVP (Slash3V3 ∅ (UsePron it_Pron)))) - TestLangDut> we stuurden onszelf ernaar - TestLangDut-OLD> we stuurden zichzelf ernaar -``` - -* TestLangEng-old-funs.org and TestLangEng-new-funs.org: groups the - functions by their concrete categories. Shows difference if you have - e.g. added or removed parameters, and that has created new versions of - some functions: say you didn't have gender in nouns, but now you - have, then all functions taking nouns have suddenly a gendered - version. (This is kind of hard to read, don't worry too much if the - output doesn't make any sense.) - -#### Additional arguments to `-o` - -The default mode is to test all functions, but you can also give any -combination of `-s`, `-f`, `-c`, `--treebank`/`-b` and `--only-changed-cats`. - -With `-s`, you can change the start category in which contexts are -generated. - -With `-f` and `-c`, it tests only the specified functions and -categories. -With `-b FILEPATH` (`-b`=`--treebank`), it tests only the trees in the file. - -With `--only-changed-cats`, it only test functions in those categories -that have changed between the two versions. - -Examples: - -* `gftest -g TestLang -l Eng -o TestLangOld` tests all functions -* `gftest -g TestLang -l Eng -o TestLangOld -s S` tests all functions in start category S -* `gftest -g TestLang -l Eng -o TestLangOld --only-changed-cats` tests only changed categories. If no categories have changed (and no other arguments specified), tests everything. -* `gftest -g TestLang -l Eng -o TestLangOld -f "AdjCN AdvCN" -c Adv -b trees.txt` tests functions, `AdjCN` and `AdvCN`; same for all functions that produce an `Adv`, and all trees in trees.txt. - -### Information about a particular string: `--concr-string` - -Show all functions that introduce the string given as an argument. - -Example: - -* `gftest -g Lang -l Eng --concr-string it` - -which gives the answer `==> CleftAdv, CleftNP, DefArt, ImpersCl, it_Pron` - -(Note that you have the same feature in GF shell, command `morpho_analyse`/`ma`.) - - -### Write into a file: `-w` - -Writes the results into a file of format `_.org`, -e.g. TestLangEng-UseN.org. Recommended to open it in emacs org-mode, -so you get an overview, and you can maybe ignore some trees if you -think they are redundant. - -1) When you open the file, you see a list of generated test cases, like this: ![Instructions how to use org mode](https://raw.githubusercontent.com/inariksit/GF-testing/master/doc/instruction-1.png) -Place cursor to the left and click tab to open it. - -2) You get a list of contexts for the test case. Keep the cursor where it was if you want to open everything at the same time. Alternatively, scroll down to one of the contexts and press tab there, if you only want to open one. -![Instructions how to use org mode](https://raw.githubusercontent.com/inariksit/GF-testing/master/doc/instruction-2.png) - -3) Now you can read the linearisations. -![Instructions how to use org mode](https://raw.githubusercontent.com/inariksit/GF-testing/master/doc/instruction-3.png) - -If you want to close the test case, just press tab again, keeping the -cursor where it's been all the time (line 31 in the pictures). - -## Less common use cases - -The topics here require some more obscure GF-fu. No need to worry if -the terms are not familiar to you. - - -### Empty or always identical fields: `-e`, `-q` - -Information about the fields: always empty, or always equal to each -other. Example of empty fields: - -``` -> gftest -g Lang -l Dut -e -* Empty fields: -==> Ant: s - -==> Pol: s - -==> Temp: s - -==> Tense: s - -==> V: particle, prefix -``` - -The categories `Ant`, `Pol`, `Temp` and `Tense` are as expected empty; -there's no string to be added to the sentences, just a parameter that -*chooses* the right forms of the clause. - -`V` having empty fields `particle` and `prefix` is in this case just -an artefact of a small lexicon: we happen to have no intransitive -verbs with a particle or prefix in the core 300-word vocabulary. But a -grammarian would know that it's still relevant to keep those fields, -because in some bigger application such a verb may show up. - -On the other hand, if some other field is always empty, it might be a -hint for the grammarian to remove it altogether. - -Example of equal fields: - -``` -> gftest -g Lang -l Dut -q -* Equal fields: -==> RCl: -s Pres Simul Pos Utr Pl -s Pres Simul Pos Neutr Pl - -==> RCl: -s Pres Simul Neg Utr Pl -s Pres Simul Neg Neutr Pl - -==> RCl: -s Pres Anter Pos Utr Pl -s Pres Anter Pos Neutr Pl - -==> RCl: -s Pres Anter Neg Utr Pl -s Pres Anter Neg Neutr Pl - -==> RCl: -s Past Simul Pos Utr Pl -s Past Simul Pos Neutr Pl -… -``` - -Here we can see that in relative clauses, gender does not seem to play -any role in plural. This could be a hint for the grammarian to make a -leaner parameter type, e.g. `param RClAgr = SgAgr | PlAgr `. - - -### Unused fields: `-u` - -These fields are not empty, but they are never used in the top -category. The top category can be specified by `-s`, otherwise it is -the default start category of the grammar. - -Note that if you give a start category from very low, such as `Adv`, -you get a whole lot of categories and fields that naturally have no -way of ever making it into an adverb. So this is mostly meaningful to -use for the start category. - - -### Erased trees: `-r` - -Show trees that are erased in some function, i.e. a function `F : A -> B -> C` has arguments A and B, but doesn't use one of them in the resulting tree of type C. This is usually a bug. - -Example: - - - -``` -> gftest -g Lang -l "Dut Eng" -r - -* Erased trees: - -** RelCl (ExistNP something_NP) : RCl -- Tree: AdvS (PrepNP with_Prep (RelNP (UsePron it_Pron) (UseRCl (TTAnt TPres ASimul) PPos (RelCl (ExistNP something_NP))))) (UseCl (TTAnt TPres ASimul) PPos (ExistNP something_NP)) -- Lin: ermee is er iets -- Trans: with it, such that there is something, there is something - -** write_V2 : V2 -- Tree: AdvS (PrepNP with_Prep (PPartNP (UsePron it_Pron) write_V2)) (UseCl (TTAnt TPres ASimul) PPos (ExistNP something_NP)) -- Lin: ermee is er iets -- Trans: with it written there is something -``` - -In the first result, an argument of type `RCl` is missing in the tree constructed by `RelNP`, and in the second result, the argument `write_V2` is missing in the tree constructed by `PPartNP`. In both cases, the English linearisation contains all the arguments, but in the Dutch one they are missing. (This bug is already fixed, just showing it here to demonstrate the feature.) - -## Detailed information about the grammar - -### Debug information: `-d` - -When combined with `-f`, `-c` or `-t`, two things happen: - -1) The trees are linearised using `tabularLinearize`, which shows the -inflection table of all forms. -2) You can see traces of pruning that happens in testing functions: -contexts that are common to several concrete categories are put under -a separate test case. - -When combined with `--show-cats`, also the concrete categories are -shown. - -### --show-cats - -Shows the categories in the grammar. With `--debug`/`-d`, shows also -concrete categories. - -Example: - -``` -> gftest -g Foods -l Spa --show-cats -d - -* Categories in the grammar: -Comment - Compiles to concrete category 0 -Item - Compiles to concrete categories 1—4 -Kind - Compiles to concrete categories 5—6 -Quality - Compiles to concrete categories 7—8 -Question - Compiles to concrete category 9 -``` - -### --show-funs - -Shows the functions in the grammar. (Nothing fancy happens with other flags.) - - -### --show-coercions - -First I'll explain what *coercions* are, then why it may be -interesting to show them. Let's take a Spanish Foods grammar, and -consider the category `Quality`, e.g. `Good` and `Vegan`. -`Good` "bueno/buena/buenos/buenas" goes before the noun it modifies, -whereas `Vegan` "vegano/vegana/…" goes after, so these will become different -*concrete categories* in the PGF: `Quality_before` and -`Quality_after`. (In reality, they are something like `Quality_7` and -`Quality_8` though.) - -Now, this difference is meaningful only when the adjective is modifying -the noun: "la buena pizza" vs. "la pizza vegana". But when the -adjective is in a predicative position, they both behave the same: -"la pizza es buena" and "la pizza es vegana". For this, the grammar -creates a *coercion*: both `Quality_before` and `Quality_after` may be -treated as `Quality_whatever`. To save some redundant work, this coercion `Quality_whatever` -appears in the type of predicative function, whereas the -modification function has to be split into two different functions, -one taking `Quality_before` and other `Quality_after`. - -Now you know what coercions are, this is how it looks like in the program: - -``` -> gftest -g Foods -l Spa --show-coercions -* Coercions in the grammar: -Quality_7--->_11 -Quality_8--->_11 -``` - -(Just mentally replace 7 with `before`, 8 with `after` and 11 with `whatever`.) - -### --show-contexts - -Show contexts for a given concrete category, given as an FId -(i.e. Int). The concrete category may be a coercion or a normal -category. By combining with [`-s`](#start-category-for-context--s), -you can change the start category of the context. - -(You can get a list of all concrete categories by pairing `--show-cats` -with `--debug`: see [`--show-cats`](#--show-cats).) - -Examples: - -* First, find out some concrete categories: - -``` - > gftest -g Foods -l Spa --show-cats -d - … - Quality - Compiles to concrete categories 7—8 - … -``` - -* Then, list the contexts for some of them, say `Quality_7`: - -``` - > gftest -g Foods -l Spa --show-contexts 7 - - Pred (That (Mod ∅ Wine)) Vegan - Pred (That Wine) ∅ - Pred (These (Mod ∅ Wine)) Vegan - Pred (These Wine) ∅ - Pred (That (Mod ∅ Pizza)) Vegan - Pred (That Pizza) ∅ - Pred (These (Mod ∅ Pizza)) Vegan - Pred (These Pizza) ∅ -``` - -* Check out from [`--show-coercions`](#--show-coercions) how to find -coercions, and you can try `--show-contexts` with them: - -``` - > gftest -g Foods -l Spa --show-contexts 11 - - Pred (That Wine) ∅ - Pred (These Wine) ∅ - Pred (That Pizza) ∅ - Pred (These Pizza) ∅ -``` - -### --count-trees - -Number of trees up to given size. Gives a number how many trees, and a -couple of examples from the highest size. Examples: - -``` -> gftest -g TestLang -l Eng --count-trees 10 -There are 675312 trees up to size 10, and 624512 of exactly size 10. -For example: -* AdvS today_Adv (UseCl (TTAnt TPres ASimul) PPos (ExistNP (UsePron i_Pron))) -* UseCl (TTAnt TCond AAnter) PNeg (PredVP (SelfNP (UsePron they_Pron)) UseCopula) -``` - -This counts the number of trees in the start category. You can also -specify a category: - -``` -> gftest -g TestLang -l Eng --count-trees 4 -s Adv -There are 2409 trees up to size 4, and 2163 of exactly size 4. -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 -``` +Development moved to https://github.com/GrammaticalFramework/gftest