packages feed

tracetree (empty) → 0.1.0.0

raw patch · 14 files changed

+1099/−0 lines, 14 filesdep +SVGFontsdep +basedep +bifunctorssetup-changed

Dependencies added: SVGFonts, base, bifunctors, colour, containers, diagrams-cairo, diagrams-contrib, diagrams-lib, json, mtl, optparse-applicative, parsec, regex-posix, tracetree, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Edsko de Vries++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Edsko de Vries nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Debug/Trace/Tree.hs view
@@ -0,0 +1,27 @@+-- | Exports most commonly used functionality+module Debug.Trace.Tree (+    -- * Labelled rose trees+    ETree(..)+    -- * Simple trees+  , SimpleTree(..)+    -- * Generic generation+  , GSimpleTree(..)+    -- * Trace operations+  , gtraceJson+  ) where++import System.IO.Unsafe+import Text.JSON++import Debug.Trace.Tree.Edged+import Debug.Trace.Tree.Simple+import Debug.Trace.Tree.Generic++{-------------------------------------------------------------------------------+  Tracing operations+-------------------------------------------------------------------------------}++gtraceJson :: GSimpleTree b => FilePath -> (a -> b) -> a -> a+gtraceJson fp f x = unsafePerformIO $ do+    writeFile fp (encode . showJSON . fromGeneric . f $ x)+    return x
+ src/Debug/Trace/Tree/Assoc.hs view
@@ -0,0 +1,43 @@+-- | Association lists+--+-- Intended to be double imported:+--+-- > import Debug.Trace.Tree.Assoc+-- > import qualified Debug.Trace.Tree.Assoc as Assoc+module Debug.Trace.Tree.Assoc (+    Assoc(..)+  , pattern Singleton+  ) where++import Data.Bifunctor+import Data.Functor.Compose++{-------------------------------------------------------------------------------+  Main datatype+-------------------------------------------------------------------------------}++newtype Assoc k v = Assoc { assocList :: [(k, v)] }+  deriving (Show, Eq)++pattern Singleton :: k -> v -> Assoc k v+pattern Singleton k v = Assoc [(k, v)]++{-------------------------------------------------------------------------------+  Standard type class instances+-------------------------------------------------------------------------------}++instance Bifunctor Assoc where+  bimap f g (Assoc vs) = Assoc (map (bimap f g) vs)++instance Functor (Assoc k) where+  fmap = second++instance Foldable (Assoc k) where+  foldMap f = foldMap f . Compose . assocList++instance Traversable (Assoc k) where+  traverse f = fmap (Assoc . getCompose) . traverse f . Compose . assocList++instance Monoid (Assoc k v) where+  mempty = Assoc mempty+  (Assoc xs) `mappend` (Assoc ys) = Assoc (xs `mappend` ys)
+ src/Debug/Trace/Tree/Edged.hs view
@@ -0,0 +1,157 @@+-- | Edge-labelled rose trees+--+-- Intended to be double imported:+--+-- > import Debug.Trace.Tree.Edged+-- > import qualified Debug.Trace.Tree.Edged as Edged+module Debug.Trace.Tree.Edged (+    ETree(..)+    -- * Standard operations+  , elems+  , keys+  , mapEdges+    -- * Hiding nodes+  , Hide(..)+  , hideNodes+    -- * Annotation+  , Depth+  , Offset+  , Coords(..)+  , Metadata(..)+  , annotate+    -- * Interaction between ETree and Tree+  , pushEdges+  , pullEdges+  , liftTree+  , liftTree'+  ) where++import Data.Bifunctor+import Data.Foldable+import Data.Tree (Tree)+import qualified Data.Tree as Tree++import Debug.Trace.Tree.Assoc+import Debug.Trace.Tree.Rose (Depth, Offset, Coords(..), Metadata(..))+import qualified Debug.Trace.Tree.Rose as Rose++{-------------------------------------------------------------------------------+  Main datatype+-------------------------------------------------------------------------------}++-- | Tree with nodes labelled with @v@ and arrows labelled with @k@+data ETree k v = Node v (Assoc k (ETree k v))+  deriving (Show, Eq)++{-------------------------------------------------------------------------------+  Standard type class instances+-------------------------------------------------------------------------------}++instance Bifunctor ETree where+  bimap f g (Node v ts) = Node (g v) (bimap f (bimap f g) ts)++instance Functor (ETree k) where+  fmap = second++instance Foldable (ETree k) where+  foldMap f (Node v ts) = f v `mappend` foldMap (foldMap f) ts++instance Traversable (ETree k) where+  traverse f (Node v ts) = Node <$> f v <*> traverse (traverse f) ts++{-------------------------------------------------------------------------------+  Standard operations+-------------------------------------------------------------------------------}++elems :: ETree k v -> [v]+elems = toList++keys :: ETree k v -> [k]+keys (Node _ (Assoc ts)) = concatMap aux ts+  where+    aux :: (k, ETree k v) -> [k]+    aux (k, t) = k : keys t++-- | Change the edges of the tree, providing source and target+mapEdges :: (v -> v -> k -> k') -> ETree k v -> ETree k' v+mapEdges f (Node v (Assoc ts)) = Node v (Assoc (map go ts))+  where+    go (k, t@(Node v' _)) = (f v v' k, mapEdges f t)++{-------------------------------------------------------------------------------+  Additional operations+-------------------------------------------------------------------------------}++annotate :: ETree k v -> ETree k (v, Metadata)+annotate = liftTree' Rose.annotate++{-------------------------------------------------------------------------------+  Hiding nodes+-------------------------------------------------------------------------------}++-- | Specification of nodes to hide+data Hide =+    -- | Hide the node at the specified coordinates+    HideNode Coords++instance Show Hide where+    show (HideNode Coords{..}) = "node(" ++ show depth ++ "," ++ show offset ++ ")"++-- | Check if a certain node should be hidden+isHidden :: [Hide] -> Metadata -> Bool+isHidden spec Metadata{..} = any hides spec+  where+    hides :: Hide -> Bool+    hides (HideNode coords') = coords == coords'++hideNodes :: forall k v. [Hide] -> ETree k (v, Metadata) -> ETree k (Maybe v, Metadata)+hideNodes spec = go+  where+    go :: ETree k (v, Metadata) -> ETree k (Maybe v, Metadata)+    go (Node (v, meta) (Assoc ts))+      | isHidden spec meta = Node (Nothing , meta) $ Assoc []+      | otherwise          = Node (Just v  , meta) $ Assoc (map (second go) ts)++{-------------------------------------------------------------------------------+  Interaction between ETree and Tree+-------------------------------------------------------------------------------}++-- | Push each edge label to a subtree into the node of that subtree+--+-- Since there is no edge to the root of the tree, the "edge" to that root+-- must be passed in as an argument.+pushEdges :: k -> ETree k v -> Tree (k, v)+pushEdges k (Node v (Assoc ts)) = Tree.Node (k, v) (map (uncurry pushEdges) ts)++-- | Inverse of 'pushEdges'+pullEdges :: Tree (k, v) -> (k, ETree k v)+pullEdges (Tree.Node (k, v) ts) = (k, Node v (Assoc (map pullEdges ts)))++-- | Lift an labelling function on trees to edged trees+liftTree :: (Tree (k, v) -> Tree ((k, v), b))+         -> k -> ETree k v -> ETree k (v, b)+liftTree f k = snd . pullEdges . fmap assoc . f . pushEdges k+  where+    assoc ((x, y), z) = (x, (y, z))++-- | Variation on 'liftTree' for functions which don't need the edges+liftTree' :: (forall a. Tree a -> Tree (a, b))+          -> ETree k v -> ETree k (v, b)+liftTree' f = snd . pullEdges . fmap assoc . f . pushEdges undefined+  where+    assoc ((x, y), z) = (x, (y, z))++{-------------------------------------------------------------------------------+  Debugging+-------------------------------------------------------------------------------}++_testETree :: ETree String String+_testETree =+  Node "a" (Assoc [ ("e1", Node "b" (Assoc [ ("e2", Node "d" (Assoc []))+                                           , ("e3", Node "e" (Assoc []))+                                           ])+                    )+                  , ("e4", Node "c" (Assoc [ ("e5", Node "f" (Assoc []))+                                           ])+                    )+                  ])
+ src/Debug/Trace/Tree/Generic.hs view
@@ -0,0 +1,86 @@+-- | Generic translation to SimpleTrees using GHC.Generics+module Debug.Trace.Tree.Generic (+    GSimpleTree(..)+  ) where++import Control.Monad.State+import Data.Bifunctor+import Data.Map (Map)+import GHC.Generics+import qualified Data.Map as Map++import Debug.Trace.Tree.Assoc+import Debug.Trace.Tree.Simple++{-------------------------------------------------------------------------------+  Translation from arbitrary datatypes to SimpleTree using GHC.Generics+-------------------------------------------------------------------------------}++class GSimpleTree a where+  fromGeneric :: a -> SimpleTree+  default fromGeneric :: (Generic a, GToTree (Rep a)) => a -> SimpleTree+  fromGeneric = gtoTree . from++instance GSimpleTree ()+instance GSimpleTree Bool+instance (GSimpleTree a, GSimpleTree b) => GSimpleTree (a, b)+instance (GSimpleTree a, GSimpleTree b, GSimpleTree c) => GSimpleTree (a, b, c)++instance GSimpleTree Char where fromGeneric = Leaf . show+instance GSimpleTree Int  where fromGeneric = Leaf . show++-- For map we do something special, and create edges for each key in the map+instance GSimpleTree a => GSimpleTree (Map String a) where+  fromGeneric = Node "Map" . Assoc . map (second fromGeneric) . Map.toList++-- Similarly, for lists we create numbered edges+instance {-# OVERLAPPABLE #-} GSimpleTree a => GSimpleTree [a] where+  fromGeneric xs = Node "[]" $ Assoc [ (show i, fromGeneric x)+                                     | i <- [0..] :: [Int]+                                     | x <- xs+                                     ]++instance GSimpleTree String where+  fromGeneric = Leaf++{-------------------------------------------------------------------------------+  Top-level generic translation+-------------------------------------------------------------------------------}++class GToTree f where+  gtoTree :: f a -> SimpleTree++instance GToTree f => GToTree (M1 D d f) where+  gtoTree (M1 x) = gtoTree x++instance (Constructor c, GToTrees f) => GToTree (M1 C c f) where+  gtoTree c@(M1 x) = Node (conName c) (evalState (gtoTrees x) 0)++instance (GToTree f, GToTree g) => GToTree (f :+: g) where+  gtoTree (L1 x) = gtoTree x+  gtoTree (R1 x) = gtoTree x++instance GSimpleTree a => GToTree (K1 R a) where+  gtoTree (K1 x) = fromGeneric x++{-------------------------------------------------------------------------------+  Generic translation for constructor arguments++  The state is used to assign names to unnamed constructor arguments.+-------------------------------------------------------------------------------}++class GToTrees f where+  gtoTrees :: f a -> State Int (Assoc String SimpleTree)++instance GToTrees U1 where+  gtoTrees U1 = return $ Assoc []++instance (GToTrees f, GToTrees g) => GToTrees (f :*: g) where+  gtoTrees (x :*: y) = mappend <$> gtoTrees x <*> gtoTrees y++instance (Selector s, GToTree f) => GToTrees (M1 S s f) where+  gtoTrees s@(M1 x) = Singleton <$> mkName (selName s) <*> pure (gtoTree x)+    where+      mkName :: String -> State Int String+      mkName "" = state $ \i -> (show i, i + 1)+      mkName nm = return nm
+ src/Debug/Trace/Tree/Rose.hs view
@@ -0,0 +1,146 @@+-- | Additional operations on standard rose trees+module Debug.Trace.Tree.Rose (+    -- * Annotating nodes+    Depth+  , Offset+  , Coords(..)+  , Metadata(..)+  , annotate+  ) where++import Control.Monad.State+import Data.Tree++{-------------------------------------------------------------------------------+  Annotating the tree+-------------------------------------------------------------------------------}++-- | Depth of a node in the tree+type Depth = Int++-- | Offset of a node in the tree+--+-- This is the horizontal offset of a node across all nodes at that depth.+--+-- For example, the offsets of+--+-- >     A+-- >    / \+-- >   B   C+-- >  / \   \+-- > D   E   F+--+-- are given by+--+-- >       (A,0)+-- >        / \+-- >    (B,0)  (C,1)+-- >     / \      \+-- > (D,0)  (E,1)  (F,2)+--+-- Similarly, the offsets of+--+-- >   A+-- >  / \+-- > B   C+-- >    / \+-- >   D   E+--+-- are given by+--+-- >    (A,0)+-- >     / \+-- > (B,0) (C,1)+-- >       /   \+-- >   (D,0)   (E,1)+--+-- Note that in this second example, D gets number 0 because it's the first+-- node at this level; it's therefore not the case that the nodes with number 0+-- necessarily make up the _spine_ of the tree.+type Offset = Int++-- | Coordinates of a node in the tree+data Coords = Coords {+      depth  :: Depth  -- ^ The "y coordinate" (depth in the tree)+    , offset :: Offset -- ^ The "x coordinate" (across all nodes at this depth)+    }+  deriving (Show, Eq, Ord)++-- | Metadata of a node in the tree+data Metadata = Metadata {+      isSpine      :: Bool+    , isFirstChild :: Bool+    , coords       :: Coords+    }+  deriving (Show, Eq, Ord)++{-------------------------------------------------------------------------------+  Auxiliary: operations on trees+-------------------------------------------------------------------------------}++-- | Mark the spine of a tree+markSpine :: Tree a -> Tree (a, Bool)+markSpine = go True+  where+    go :: Bool -> Tree a -> Tree (a, Bool)+    go isSpine (Node a ts) = Node (a, isSpine)+                           $ map (uncurry go) $ zip (isSpine : repeat False) ts++-- | Mark the first child of each node+markFirstChild :: Tree a -> Tree (a, Bool)+markFirstChild = go True+  where+    go :: Bool -> Tree a -> Tree (a, Bool)+    go isFirst (Node a ts) = Node (a, isFirst)+                           $ map (uncurry go) $ zip (True : repeat False) ts++-- | Mark each node with its depth in the tree+markDepth :: Tree a -> Tree (a, Depth)+markDepth = go 0+  where+    go :: Depth -> Tree a -> Tree (a, Depth)+    go d (Node a ts) = Node (a, d) $ map (go (d + 1)) ts++-- | Mark each node with its coordinates+markCoords :: forall a. Tree a -> Tree (a, Coords)+markCoords t = evalState (unfoldTreeM_BF go (markDepth t)) (Coords 0 0)+  where+    go :: MonadState Coords m+       => Tree (a, Depth) -> m ((a, Coords), [Tree (a, Depth)])+    go (Node (a, depth) ts) = do+      cs <- state $ \(Coords curDepth curOffset) ->+              if depth > curDepth -- first node at the next depth level?+                then (Coords depth 0         , Coords depth 1)+                else (Coords depth curOffset , Coords depth (curOffset + 1))+      return ((a, cs), ts)++annotate :: Tree a -> Tree (a, Metadata)+annotate = fmap aux+         . markCoords+         . markFirstChild+         . markSpine+  where+    aux :: (((a, Bool), Bool), Coords) -> (a, Metadata)+    aux (((a, isSpine), isFirstChild), coords) = (a, Metadata{..})++{-------------------------------------------------------------------------------+  Debugging+-------------------------------------------------------------------------------}++_testTree :: Tree String+_testTree =+  Node "a" [ Node "b" [ Node "d" []+                      , Node "e" []+                      ]+           , Node "c" [ Node "f" []+                      ]+           ]++-- Tree with deeper nodes on the right than on the left+_testTree2 :: Tree String+_testTree2 =+  Node "a" [ Node "b" []+           , Node "c" [ Node "d" []+                      , Node "e" []+                      ]+           ]
+ src/Debug/Trace/Tree/Simple.hs view
@@ -0,0 +1,67 @@+-- | Simple trees (edged trees with strings everywhere)+--+-- Intended to be double imported:+--+-- > import Debug.Trace.Tree.Simple+-- > import qualified Debug.Trace.Tree.Simple as Simple+module Debug.Trace.Tree.Simple (+    SimpleTree+  , simpleETree+  , pattern Node+  , pattern Leaf+  ) where++import Text.JSON+import Debug.Trace.Tree.Edged (ETree)+import Debug.Trace.Tree.Assoc+import qualified Debug.Trace.Tree.Edged as Edged++{-------------------------------------------------------------------------------+  Trees containing only strings+-------------------------------------------------------------------------------}++newtype SimpleTree = SimpleTree { simpleETree :: ETree String String }+  deriving (Show, Eq)++pattern Node :: String -> Assoc String SimpleTree -> SimpleTree+pattern Node v ts <- SimpleTree (Edged.Node v (fmap SimpleTree -> ts))+  where+    Node v ts = SimpleTree (Edged.Node v (fmap simpleETree ts))++pattern Leaf :: String -> SimpleTree+pattern Leaf v = Node v (Assoc [])++{-------------------------------------------------------------------------------+  Serialization to and from JSON+-------------------------------------------------------------------------------}++instance JSON SimpleTree where+  showJSON (Leaf v   ) = String   v+  showJSON (Node v ts) = JsonTree v $ fmap showJSON ts+  showJSON _ = error "inaccessible"++  readJSON (String   v)    = return $ Leaf v+  readJSON (JsonTree v ts) = Node v <$> traverse readJSON ts+  readJSON _ = fail "Invalid JSON"++{-------------------------------------------------------------------------------+  Auxiliary: patterns for working with JSValue+-------------------------------------------------------------------------------}++pattern JsonTree :: String -> Assoc String JSValue -> JSValue+pattern JsonTree v ts <- SingletonObject v (Object (Assoc -> ts))+  where+    JsonTree v ts = SingletonObject v (Object (assocList ts))++pattern SingletonObject :: String -> JSValue -> JSValue+pattern SingletonObject k v = Object [(k, v)]++pattern String :: String -> JSValue+pattern String str <- JSString (fromJSString -> str)+  where+    String str = JSString (toJSString str)++pattern Object :: [(String, JSValue)] -> JSValue+pattern Object obj <- JSObject (fromJSObject -> obj)+  where+    Object obj = JSObject (toJSObject obj)
+ tracetree.cabal view
@@ -0,0 +1,106 @@+name:                tracetree+version:             0.1.0.0+synopsis:            Visualize Haskell data structures as edge-labeled trees+description:         The tracetree library can be used to conveniently write+                     Haskell data structures as trees represented as JSON+                     files. These JSON files can then be inspected with any+                     JSON viewer; the JSON viewer's functionality to collapse+                     part of the JSON tree can be particularly convenient when+                     exploring large objects.+                     .+                     Additionally, the ttrender executable can be used to render+                     these JSON trees as .svg or .png files, and provides+                     various command line flags for controlling the layout of+                     the tree (colour, orientation, hiding nodes, etc.).+                     .+                     The tracetree library and ttrender executable are+                     independent components; if you don't want to add the+                     dependency on tracetree to your project, you can just+                     generate the .JSON files directly in your code; the format+                     is not complicated (indeed, you can create them by hand+                     or post-process previously exported .JSON files). +license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Development+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/edsko/tracetree++flag ttrender+  description: Build executable to render the trees (requires Cairo)+  default: False++library+  exposed-modules:     Debug.Trace.Tree+                       Debug.Trace.Tree.Assoc+                       Debug.Trace.Tree.Edged+                       Debug.Trace.Tree.Generic+                       Debug.Trace.Tree.Rose+                       Debug.Trace.Tree.Simple+  -- We need ghc 7.10 (using bidrectional pattern synonyms),+  -- but I don't know how to specify that other through the version of base+  build-depends:       base         >= 4.8 && < 5,+                       bifunctors   >= 4.2 && < 4.3,+                       containers   >= 0.5 && < 0.6,+                       json         >= 0.9 && < 0.10,+                       mtl          >= 2.2 && < 2.3,+                       transformers >= 0.4 && < 0.5+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall+  default-extensions:  DefaultSignatures+                       FlexibleContexts+                       FlexibleInstances+                       NoMonomorphismRestriction+                       ParallelListComp+                       PatternSynonyms+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+                       TupleSections+                       TypeOperators+                       ViewPatterns+  -- other-extensions:++executable ttrender+  main-is:             Main.hs+  other-modules:       Debug.Trace.Tree.Render.Edged+                       Debug.Trace.Tree.Render.Options+                       Debug.Trace.Tree.Render.Simple+                       Debug.Trace.Tree.Render.Constants++  if flag(ttrender)+    build-depends:     base                 >= 4.8  && < 5,+                       colour               >= 2.3  && < 2.4,+                       json                 >= 0.9  && < 0.10,+                       optparse-applicative >= 0.11 && < 0.12,+                       regex-posix          >= 0.95 && < 0.96,+                       parsec               >= 3.1  && < 3.2,+                       diagrams-cairo       >= 1.3  && < 1.4,+                       diagrams-lib         >= 1.3  && < 1.4,+                       diagrams-contrib     >= 1.3  && < 1.4,+                       SVGFonts             >= 1.5  && < 1.6,+                       -- whatever version we use above+                       tracetree+  else+    buildable:         False++  hs-source-dirs:      ttrender+  default-language:    Haskell2010+  default-extensions:  BangPatterns+                       FlexibleContexts+                       NoMonomorphismRestriction+                       PatternSynonyms+                       RecordWildCards+                       ScopedTypeVariables+                       TupleSections+                       TypeFamilies+                       ViewPatterns+  ghc-options:         -Wall
+ ttrender/Debug/Trace/Tree/Render/Constants.hs view
@@ -0,0 +1,34 @@+-- | Rendering constants+module Debug.Trace.Tree.Render.Constants where++-- | Minimum distance between nodes in the tree+constTreeHSep, constTreeVSep :: Double+constTreeHSep = 25+constTreeVSep = 25++-- | Extra space left between (the side of) edge labels and (a point on)+-- the lines that make up the arrows in the tree+constEdgePadding :: Double+constEdgePadding = 10++-- | Text height for node and edge labels+constNodeLabelHeight, constEdgeLabelHeight :: Double+constNodeLabelHeight = 25+constEdgeLabelHeight = 10++-- | Text height when overlaying coordinates+constCoordsOverlay :: Double+constCoordsOverlay = 35++-- | Length of the dashes to missing nodes+constMissingNodeDash :: Double+constMissingNodeDash = 5++-- | Arrow head length and line width+constArrowHeadLength, constArrowLineWidth :: Double+constArrowHeadLength = 8+constArrowLineWidth  = 1++-- | Padding around nodes+constNodePadding :: Double+constNodePadding = 5
+ ttrender/Debug/Trace/Tree/Render/Edged.hs view
@@ -0,0 +1,128 @@+module Debug.Trace.Tree.Render.Edged (renderTree) where++import Data.Bifunctor+import Data.Maybe (fromMaybe)+import Diagrams.Backend.Cairo (B)+import Diagrams.Prelude hiding (coords, offset)+import Diagrams.TwoD.Layout.Tree (SymmLayoutOpts)+import Graphics.SVGFonts+import qualified Diagrams.TwoD.Layout.Tree as Diagrams.Tree++import Debug.Trace.Tree.Edged+import Debug.Trace.Tree.Render.Constants++{-------------------------------------------------------------------------------+  Main rendering algorithm+-------------------------------------------------------------------------------}++-- | Node IDs allocated by 'Diagrams.Tree.label'+type PID = Int++renderTree :: forall k v.+              (v -> v -> k -> (Diagram B, ArrowOpts Double))+           -> (v -> Diagram B)+           -> Bool                  -- ^ Show coordinates?+           -> ETree k (v, Metadata) -- ^ Tree with metadata+           -> Diagram B+renderTree drK' drV' showCoords t =+    addArrows (arrows positioned) (nodes positioned)+  where+    -- Step 1. Render the individual tree nodes and the annotations on the edges+    drawn :: ETree (Diagram B, ArrowOpts Double) (Diagram B, Metadata)+    drawn = second drV . mapEdges drK $ t+      where+        drK :: (v, meta) -> (v, meta) -> k -> (Diagram B, ArrowOpts Double)+        drK (v, _) (v', _) k = drK' v v' k++        drV :: (v, Metadata) -> (Diagram B, Metadata)+        drV (v, meta) =+          let rendered | showCoords = drV' v <> renderCoords (coords meta)+                       | otherwise  = drV' v+          in (rendered, meta)++    -- Step 2. Assign IDs to all nodes and pair each node with its ID+    labelled :: ETree (Diagram B, ArrowOpts Double) (Diagram B, Metadata, PID)+    labelled = fmap (\((d, meta), n) -> (d # named n, meta, n))+             $ Diagrams.Tree.label drawn -- pair with unique IDs++    -- Step 3. Compute tree layout and move all nodes to their final location+    positioned :: ETree (Diagram B, ArrowOpts Double) (Diagram B, Metadata, PID)+    positioned = fmap (\((d, meta, n), p) -> (d # moveTo p, meta, n))+               $ symmLayout'' symmOpts (mempty, with)+               $ labelled++    -- Step 4. Extract nodes from the positioned tree+    --(Just extract all nodes and mappend them all together)+    nodes :: ETree a (Diagram B, meta, pid) -> Diagram B+    nodes = foldMap $ \(node, _meta, _n) -> node++    -- Step 5. Extract arrows from the positioned tree+    arrows :: ETree (Diagram B, ArrowOpts Double) (a, Metadata, PID) -> Arrows+    arrows = mconcat . keys . mapEdges aux+      where+        aux :: (a, Metadata, PID) -> (a, Metadata, PID)+            -> (Diagram B, ArrowOpts Double) -> Arrows+        aux (_, _parent, n) (_, child, n') (lbl, arrOpts) =+          connectLabelled arrOpts lbl (isFirstChild child) n n'++    symmOpts :: SymmLayoutOpts Double ((Diagram B, ArrowOpts Double), (Diagram B, Metadata, PID))+    symmOpts = with & Diagrams.Tree.slWidth  .~ computeWidth+                    & Diagrams.Tree.slHeight .~ computeHeight+                    & Diagrams.Tree.slHSep   .~ constTreeHSep+                    & Diagrams.Tree.slVSep   .~ constTreeVSep+      where+        -- We don't know where the label will be placed. In the worst case,+        -- the label is positioned to start or end precisely at the center+        -- of the node, so we allow for the worst case here.+        computeWidth ((edge, _opts), (node, _meta, _n)) =+          let (edgeMinX, edgeMaxX) = fromMaybe (0,0) $ extentX edge+              (nodeMinX, nodeMaxX) = fromMaybe (0,0) $ extentX node+              edgeWidth = edgeMaxX - edgeMinX+          in (negate edgeWidth `min` nodeMinX, edgeWidth `max` nodeMaxX)++        -- For the height we ignore the edge labels+        computeHeight ((_edge, _opts), (node, _meta, _n)) =+          fromMaybe (0,0) $ extentY node++-- | Lift standard layout algorithm to edged trees+symmLayout'' :: SymmLayoutOpts Double (k, v) -> k -> ETree k v -> ETree k (v, P2 Double)+symmLayout'' opts = liftTree (Diagrams.Tree.symmLayout' opts)++-- | Render coordinates+--+-- Note that these coordinates are not expected ever in the final diagram; they+-- are used only during diagram construction. So we don't need to worry too much+-- about how exactly they look.+renderCoords :: Coords -> Diagram B+renderCoords Coords{..} =+      stroke (textSVG (show (depth, offset)) constCoordsOverlay)+    # fc red+    # lw (global 0.5)++{-------------------------------------------------------------------------------+  Diagrams auxiliary: labelled arrows+-------------------------------------------------------------------------------}++newtype Arrows = Arrows { addArrows :: Diagram B -> Diagram B }++instance Monoid Arrows where+  mempty = Arrows id+  Arrows f `mappend` Arrows g = Arrows (f . g)++-- based on 'connectOutside'+connectLabelled :: ArrowOpts Double -> Diagram B -> Bool -> Int -> Int -> Arrows+connectLabelled opts edgeLabel labelOnLeft n1 n2 = Arrows $+  withName n1 $ \b1 ->+  withName n2 $ \b2 ->+    let v = location b2 .-. location b1+        midpoint = location b1 .+^ (v/2)+        s' = fromMaybe (location b1) $ traceP midpoint (-v) b1+        e' = fromMaybe (location b2) $ traceP midpoint v b2+        lbl = edgeLabel+            # (if labelOnLeft+                 then translateX (negate constEdgePadding) . alignR+                 else translateX         constEdgePadding  . alignL+              )+            # moveTo midpoint+    in+      atop (lbl <> arrowBetween' opts s' e')
+ ttrender/Debug/Trace/Tree/Render/Options.hs view
@@ -0,0 +1,149 @@+-- | Render simple trees+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Debug.Trace.Tree.Render.Options (RenderOptions(..), applyOptions) where++import Data.Bifunctor+import Data.Colour (Colour)+import Data.Colour.Names (readColourName)+import Data.Maybe (isJust)+import Data.List (groupBy)+import Data.Function (on)+import Diagrams.Backend.CmdLine (Parseable(..))+import Options.Applicative+import qualified Text.Parsec        as Parsec+import qualified Text.Parsec.String as Parsec++import Debug.Trace.Tree.Simple (SimpleTree, simpleETree)+import Debug.Trace.Tree.Edged (ETree, Hide(..), Metadata, Coords(..))+import Debug.Trace.Tree.Assoc (Assoc(..))+import qualified Debug.Trace.Tree.Edged  as Edged+import qualified Debug.Trace.Tree.Simple as Simple++data RenderOptions = RenderOptions {+    renderHideNodes    :: [Hide]+  , renderMerge        :: [String]+  , renderVertical     :: [String]+  , renderColours      :: [(String, Colour Double)]+  , renderMaxNotShown  :: Int+  , renderDelChildren  :: [String]+  , renderShowCoords   :: Bool+  , renderInput        :: FilePath+  }++instance Parseable RenderOptions where+  parser = RenderOptions+    <$> ( many (option readHide $ mconcat [+            long "hide"+          , metavar "HIDE"+          , help "Hide certain nodes in the tree; arrows to these nodes are shown as dangling (modulo the max-not-shown option). Valid syntax for the argument is: \"node(y,x)\": Hide the node at the specified level. Can be used multiple times."+          ]))+    <*> ( many (strOption $ mconcat [+            long "merge"+          , metavar "C"+          , help "Collapse any tree of shape (C' .. (C args) ..) to (C' .. args ..). Can be used multiple times."+          ]))+    <*> ( many (strOption $ mconcat [+            long "vertical"+          , metavar "REGEXP"+          , help "Show any node matching the specified regular expression vertically. Can be used multiple times."+          ]))+    <*> ( many (option readColourAssignment $ mconcat [+            long "colour"+          , help "Set the colour for a node. For example --colour P=red sets the background of all P nodes to be red. Can be used multiple times."+          ]))+    <*> ( option auto $ mconcat [+             long "max-not-shown"+           , metavar "Int"+           , value 3+           , showDefault+           , help "Maximum number of edges to hidden nodes (use together with --max-breadths)"+           ])+    <*> ( many (strOption $ mconcat [+             long "delete-children"+           , help "Delete the children of the specified node. This actually removes the children from the tree, no dangling arrows are shown. Can be used multiple times."+           ]))+    <*> ( switch $ mconcat [+             long "show-coords"+           , help "Superimpose node coordinates when rendering the tree. Useful when figuring out which arguments to pass to --hide."+           ])+    <*> ( argument str (metavar "JSON") )++readHide :: ReadM Hide+readHide = do+    arg <- str+    case Parsec.parse parseHide "HIDE" arg of+      Left  err  -> fail (show err)+      Right hide -> return hide++readColourAssignment :: ReadM (String, Colour Double)+readColourAssignment = do+    arg <- str+    case break (== '=') arg of+      (constr, '=':colour) -> (constr,) <$> readColourName colour+      _ -> fail "Invalid colour assignment"++applyOptions :: RenderOptions -> SimpleTree -> ETree String (Maybe String, Metadata)+applyOptions RenderOptions{..} =+      applyMaxNotShown renderMaxNotShown+    . Edged.hideNodes renderHideNodes+    . Edged.annotate+    . simpleETree+    . applyMerge renderMerge+    . applyDelChildren renderDelChildren++applyMerge :: [String] -> SimpleTree -> SimpleTree+applyMerge toMerge (Simple.Node c' (Assoc ts)) =+    Simple.Node c' . fmap (applyMerge toMerge) . Assoc $ concatMap aux ts+  where+    aux t@(_, Simple.Node c (Assoc ts'))+      | c `elem` toMerge = ts'+      | otherwise        = [t]+    aux _ = error "inaccessible"+applyMerge _ _ = error "inaccessible"++applyDelChildren :: [String] -> SimpleTree -> SimpleTree+applyDelChildren toHide = go+  where+    go (Simple.Node c (Assoc ts))+      | c `elem` toHide = Simple.Node c (Assoc [])+      | otherwise       = Simple.Node c (Assoc (map (second go) ts))+    go _ = error "inaccessible"++applyMaxNotShown :: Int -> ETree String (Maybe String, Metadata) -> ETree String (Maybe String, Metadata)+applyMaxNotShown n = \(Edged.Node c (Assoc ts)) ->+    let culled = concatMap aux (groupBy ((==) `on` isShown) ts)+    in Edged.Node c $ fmap (applyMaxNotShown n) (Assoc culled)+  where+    -- Replace each group of hidden nodes with an ellipsis (if larger than n)+    -- We re-use the node metadata of the first node in the group+    aux :: [(String, ETree String (Maybe String, Metadata))]+        -> [(String, ETree String (Maybe String, Metadata))]+    aux [] = error "impossible: groupBy does not create empty groups"+    aux ts@(t:_)+      | not (isShown t) && length ts > n = [ellipsis (rootMeta (snd t))]+      | otherwise                        = ts++    ellipsis :: Metadata -> (String, ETree String (Maybe String, Metadata))+    ellipsis meta = ("...", Edged.Node (Nothing, meta) (Assoc []))++    isShown :: (String, ETree String (Maybe String, meta)) -> Bool+    isShown (_key, (Edged.Node (c', _coords) _subtree)) = isJust c'++    rootMeta :: ETree k (v, Metadata) -> Metadata+    rootMeta (Edged.Node (_, meta) _) = meta++{-------------------------------------------------------------------------------+  Parser for Hide+-------------------------------------------------------------------------------}++parseHide :: Parsec.Parser Hide+parseHide = parseHideNode++parseHideNode :: Parsec.Parser Hide+parseHideNode = do+    Parsec.string "node("+    y <- Parsec.many1 Parsec.digit+    Parsec.string ","+    x <- Parsec.many1 Parsec.digit+    Parsec.string ")"+    return $ HideNode $ Coords (read y) (read x)
+ ttrender/Debug/Trace/Tree/Render/Simple.hs view
@@ -0,0 +1,100 @@+-- | Render simple trees+module Debug.Trace.Tree.Render.Simple (renderTree) where++import Diagrams.Prelude+import Diagrams.Backend.Cairo (B)+import Graphics.SVGFonts+import Graphics.SVGFonts.ReadFont (PreparedFont)+import Text.Regex.Posix ((=~))++import Debug.Trace.Tree.Simple+import Debug.Trace.Tree.Render.Options+import Debug.Trace.Tree.Render.Constants+import qualified Debug.Trace.Tree.Render.Edged as Edged++renderTree :: RenderOptions -> SimpleTree -> Diagram B+renderTree options@RenderOptions{..} =+      Edged.renderTree drawEdgeLabel (drawNode options) renderShowCoords+    . applyOptions options++drawNode :: RenderOptions -> Maybe String -> Diagram B+drawNode RenderOptions{..} node =+      maybeVertical node+    $ makeBox node+  where+    makeBox (Just str) = box str (lookup str renderColours)+    makeBox Nothing    = mempty++    maybeVertical Nothing    = id+    maybeVertical (Just str) = if any (\regexp -> str =~ regexp) renderVertical+                                 then rotateBy (1/4)+                                 else id++drawEdgeLabel :: Maybe String -> Maybe String -> String -> (Diagram B, ArrowOpts Double)+drawEdgeLabel _ Nothing str = (+    stroke (textSVG' (textOpts constEdgeLabelHeight bit) str) # fc black # lw none+  , arrOpts & shaftStyle %~ dashingG [constMissingNodeDash, constMissingNodeDash] 0+            & headTexture .~ solid grey+  )+drawEdgeLabel _ (Just _) str = (+    stroke (textSVG' (textOpts constEdgeLabelHeight bit) str) # fc black # lw none+  , arrOpts+  )++-- NOTE: global sizes are relative to the final vector space of the diagram,+-- and are not affected by scaling. We don't want to use normalized because+-- normalized values depend on the size of the final diagram, and the size of+-- the diagram may very greatly depending on the size of the tree.+-- See Section 2.5, "Measurement units" of the diagrams manual.+arrOpts :: ArrowOpts Double+arrOpts = with & headLength .~ global constArrowHeadLength+               & shaftStyle %~ lw (global constArrowLineWidth) . lc grey++textOpts :: Double -> PreparedFont Double -> TextOpts Double+textOpts h fnt = with {+    textFont   = fnt+  , textHeight = h+  }++box :: String -> Maybe (Colour Double) -> Diagram B+box str mc = mconcat [+      stroke txt # fc black # lw none+    , boundingBoxRect bb # setBg mc # lc black # lw (global 1)+    ]+  where+    txt :: Path V2 Double+    txt = textSVG' (textOpts constNodeLabelHeight lin) str++    bb :: BoundingBox V2 Double+    bb = boundingBoxGrow constNodePadding (boundingBox txt) <> boundingBox minBB++    minBB :: Diagram B+    minBB = square constNodeLabelHeight++    setBg (Just c) = fc c+    setBg Nothing  = id++{-------------------------------------------------------------------------------+  Auxiliary: operations on bounding boxes+-------------------------------------------------------------------------------}++boundingBoxGrow :: Double -> BoundingBox V2 Double -> (BoundingBox V2 Double)+boundingBoxGrow padding bb =+    fromCorners (p2 (x  - padding, y  - padding))+                (p2 (x' + padding, y' + padding))+  where+    (unp2 -> (x, y), unp2 -> (x', y')) = getCorners' bb++boundingBoxRect :: BoundingBox V2 Double -> Diagram B+boundingBoxRect = uncurry rect . boundingBoxSize++boundingBoxSize :: Num a => BoundingBox V2 a -> (a, a)+boundingBoxSize bb = ((x' - x), (y' - y))+  where+    (unp2 -> (x, y), unp2 -> (x', y')) = getCorners' bb++getCorners' :: Num a => BoundingBox V2 a -> (Point V2 a, Point V2 a)+getCorners' bb =+    case getCorners bb of+      Just (ll, ur) -> (ll     , ur    )+      Nothing       -> (origin , origin)
+ ttrender/Main.hs view
@@ -0,0 +1,24 @@+-- | Render simple trees+module Main (main) where++import Diagrams.Prelude+import Diagrams.Backend.Cairo (B)+import Diagrams.Backend.Cairo.CmdLine (mainWith)+import Text.JSON++import Debug.Trace.Tree.Render.Simple+import Debug.Trace.Tree.Render.Options++{-------------------------------------------------------------------------------+  Main application driver+-------------------------------------------------------------------------------}++generateDiagram :: RenderOptions -> IO (Diagram B)+generateDiagram options@RenderOptions{..} = do+  json <- readFile renderInput+  case decode json of+    Ok parsed -> return $ renderTree options parsed+    Error err -> fail err++main :: IO ()+main = mainWith generateDiagram