added -nofun and -nocat options to vt

4 files changed, 30 insertions, 34 deletions

diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index 04c47413a..6cdd82d7e 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -165,8 +165,8 @@ allCommands pgf = Map.fromList [
      synopsis = "generates a list of trees, by default exhaustive",
      explanation = unlines [
        "Generates all trees of a given category, with increasing depth.",
-       "By default, the depth is inlimited, but this can be changed by a flag."
-       ---- "If a Tree argument is given, thecommand completes the Tree with values",
+       "By default, the depth is 4, but this can be changed by a flag."
+       ---- "If a Tree argument is given, the command completes the Tree with values",
        ---- "to the metavariables in the tree."
        ],
      flags = [
@@ -177,7 +177,7 @@ allCommands pgf = Map.fromList [
        ],
      exec = \opts _ -> do
        let pgfr = optRestricted opts
-       let dp = return $ valIntOpts "depth" 999999 opts
+       let dp = return $ valIntOpts "depth" 4 opts
        let ts = generateAllDepth pgfr (optCat opts) dp
        return $ fromTrees $ take (optNumInf opts) ts
      }),
@@ -449,7 +449,9 @@ allCommands pgf = Map.fromList [
        "flag -format."
        ],
      exec = \opts ts -> do
-         let grph = visualizeTrees False ts -- True=digraph
+         let funs = not (isOpt "nofun" opts)
+         let cats = not (isOpt "nocat" opts)
+         let grph = visualizeTrees pgf (funs,cats) ts -- True=digraph
          if isFlag "view" opts || isFlag "format" opts then do
            let file s = "_grph." ++ s
            let view = optViewGraph opts ++ " "
@@ -463,7 +465,10 @@ allCommands pgf = Map.fromList [
        "p \"hello\" | vt              -- parse a string and show trees as graph script",
        "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
        ],
-
+     options = [
+       ("nofun","don't show functions but only categories"),
+       ("nocat","don't show categories but only functions")
+       ],
      flags = [
        ("format","format of the visualization file (default \"ps\")"),
        ("view","program to open the resulting file (default \"gv\")")
diff --git a/src-3.0/GF/Source/SourceToGrammar.hs b/src-3.0/GF/Source/SourceToGrammar.hs
index 5f785f05c..e80219f30 100644
--- a/src-3.0/GF/Source/SourceToGrammar.hs
+++ b/src-3.0/GF/Source/SourceToGrammar.hs
@@ -684,7 +684,7 @@ transDDecl x = case x of
   DDDec binds exp  -> transDecl $ DDec binds exp
   DDExp exp  ->  transDecl $ DExp exp
 
--- | to deal with the old format, sort judgements in three modules, forming
+-- | to deal with the old format, sort judgements in two modules, forming
 -- their names from a given string, e.g. file name or overriding user-given string
 transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
 transOldGrammar opts name0 x = case x of
@@ -693,7 +693,7 @@ transOldGrammar opts name0 x = case x of
     g1 <- transGrammar $ Gr moddefs
     removeLiT g1 --- needed for bw compatibility with an obsolete feature
  where
-   sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps
+   sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)]
      where 
        ops = map fst ps
        (a,r,c,ps) = foldr srt ([],[],[],[]) ds
@@ -714,14 +714,10 @@ transOldGrammar opts name0 x = case x of
      DefPrintCat printdefs  -> (a,r,d:c,ps)
      DefPrintFun printdefs  -> (a,r,d:c,ps)
      DefPrintOld printdefs  -> (a,r,d:c,ps)
-     DefPackage m ds        -> (a,r,c,(m,ds):ps)
+     -- DefPackage m ds        -> (a,r,c,(m,ds):ps) -- OBSOLETE
      _ -> (a,r,c,ps)
    mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn [])  (topDefs a))
