"Committed_by_peb"

2 files changed, 62 insertions, 3 deletions

diff --git a/src/GF/Conversion/TypeGraph.hs b/src/GF/Conversion/TypeGraph.hs
new file mode 100644
index 000000000..3a8d9f2d4
--- /dev/null
+++ b/src/GF/Conversion/TypeGraph.hs
@@ -0,0 +1,55 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/05 11:56:42 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Printing the type hierarchy of an abstract module in GraphViz format
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+
+import GF.Data.Operations ((++++), (+++++))
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+-- | SimpleGFC to TypeGraph
+--
+-- assumes that the profiles in the Simple GFC names are trivial
+
+prtTypeGraph :: SGrammar -> String
+prtTypeGraph rules = "digraph TypeGraph {" ++++ 
+                     "concentrate=true;" ++++
+                     "node [shape=ellipse];" +++++
+                     unlines (map prtTypeGraphRule rules) +++++
+                     "}"
+
+prtTypeGraphRule :: SRule -> String
+prtTypeGraphRule (Rule (Abs cat cats (Name fun _prof)) _)
+    = unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ]
+
+prtFunctionGraph :: SGrammar -> String
+prtFunctionGraph rules = "digraph FunctionGraph {" ++++ 
+                         "node [shape=ellipse];" +++++
+                         unlines (map prtFunctionGraphRule rules) +++++
+                         "}"
+
+prtFunctionGraphRule :: SRule -> String
+prtFunctionGraphRule (Rule (Abs cat cats (Name fun _prof)) _)
+    = prt fun ++ " [shape=box, style=dashed];" ++++
+      prt fun ++ " -> " ++ prtSCat cat ++ ";" ++++
+      unlines [ prtSCat c ++ " -> " ++ prt fun ++ ";" | c <- cats ]
+
+prtSCat (Decl var cat args) = prt cat
+
+
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 15e909004..f5ed30009 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/29 13:20:08 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.75 $
+-- > CVS $Date: 2005/10/05 11:56:42 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.76 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -81,6 +81,7 @@ import qualified GF.Conversion.GFC as Cnv
 import qualified GF.Conversion.Types as CnvTypes
 import qualified GF.Conversion.Haskell as CnvHaskell
 import qualified GF.Conversion.Prolog as CnvProlog
+import qualified GF.Conversion.TypeGraph as CnvTypeGraph
 import GF.Canon.Unparametrize
 import GF.Canon.Subexpressions
 
@@ -278,6 +279,9 @@ customGrammarPrinter =
   ,(strCI "pinfo",    Prt.prt . statePInfo)
   ,(strCI "abstract", Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang)
 
+  ,(strCI "functiongraph",CnvTypeGraph.prtFunctionGraph . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
+  ,(strCI "typegraph",    CnvTypeGraph.prtTypeGraph . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
+
   ,(strCI "gfc-haskell",  CnvHaskell.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
   ,(strCI "mcfg-haskell", CnvHaskell.prtMGrammar . stateMCFG)
   ,(strCI "cfg-haskell",  CnvHaskell.prtCGrammar . stateCFG)