Skip to content
Browse files

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).
  • Loading branch information...
1 parent 0c69493 commit 6acf6bace49cfdbbf0ac31b4271a9b7f4ba94d6a @ivan-m ivan-m committed Oct 18, 2011
Showing with 33 additions and 65 deletions.
  1. +2 −2 src/GHC/Vacuum.hs
  2. +0 −12 src/GHC/Vacuum/Pretty.hs
  3. +30 −50 src/GHC/Vacuum/Pretty/Dot.hs
  4. +1 −1 vacuum.cabal
View
4 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
View
12 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
View
80 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]
+ ]
------------------------------------------------
View
2 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,

0 comments on commit 6acf6ba

Please sign in to comment.
Something went wrong with that request. Please try again.