packages feed

tree-render-text (empty) → 0.1.0.0

raw patch · 5 files changed

+464/−0 lines, 5 filesdep +basedep +boxesdep +containerssetup-changed

Dependencies added: base, boxes, containers, mtl

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Tree/Render/Text.hs view
@@ -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))+
+ src/Data/Tree/Render/TextTest.hs view
@@ -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+
+ tree-render-text.cabal view
@@ -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