Use graphviz for creating Dot code rather than directly creating it w…

…ith pretty

Documentation needs to be improved: the examples in GHC.Vacuum are no longer valid
(that said, they weren't valid even before this change).

src/GHC/Vacuum.hs

@@ -57,8 +57,7 @@ module GHC.Vacuum (
   ,nameGraph
   ,ShowHNode(..)
   ,showHNodes
-  --,ppHs
-  ,ppDot
+  ,graphToDot
   ,Draw(..),G(..)
   ,draw,printDraw,split
   ,Closure(..)
@@ -78,6 +77,7 @@ import GHC.Vacuum.Q
 import GHC.Vacuum.Util
 import GHC.Vacuum.Types
 import GHC.Vacuum.Pretty
+import GHC.Vacuum.Pretty.Dot
 import GHC.Vacuum.ClosureType
 import GHC.Vacuum.Internal as GHC
 

src/GHC/Vacuum/Pretty.hs

@@ -7,7 +7,6 @@ import Data.List
 import Data.IntMap(IntMap)
 import Data.Monoid(Monoid(..))
 import qualified Data.IntMap as IM
-import Text.PrettyPrint(Doc,text,render)
 --import Language.Haskell.Meta.Utils(pretty)
 import Control.Monad
 
@@ -42,17 +41,6 @@ showHNodes (ShowHNode showN externN) m
 
 -----------------------------------------------------------------------------
 
---ppHs :: (Show a) => a -> Doc
---ppHs = text . pretty
-
-ppDot :: [(String, [String])] -> Doc
-ppDot = graphToDot id
-
-renderDot :: [(String, [String])] -> String
-renderDot = render . ppDot
-
------------------------------------------------------------------------------
-
 -- | To assist in \"rendering\"
 --  the graph to some source.
 data Draw e v m a = Draw

src/GHC/Vacuum/Pretty/Dot.hs

@@ -1,65 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+> import GHC.Vacuum.Pretty.Dot
+> import Data.GraphViz.Commands
+> graphToDotPng :: FilePath -> [(String,[String])] -> IO FilePath
+> graphToDotPng fpre g = addExtension (runGraphviz (graphToDot g)) Png fpre
+-}
 module GHC.Vacuum.Pretty.Dot (
    graphToDot
-  ,ppGraph,ppEdge,gStyle
---   ,Doc,text,render
+  ,graphToDotParams
+  ,vacuumParams
 ) where
 
-import Text.PrettyPrint
-
-------------------------------------------------
+import Data.GraphViz hiding (graphToDot)
+import Data.GraphViz.Attributes.Complete( Attribute(RankDir, Splines, FontName)
+                                        , RankDir(FromLeft), EdgeType(SplineEdges))
 
--- | .
-graphToDot :: (a -> String) -> [(a, [a])] -> Doc
-graphToDot f = ppGraph . fmap (f *** fmap f)
-  where f *** g = \(a, b)->(f a, g b)
+import Control.Arrow(second)
 
 ------------------------------------------------
 
-gStyle :: String
-gStyle = unlines
-  ["  graph [rankdir=LR, splines=true];"
-  ,"  node [label=\"\\N\", shape=none, fontcolor=blue, fontname=courier];"
-  ,"  edge [color=black, style=dotted, fontname=courier, arrowname=onormal];"]
+graphToDot :: (Ord a) => [(a, [a])] -> DotGraph a
+graphToDot = graphToDotParams vacuumParams
 
-ppGraph :: [(String, [String])] -> Doc
-ppGraph xs = (text "digraph g" <+> text "{")
-              $+$ text gStyle
-                $+$ nest indent (vcat . fmap ppEdge $ xs)
-                    $+$ text "}"
-                        where indent = 2
+graphToDotParams :: (Ord a, Ord cl) => GraphvizParams a () () cl l -> [(a, [a])] -> DotGraph a
+graphToDotParams params nes = graphElemsToDot params ns es
+  where
+    ns = map (second $ const ()) nes
 
-ppEdge :: (String, [String]) -> Doc
-ppEdge (x,xs) = (dQText x) <+> (text "->")
-                    <+> (braces . hcat . punctuate semi
-                        . fmap dQText $ xs)
+    es = concatMap mkEs nes
+    mkEs (f,ts) = map (\t -> (f,t,())) ts
 
-dQText :: String -> Doc
-dQText = doubleQuotes . text
+------------------------------------------------
 
-{-
-import System.Cmd
-import System.Exit
-graphToDotPng :: FilePath -> [(String,[String])] -> IO Bool
-graphToDotPng fpre g = do
-  let [dot,png] = fmap (fpre++) [".dot",".png"]
-  writeFile dot
-    . render . ppGraph
-      -- . fmap (show***fmap show)
-        $ g
-  ((==ExitSuccess) `fmap`) .system . intercalate " " $
-    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
-    ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","display",png,"&"]
+vacuumParams :: GraphvizParams a () () () ()
+vacuumParams = defaultParams { globalAttributes = gStyle }
 
-graphToDotPdf :: FilePath -> [(String,[String])] -> IO Bool
-graphToDotPdf fpre g = do
-  let [dot,png] = fmap (fpre++) [".dot",".pdf"]
-  writeFile dot
-    . render . ppGraph
-      -- . fmap (show***fmap show)
-        $ g
-  ((==ExitSuccess) `fmap`) .system . intercalate " " $
-    -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]
-    ["cat",dot,"tred","|","dot -Tpdf",">",png,"2>/dev/null;","evince",png,"&"]
--}
+gStyle :: [GlobalAttributes]
+gStyle = [ GraphAttrs [RankDir FromLeft, Splines SplineEdges, FontName "courier"]
+         , NodeAttrs  [textLabel "\\N", shape PlainText, fontColor Blue]
+         , EdgeAttrs  [color Black, style dotted]
+         ]
 
 ------------------------------------------------

vacuum.cabal

@@ -19,7 +19,7 @@ library
   extensions:       CPP, BangPatterns
   includes:         ghcautoconf.h
   build-depends:    base==4.*, ghc-prim, array,
-                    containers, pretty
+                    containers, graphviz == 2999.12.*
                     -- haskell-src-meta
 
   exposed-modules:  GHC.Vacuum,