-   mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r))
-                  where ops = map OName ps
-   mkCnc ps r = MModule q (MTConcrete cncName absName) 
-                               (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r))
-   mkPack (m, ds) = MModule q (MTResource m) (MBody ne  (OpenIn []) (topDefs ds))
+   mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r))
    topDefs t = t
    ne = NoExt
    q = CMCompl
@@ -742,21 +738,7 @@ transOldGrammar opts name0 x = case x of
      _:s   -> (beg, takeWhile (/='.') s)
 
 transInclude :: Include -> Err [FilePath]
-transInclude x = case x of
-  NoIncl -> return []
-  Incl filenames  -> return $ map trans filenames
- where
-   trans f = case f of
-     FString s  -> s
-     FIdent (PIdent (_, s)) -> modif s
-     FSlash filename  -> '/' : trans filename
-     FDot filename  -> '.' : trans filename
-     FMinus filename  -> '-' : trans filename
-     FAddId (PIdent (_, s)) filename  -> modif s ++ trans filename
-   modif s = let s' = BS.snoc (BS.init s) (toLower (BS.last s)) in 
-             BS.unpack (if elem (BS.unpack s') newReservedWords then s' else s)
-                      --- unsafe hack ; cf. GetGrammar.oldLexer
-
+transInclude x = Bad "Old GF with includes no more supported in GF 3.0"
 
 newReservedWords :: [String]
 newReservedWords =
diff --git a/src-3.0/PGF/Macros.hs b/src-3.0/PGF/Macros.hs
index a680cf0f9..bb5e8188b 100644
--- a/src-3.0/PGF/Macros.hs
+++ b/src-3.0/PGF/Macros.hs
@@ -34,6 +34,9 @@ lookType :: PGF -> CId -> Type
 lookType pgf f = 
   fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf))
 
+lookValCat :: PGF -> CId -> CId
+lookValCat pgf = valCat . lookType pgf
+
 lookParser :: PGF -> CId -> Maybe ParserInfo
 lookParser pgf lang = Map.lookup lang (concretes pgf) >>= parser
 
diff --git a/src-3.0/PGF/VisualizeTree.hs b/src-3.0/PGF/VisualizeTree.hs
index 1bf4dc075..0219dcbde 100644
--- a/src-3.0/PGF/VisualizeTree.hs
+++ b/src-3.0/PGF/VisualizeTree.hs
@@ -20,12 +20,13 @@ module PGF.VisualizeTree ( visualizeTrees
 
 import PGF.CId (prCId)
 import PGF.Data
+import PGF.Macros (lookValCat)
 
-visualizeTrees :: Bool -> [Tree] -> String
-visualizeTrees digr = unlines . map (prGraph digr . tree2graph digr)
+visualizeTrees :: PGF -> (Bool,Bool) -> [Tree] -> String
+visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats)
 
-tree2graph :: Bool -> Tree -> [String]
-tree2graph digr = prf [] where
+tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String]
+tree2graph pgf (funs,cats) = prf [] where
   prf ps t = case t of
     Fun cid trees -> 
       let (nod,lab) = prn ps cid in
@@ -33,10 +34,15 @@ tree2graph digr = prf [] where
         [       pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++
         concat [prf (j:ps) t     | (j,t) <- zip [0..] trees]
   prn ps cid = 
-    let lab = "\"" ++ prCId cid ++ "\""
+    let
+      fun = if funs then prCId cid else ""
+      cat = if cats then prCat cid else ""
+      colon = if funs && cats then " : " else ""
+      lab = "\"" ++ fun ++ colon ++ cat ++ "\""
     in (show(show (ps :: [Int])),lab)
   pra i nod t@(Fun cid _) =  nod ++ arr ++ fst (prn i cid) ++ " [style = \"solid\"];"
-  arr = if digr then " -> " else " -- "
+  arr = " -- " -- if digr then " -> " else " -- "
+  prCat = prCId . lookValCat pgf
 
 prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
   graph = if digr then "digraph" else "graph"