diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +0.1.0.1 +------- +* Improved language for hiding nodes +* Lifted upper bounds + +0.1.0.0 +------- +* Initial release diff --git a/src/Debug/Trace/Tree/Edged.hs b/src/Debug/Trace/Tree/Edged.hs --- a/src/Debug/Trace/Tree/Edged.hs +++ b/src/Debug/Trace/Tree/Edged.hs @@ -11,6 +11,8 @@ , keys , mapEdges -- * Hiding nodes + , MatchAgainst(..) + , NodeSpec(..) , Hide(..) , hideNodes -- * Annotation @@ -18,6 +20,7 @@ , Offset , Coords(..) , Metadata(..) + , Rose.isFirstChild , annotate -- * Interaction between ETree and Tree , pushEdges @@ -89,28 +92,62 @@ Hiding nodes -------------------------------------------------------------------------------} +-- | Abstract definition of something we can match against a value +class MatchAgainst v m where + matchAgainst :: v -> m -> Bool + +-- | Various ways we can specify a node +data NodeSpec v = + -- | Node at the specified coordinates + NodeCoords Coords + + -- | Match the value of the node + | forall m. (MatchAgainst v m, Show m) => NodeMatch m + +matchSpec :: NodeSpec v -> (v, Metadata) -> Bool +matchSpec (NodeCoords c) (_, Metadata{..}) = c == coords +matchSpec (NodeMatch m) (v, _) = v `matchAgainst` m + -- | Specification of nodes to hide -data Hide = - -- | Hide the node at the specified coordinates - HideNode Coords +data Hide v = + -- | Hide the specified node + HideNode (NodeSpec v) -instance Show Hide where - show (HideNode Coords{..}) = "node(" ++ show depth ++ "," ++ show offset ++ ")" + -- | Limit the range of children of the specified node + | HideMax (Int, Int) (NodeSpec v) +instance Show (NodeSpec v) where + show (NodeCoords Coords{..}) = show depth ++ "," ++ show offset + show (NodeMatch m) = show m + +instance Show (Hide v) where + show (HideNode spec) = "node(" ++ show spec ++ ")" + show (HideMax n spec) = "max(" ++ show n ++ "," ++ show spec ++ ")" + -- | Check if a certain node should be hidden -isHidden :: [Hide] -> Metadata -> Bool -isHidden spec Metadata{..} = any hides spec +isHidden :: forall v. + [Hide v] -- ^ User-specified rules for hiding nodes + -> Maybe (v, Metadata) -- ^ Parent node + -> (v, Metadata) -- ^ This node + -> Bool +isHidden rules mParent this@(_, Metadata{..}) = + any (hides mParent) rules where - hides :: Hide -> Bool - hides (HideNode coords') = coords == coords' + hides :: Maybe (v, Metadata) -> Hide v -> Bool + hides _ (HideNode spec) = matchSpec spec this + hides (Just parent) (HideMax r spec) = matchSpec spec parent && not (inRange r nthChild) + hides Nothing (HideMax _ _) = False -hideNodes :: forall k v. [Hide] -> ETree k (v, Metadata) -> ETree k (Maybe v, Metadata) -hideNodes spec = go + inRange :: (Int, Int) -> Int -> Bool + inRange (lo, hi) n = lo <= n && n <= hi + +hideNodes :: forall k v. [Hide v] -> ETree k (v, Metadata) -> ETree k (Maybe v, Metadata) +hideNodes spec = go Nothing 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) + go :: Maybe (v, Metadata) -> ETree k (v, Metadata) -> ETree k (Maybe v, Metadata) + go mParent (Node (v, meta) (Assoc ts)) + | isHidden spec mParent (v, meta) = Node (Nothing, meta) $ Assoc [] + | otherwise = Node (Just v, meta) $ Assoc (map (second (go (Just (v, meta)))) ts) {------------------------------------------------------------------------------- Interaction between ETree and Tree diff --git a/src/Debug/Trace/Tree/Rose.hs b/src/Debug/Trace/Tree/Rose.hs --- a/src/Debug/Trace/Tree/Rose.hs +++ b/src/Debug/Trace/Tree/Rose.hs @@ -5,6 +5,7 @@ , Offset , Coords(..) , Metadata(..) + , isFirstChild , annotate ) where @@ -68,12 +69,15 @@ -- | Metadata of a node in the tree data Metadata = Metadata { - isSpine :: Bool - , isFirstChild :: Bool - , coords :: Coords + isSpine :: Bool + , nthChild :: Int + , coords :: Coords } deriving (Show, Eq, Ord) +isFirstChild :: Metadata -> Bool +isFirstChild Metadata{..} = nthChild == 0 + {------------------------------------------------------------------------------- Auxiliary: operations on trees -------------------------------------------------------------------------------} @@ -87,12 +91,11 @@ $ map (uncurry go) $ zip (isSpine : repeat False) ts -- | Mark the first child of each node -markFirstChild :: Tree a -> Tree (a, Bool) -markFirstChild = go True +markNthChild :: Tree a -> Tree (a, Int) +markNthChild = go 0 where - go :: Bool -> Tree a -> Tree (a, Bool) - go isFirst (Node a ts) = Node (a, isFirst) - $ map (uncurry go) $ zip (True : repeat False) ts + go :: Int -> Tree a -> Tree (a, Int) + go nth (Node a ts) = Node (a, nth) $ zipWith go [0..] ts -- | Mark each node with its depth in the tree markDepth :: Tree a -> Tree (a, Depth) @@ -117,11 +120,11 @@ annotate :: Tree a -> Tree (a, Metadata) annotate = fmap aux . markCoords - . markFirstChild + . markNthChild . markSpine where - aux :: (((a, Bool), Bool), Coords) -> (a, Metadata) - aux (((a, isSpine), isFirstChild), coords) = (a, Metadata{..}) + aux :: (((a, Bool), Int), Coords) -> (a, Metadata) + aux (((a, isSpine), nthChild), coords) = (a, Metadata{..}) {------------------------------------------------------------------------------- Debugging diff --git a/tracetree.cabal b/tracetree.cabal --- a/tracetree.cabal +++ b/tracetree.cabal @@ -1,5 +1,5 @@ name: tracetree -version: 0.1.0.0 +version: 0.1.0.1 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 @@ -18,7 +18,7 @@ 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). + or post-process previously exported .JSON files). license: BSD3 license-file: LICENSE author: Edsko de Vries @@ -29,6 +29,9 @@ -- extra-source-files: cabal-version: >=1.10 +extra-source-files: + ChangeLog.md + source-repository head type: git location: https://github.com/edsko/tracetree @@ -47,7 +50,7 @@ -- 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, + bifunctors >= 4.2 && < 5.3, containers >= 0.5 && < 0.6, json >= 0.9 && < 0.10, mtl >= 2.2 && < 2.3, @@ -56,8 +59,10 @@ default-language: Haskell2010 ghc-options: -Wall default-extensions: DefaultSignatures + ExistentialQuantification FlexibleContexts FlexibleInstances + MultiParamTypeClasses NoMonomorphismRestriction ParallelListComp PatternSynonyms @@ -80,7 +85,7 @@ build-depends: base >= 4.8 && < 5, colour >= 2.3 && < 2.4, json >= 0.9 && < 0.10, - optparse-applicative >= 0.11 && < 0.12, + optparse-applicative >= 0.11 && < 0.13, regex-posix >= 0.95 && < 0.96, parsec >= 3.1 && < 3.2, diagrams-cairo >= 1.3 && < 1.4, @@ -96,6 +101,8 @@ default-language: Haskell2010 default-extensions: BangPatterns FlexibleContexts + FlexibleInstances + MultiParamTypeClasses NoMonomorphismRestriction PatternSynonyms RecordWildCards diff --git a/ttrender/Debug/Trace/Tree/Render/Edged.hs b/ttrender/Debug/Trace/Tree/Render/Edged.hs --- a/ttrender/Debug/Trace/Tree/Render/Edged.hs +++ b/ttrender/Debug/Trace/Tree/Render/Edged.hs @@ -36,7 +36,7 @@ drV :: (v, Metadata) -> (Diagram B, Metadata) drV (v, meta) = - let rendered | showCoords = drV' v <> renderCoords (coords meta) + let rendered | showCoords = renderCoords (coords meta) <> drV' v | otherwise = drV' v in (rendered, meta) diff --git a/ttrender/Debug/Trace/Tree/Render/Options.hs b/ttrender/Debug/Trace/Tree/Render/Options.hs --- a/ttrender/Debug/Trace/Tree/Render/Options.hs +++ b/ttrender/Debug/Trace/Tree/Render/Options.hs @@ -1,6 +1,6 @@ -- | Render simple trees {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module Debug.Trace.Tree.Render.Options (RenderOptions(..), applyOptions) where +module Debug.Trace.Tree.Render.Options where -- (RenderOptions(..), applyOptions) where import Data.Bifunctor import Data.Colour (Colour) @@ -10,19 +10,35 @@ import Data.Function (on) import Diagrams.Backend.CmdLine (Parseable(..)) import Options.Applicative +import Text.Regex.Posix ((=~)) 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.Edged import Debug.Trace.Tree.Assoc (Assoc(..)) -import qualified Debug.Trace.Tree.Edged as Edged import qualified Debug.Trace.Tree.Simple as Simple +{------------------------------------------------------------------------------- + Matching nodes +-------------------------------------------------------------------------------} + +data RegExp = RegExp String + +instance Show RegExp where + show (RegExp regExp) = regExp + +instance MatchAgainst String RegExp where + s `matchAgainst` (RegExp regExp) = s =~ regExp + +{------------------------------------------------------------------------------- + Command line args proper +-------------------------------------------------------------------------------} + data RenderOptions = RenderOptions { - renderHideNodes :: [Hide] + renderHideNodes :: [Hide String] , renderMerge :: [String] - , renderVertical :: [String] + , renderVertical :: [RegExp] , renderColours :: [(String, Colour Double)] , renderMaxNotShown :: Int , renderDelChildren :: [String] @@ -32,17 +48,30 @@ instance Parseable RenderOptions where parser = RenderOptions - <$> ( many (option readHide $ mconcat [ + <$> ( many (option (readParsec parseHide) $ 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." + , help $ unlines [ + "Hide certain nodes in the tree; arrows to these nodes are shown as dangling (modulo the max-not-shown option)." + , "Can be used multiple times." + , "" + , "Valid syntax for the argument is: " + , " \"node(SPEC)\": Hide all nodes matching SPEC." + , " \"max(RANGE,SPEC)\": Only show the children in RANGE of nodes matching SPEC." + , "" + , "Where SPEC is: " + , " \"y,x\": Node at specific coordinates" + , " REGEXP: Any node matching REGEXP" + , "" + , "RANGE is n-m, n-, or -m" + ] ])) <*> ( 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 [ + <*> ( many (option (readParsec parseRegExp) $ mconcat [ long "vertical" , metavar "REGEXP" , help "Show any node matching the specified regular expression vertically. Can be used multiple times." @@ -68,12 +97,12 @@ ]) <*> ( argument str (metavar "JSON") ) -readHide :: ReadM Hide -readHide = do +readParsec :: Parsec.Parser a -> ReadM a +readParsec p = do arg <- str - case Parsec.parse parseHide "HIDE" arg of - Left err -> fail (show err) - Right hide -> return hide + case Parsec.parse p "command line argument" arg of + Left err -> fail (show err) + Right a -> return a readColourAssignment :: ReadM (String, Colour Double) readColourAssignment = do @@ -85,8 +114,8 @@ applyOptions :: RenderOptions -> SimpleTree -> ETree String (Maybe String, Metadata) applyOptions RenderOptions{..} = applyMaxNotShown renderMaxNotShown - . Edged.hideNodes renderHideNodes - . Edged.annotate + . hideNodes renderHideNodes + . annotate . simpleETree . applyMerge renderMerge . applyDelChildren renderDelChildren @@ -110,9 +139,9 @@ go _ = error "inaccessible" applyMaxNotShown :: Int -> ETree String (Maybe String, Metadata) -> ETree String (Maybe String, Metadata) -applyMaxNotShown n = \(Edged.Node c (Assoc ts)) -> +applyMaxNotShown n = \(Node c (Assoc ts)) -> let culled = concatMap aux (groupBy ((==) `on` isShown) ts) - in Edged.Node c $ fmap (applyMaxNotShown n) (Assoc culled) + in 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 @@ -124,26 +153,62 @@ | otherwise = ts ellipsis :: Metadata -> (String, ETree String (Maybe String, Metadata)) - ellipsis meta = ("...", Edged.Node (Nothing, meta) (Assoc [])) + ellipsis meta = ("...", Node (Nothing, meta) (Assoc [])) isShown :: (String, ETree String (Maybe String, meta)) -> Bool - isShown (_key, (Edged.Node (c', _coords) _subtree)) = isJust c' + isShown (_key, (Node (c', _coords) _subtree)) = isJust c' rootMeta :: ETree k (v, Metadata) -> Metadata - rootMeta (Edged.Node (_, meta) _) = meta + rootMeta (Node (_, meta) _) = meta {------------------------------------------------------------------------------- Parser for Hide -------------------------------------------------------------------------------} -parseHide :: Parsec.Parser Hide -parseHide = parseHideNode +parseHide :: Parsec.Parser (Hide String) +parseHide = + (do Parsec.try $ Parsec.string "node(" + s <- parseNodeSpec + Parsec.string ")" + return $ HideNode s) + <|> (do Parsec.try $ Parsec.string "max(" + lo <- parseInt + Parsec.string "-" + hi <- parseInt + Parsec.string "," + s <- parseNodeSpec + Parsec.string ")" + return $ HideMax (lo, hi) s) -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) +parseNodeSpec :: Parsec.Parser (NodeSpec String) +parseNodeSpec = + Parsec.try (do y <- parseInt + Parsec.string "," + x <- parseInt + return $ NodeCoords $ Coords y x) + <|> + (NodeMatch <$> parseRegExp) + +parseInt :: Parsec.Parser Int +parseInt = read <$> Parsec.many1 Parsec.digit + +-- | Regular expression delimited by an unmatched closing parenthesis +parseRegExp :: Parsec.Parser RegExp +parseRegExp = RegExp <$> matchBrackets + +{------------------------------------------------------------------------------- + Auxiliary parsec +-------------------------------------------------------------------------------} + +-- | Match as much as possible, until we see an unexpected closing parenthesis +matchBrackets :: Parsec.Parser String +matchBrackets = go 0 + where + go :: Int -> Parsec.Parser String + go nestingDepth = (do + x <- if nestingDepth > 0 then Parsec.anyChar else Parsec.noneOf ")" + let nestingDepth' | x == '(' = nestingDepth + 1 + | x == ')' = nestingDepth - 1 + | otherwise = nestingDepth + xs <- go nestingDepth' + return (x:xs)) <|> return "" diff --git a/ttrender/Debug/Trace/Tree/Render/Simple.hs b/ttrender/Debug/Trace/Tree/Render/Simple.hs --- a/ttrender/Debug/Trace/Tree/Render/Simple.hs +++ b/ttrender/Debug/Trace/Tree/Render/Simple.hs @@ -5,8 +5,8 @@ import Diagrams.Backend.Cairo (B) import Graphics.SVGFonts import Graphics.SVGFonts.ReadFont (PreparedFont) -import Text.Regex.Posix ((=~)) +import Debug.Trace.Tree.Edged (matchAgainst) import Debug.Trace.Tree.Simple import Debug.Trace.Tree.Render.Options import Debug.Trace.Tree.Render.Constants @@ -26,7 +26,7 @@ makeBox Nothing = mempty maybeVertical Nothing = id - maybeVertical (Just str) = if any (\regexp -> str =~ regexp) renderVertical + maybeVertical (Just str) = if any (matchAgainst str) renderVertical then rotateBy (1/4) else id