diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Debug/Trace/Tree.hs b/src/Debug/Trace/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree.hs @@ -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 diff --git a/src/Debug/Trace/Tree/Assoc.hs b/src/Debug/Trace/Tree/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree/Assoc.hs @@ -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) diff --git a/src/Debug/Trace/Tree/Edged.hs b/src/Debug/Trace/Tree/Edged.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree/Edged.hs @@ -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 [])) + ]) + ) + ]) diff --git a/src/Debug/Trace/Tree/Generic.hs b/src/Debug/Trace/Tree/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree/Generic.hs @@ -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 diff --git a/src/Debug/Trace/Tree/Rose.hs b/src/Debug/Trace/Tree/Rose.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree/Rose.hs @@ -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" [] + ] + ] diff --git a/src/Debug/Trace/Tree/Simple.hs b/src/Debug/Trace/Tree/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Tree/Simple.hs @@ -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) diff --git a/tracetree.cabal b/tracetree.cabal new file mode 100644 --- /dev/null +++ b/tracetree.cabal @@ -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 diff --git a/ttrender/Debug/Trace/Tree/Render/Constants.hs b/ttrender/Debug/Trace/Tree/Render/Constants.hs new file mode 100644 --- /dev/null +++ b/ttrender/Debug/Trace/Tree/Render/Constants.hs @@ -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 diff --git a/ttrender/Debug/Trace/Tree/Render/Edged.hs b/ttrender/Debug/Trace/Tree/Render/Edged.hs new file mode 100644 --- /dev/null +++ b/ttrender/Debug/Trace/Tree/Render/Edged.hs @@ -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') diff --git a/ttrender/Debug/Trace/Tree/Render/Options.hs b/ttrender/Debug/Trace/Tree/Render/Options.hs new file mode 100644 --- /dev/null +++ b/ttrender/Debug/Trace/Tree/Render/Options.hs @@ -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) diff --git a/ttrender/Debug/Trace/Tree/Render/Simple.hs b/ttrender/Debug/Trace/Tree/Render/Simple.hs new file mode 100644 --- /dev/null +++ b/ttrender/Debug/Trace/Tree/Render/Simple.hs @@ -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) diff --git a/ttrender/Main.hs b/ttrender/Main.hs new file mode 100644 --- /dev/null +++ b/ttrender/Main.hs @@ -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