diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Thomas Eding + +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 Thomas Eding 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/Data/Tree/Render/Text.hs b/src/Data/Tree/Render/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Render/Text.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} + +-- | Configurable text rendering of trees. +module Data.Tree.Render.Text ( + ParentLocation(..), + ChildOrder(..), + BranchPath(..), + + renderTreeM, + RenderOptionsM(..), + tracedRenderOptionsM, + tracedRenderOptionsAsciiM, + + renderTree, + RenderOptions, + tracedRenderOptions, + tracedRenderOptionsAscii, +) where + +import qualified Control.Monad.State.Strict as M +import qualified Control.Monad.Writer as M +import qualified Data.List as List +import Data.Monoid ( Endo(Endo, appEndo) ) +import qualified Data.Tree as Tree +import Data.Tree ( Tree ) + +-- | A difference list on typ 'a'. +type DList a = Endo [a] + +-- | Appends a list '[a]' to the output of a 'M.Writer (DList a)'. +tellDList :: [a] -> M.Writer (DList a) () +tellDList s = M.tell $ Endo (s <>) + +-- | Describes where a parent node is rendered, relative to its children. +data ParentLocation + = ParentBeforeChildren + | ParentAfterChildren + | ParentBetweenChildren + deriving (Show, Eq, Ord) + +-- | Describes the render order of a node's children. +data ChildOrder + = FirstToLast + | LastToFirst + deriving (Show, Eq, Ord) + +-- | A part of a path along a rendered tree. +data BranchPath + = BranchUp + -- ^ Describes a turn going up toward the left. + -- + -- e.g. @╭─@ + | BranchDown + -- ^ Describes a turn going down toward the left. + -- + -- e.g. @╰─@ + | BranchJoin + -- ^ Describes a T-join of a path going up and down toward the left. + -- + -- e.g. @├─@ + | BranchContinue + -- ^ Describes a path going up and down. + -- + -- e.g. @│ @ + | BranchEmpty + -- ^ Describes a part that does NOT contain a path piece. + -- + -- e.g. @ @ + deriving (Show, Eq, Ord) + +-- | Options used for rendering a 'Tree label'. +data RenderOptionsM m string label = RenderOptions + { oParentLocation :: ParentLocation + -- ^ Controls where parent nodes are rendered. + , oChildOrder :: ChildOrder + -- ^ Controls the order a node's children are rendered. + , oVerticalPad :: Int + -- ^ The amount of vertical spacing between nodes. + , oPrependNewLine :: Bool + -- ^ If 'True', a newline is prepended to the rendered output. + , oFromString :: String -> string + -- ^ Promotes a 'String' to a 'string'. + , oWrite :: string -> m () + -- ^ Writes a 'string'. + , oShowNodeLabel :: label -> string + -- ^ Shows a 'Tree.rootLabel'. + , oGetNodeMarker :: label -> string + -- ^ Get the marker for a node. Although this takes as input a node's 'label', + -- this should not render the label itself. + -- + -- The label is passed as an argument to allow things such as: + -- * Rendering a node marker differently for labels that fail to pass a test. + -- * Highlighting a node currently being visited. + -- + -- Simple use cases would use a constant function ignoring the label value. + , oShowBranchPath :: BranchPath -> string + -- ^ Shows a 'BranchPath'. The returned values should contain no newlines and + -- should all be of the same printed width when rendered as text. + } + +-- | An alias of 'RenderOptionsM' for producing pure 'String' renders. +type RenderOptions = RenderOptionsM (M.Writer (DList Char)) + +-- | Options for producing a line-traced tree using unicode drawing characters. +-- +-- This uses: +-- BranchUp -> "╭─" +-- BranchDown -> "╰─" +-- BranchJoin -> "├─" +-- BranchContinue -> "│ " +-- BranchEmpty -> " " +-- +tracedRenderOptionsM + :: (String -> string) + -- ^ Promotes a 'String' to a 'string'. + -> (string -> m ()) + -- ^ Writes a 'string'. + -> (label -> string) + -- ^ Shows a 'Tree.rootLabel'. + -> RenderOptionsM m string label +tracedRenderOptionsM fromString' write' show' = RenderOptions + { oParentLocation = ParentBeforeChildren + , oChildOrder = FirstToLast + , oVerticalPad = 0 + , oPrependNewLine = False + , oFromString = fromString' + , oWrite = write' + , oShowNodeLabel = show' + , oGetNodeMarker = const $ fromString' "● " + , oShowBranchPath = fromString' . \case + BranchUp -> "╭─" + BranchDown -> "╰─" + BranchJoin -> "├─" + BranchContinue -> "│ " + BranchEmpty -> " " + } + +-- | Options for producing a line-traced tree using ASCII characters. +-- +-- This uses: +-- BranchUp -> ",-" +-- BranchDown -> "`-" +-- BranchJoin -> "|-" +-- BranchContinue -> "| " +-- BranchEmpty -> " " +-- +tracedRenderOptionsAsciiM + :: (String -> string) + -- ^ Promotes a 'String' to a 'string'. + -> (string -> m ()) + -- ^ Writes a 'string'. + -> (label -> string) + -- ^ Shows a 'Tree.rootLabel'. + -> RenderOptionsM m string label +tracedRenderOptionsAsciiM fromString' write' show' = + (tracedRenderOptionsM fromString' write' show') + { oGetNodeMarker = const $ fromString' "o " + , oShowBranchPath = fromString' . \case + BranchUp -> ",-" + BranchDown -> "`-" + BranchJoin -> "|-" + BranchContinue -> "| " + BranchEmpty -> " " + } + +-- | Simplified 'tracedRenderOptionsM' when using 'RenderOptions'. +tracedRenderOptions + :: (label -> String) + -- ^ Shows a 'Tree.rootLabel'. + -> RenderOptions String label +tracedRenderOptions = tracedRenderOptionsM id tellDList + +-- | Simplified 'tracedRenderOptionsAsciiM' when using 'RenderOptions'. +tracedRenderOptionsAscii + :: (label -> String) + -- ^ Shows a 'Tree.rootLabel'. + -> RenderOptions String label +tracedRenderOptionsAscii = tracedRenderOptionsAsciiM id tellDList + +-- | Renders a 'Tree' a pretty printed tree asa a 'String'. +renderTree :: RenderOptions String label -> Tree label -> String +renderTree options = run . renderTreeM options + where + run = ($ "") . appEndo . M.execWriter + +-- | Renders a pretty printed tree within a monadic context. +renderTreeM :: Monad m => RenderOptionsM m string label -> Tree label -> m () +renderTreeM options tree = M.evalStateT action options + where + action = render [] tree + +type Render string label m = M.StateT (RenderOptionsM m string label) m + +write :: Monad m => string -> Render string label m () +write s = do + w <- M.gets oWrite + M.lift $ w s + +render :: Monad m => [BranchPath] -> Tree label -> Render string label m () +render trail = \case + Tree.Node + { Tree.rootLabel = label + , Tree.subForest = kids' + } -> do + + let renderCurr = do + getMarker <- M.gets oGetNodeMarker + showLabel <- M.gets oShowNodeLabel + M.gets oPrependNewLine >>= \case + True -> renderNewLine + False -> M.modify' $ \st -> st + { oPrependNewLine = True + } + renderTrail trail + write $ getMarker label + write $ showLabel label + + childOrder <- M.gets oChildOrder + let kids = case childOrder of + FirstToLast -> kids' + LastToFirst -> reverse kids' + + M.gets oParentLocation >>= \case + + ParentBeforeChildren -> do + let renderNext path = render $ path : trail + case initLast kids of + Nothing -> do + renderCurr + Just (ks, k) -> do + renderCurr + M.forM_ ks $ \k' -> do + renderVerticalSpace trail + renderNext BranchJoin k' + renderVerticalSpace trail + renderNext BranchDown k + + ParentAfterChildren -> do + let renderNext path = render $ path : trail + case kids of + [] -> do + renderCurr + k : ks -> do + renderNext BranchUp k + M.forM_ ks $ \k' -> do + renderVerticalSpace trail + renderNext BranchJoin k' + renderVerticalSpace trail + renderCurr + + ParentBetweenChildren -> do + let trailL = case trail of + BranchDown : rest -> BranchContinue : rest + _ -> trail + trailR = case trail of + BranchUp : rest -> BranchContinue : rest + _ -> trail + renderNextL path = render $ path : trailL + renderNextR path = render $ path : trailR + case headMiddleLast kids of + Nothing -> do + renderCurr + Just (k, Nothing) -> do + case childOrder of + FirstToLast -> do + renderCurr + renderVerticalSpace trailR + renderNextR BranchDown k + LastToFirst -> do + renderNextL BranchUp k + renderVerticalSpace trailL + renderCurr + Just (k0, Just (ks, kn)) -> do + let index = case childOrder of + FirstToLast -> length ks `div` 2 + LastToFirst -> case length ks `divMod` 2 of + (d, 0) -> d + (d, _) -> d + 1 + let (ksL, ksR) = List.splitAt index ks + renderNextL BranchUp k0 + M.forM_ ksL $ \k -> do + renderVerticalSpace trailL + renderNextL BranchJoin k + renderVerticalSpace trailL + renderCurr + M.forM_ ksR $ \k -> do + renderVerticalSpace trailR + renderNextR BranchJoin k + renderVerticalSpace trailR + renderNextR BranchDown kn + +renderNewLine :: Monad m => Render string label m () +renderNewLine = do + from <- M.gets oFromString + write $ from "\n" + +renderVerticalSpace :: Monad m => [BranchPath] -> Render string label m () +renderVerticalSpace trail = do + n <- M.gets oVerticalPad + M.replicateM_ n $ do + renderNewLine + renderTrail $ BranchContinue : trail + +renderTrail :: Monad m => [BranchPath] -> Render string label m () +renderTrail trail = do + showPath <- M.gets oShowBranchPath + let renderPath = write . showPath + case trail of + [] -> pure () + p : ps -> do + M.forM_ (reverse ps) $ renderPath . \case + BranchDown -> BranchEmpty + BranchUp -> BranchEmpty + BranchEmpty -> BranchEmpty + _ -> BranchContinue + write $ showPath p + +initLast :: [a] -> Maybe ([a], a) +initLast = \case + [] -> Nothing + xs -> Just (init xs, last xs) + +headMiddleLast :: [a] -> Maybe (a, Maybe ([a], a)) +headMiddleLast = \case + [] -> Nothing + x : xs -> case xs of + [] -> Just (x, Nothing) + _ -> Just (x, Just (init xs, last xs)) + diff --git a/src/Data/Tree/Render/TextTest.hs b/src/Data/Tree/Render/TextTest.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Render/TextTest.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} + +module Data.Tree.Render.TextTest ( + test1, +) where + +import qualified Data.Tree as Tree +import Data.Tree ( Tree ) +import qualified Data.Tree.Render.Text as R +import qualified Text.PrettyPrint.Boxes as Box +import Text.PrettyPrint.Boxes ( Box ) + +naturalBox :: String -> Box +naturalBox = Box.vcat Box.left . map Box.text . lines + +vsep :: [Box] -> Box +vsep = Box.vsep 2 Box.left + +hsep :: [Box] -> Box +hsep = Box.hsep 3 Box.left + +renderFlavors :: R.RenderOptions String String -> Box +renderFlavors options = + let go ord loc = + let str = flip R.renderTree testTree1 options + { R.oChildOrder = ord + , R.oParentLocation = loc + } + in naturalBox str + in hsep + [ go R.FirstToLast R.ParentBeforeChildren + , go R.FirstToLast R.ParentAfterChildren + , go R.FirstToLast R.ParentBetweenChildren + , go R.LastToFirst R.ParentBeforeChildren + , go R.LastToFirst R.ParentAfterChildren + , go R.LastToFirst R.ParentBetweenChildren + ] + +test1 :: IO () +test1 = do + let options = R.tracedRenderOptions id + putStrLn "" + let b0 = renderFlavors options + let b1 = renderFlavors options { R.oVerticalPad = 1 } + Box.printBox $ vsep [b0, b1] + putStrLn "" + +testTree1 :: Tree String +testTree1 + = node "Add" + [ node "Add" + [ node "0" [] + , node "Mul" + [ node "1" [] + , node "2" [] + ] + ] + , node "Neg" + [ node "Max" + [ node "3" [] + , node "4" [] + , node "5" [] + , node "Var" + [ node "x" [] + ] + , node "6" [] + ] + ] + ] + + where + node :: String -> [Tree String] -> Tree String + node = Tree.Node + diff --git a/tree-render-text.cabal b/tree-render-text.cabal new file mode 100644 --- /dev/null +++ b/tree-render-text.cabal @@ -0,0 +1,26 @@ +cabal-version: 2.4 +-- Initial package description 'tree-render-text.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: tree-render-text +version: 0.1.0.0 +synopsis: Configurable text rendering of trees. +description: Configurable text rendering of trees. +homepage: https://github.com/thomaseding/tree-render-text +-- bug-reports: +license: BSD-3-Clause +license-file: LICENSE +author: Thomas Eding +maintainer: Thomas Eding +-- copyright: +category: Data +--extra-source-files: CHANGELOG.md + +library + exposed-modules: Data.Tree.Render.Text + other-modules: Data.Tree.Render.TextTest + other-extensions: FlexibleContexts, LambdaCase, Safe + build-depends: base ^>=4.12.0.0, mtl ^>=2.2.2, containers ^>=0.6.0.1, boxes ^>=0.1.5 + hs-source-dirs: src + default-language: Haskell2010