{-# LANGUAGE RecordWildCards #-}
-- | Tools for working with the 'TreeDiagram' monoid to draw tree diagrams.
module Data.Monoid.TreeDiagram
  ( TreeDiagram
  , showTreeDiagram
  , printTreeDiagram
  , singleton
  , subtree
  , width
  , height
  ) where

import Data.List (intersperse)
import Data.Semigroup (Semigroup(..))

-- | combine difference-strings into one
concatShowS :: [ShowS] -> ShowS
concatShowS :: [ShowS] -> ShowS
concatShowS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id

-- | repeat a character a given number of times
replicateChar :: Int -> Char -> ShowS
replicateChar :: Int -> Char -> ShowS
replicateChar Int
n = [ShowS] -> ShowS
concatShowS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar

-- | A monoid for generating tree diagrams
data TreeDiagram = Empty | NonEmpty
  { TreeDiagram -> GraphEnvironment -> ShowS
graph       :: GraphEnvironment -> ShowS -- ^ the top line of the diagram
  , TreeDiagram -> Int
graphWidth  :: Int -- ^ number of characters in the graph
  , TreeDiagram -> Int
graphIndent :: Int -- ^ left whitespace needed to align graph with rows underneath
  , TreeDiagram -> Int
graphDedent :: Int -- ^ right whitespace needed to pad graph to maximum row width
  , TreeDiagram -> [(Int, ShowS)]
rows        :: [(Int,ShowS)] -- ^ width and definition of each row under the graph line
  , TreeDiagram -> (Int, Int)
leftLimit   :: (Int,Int) -- ^ index of lines without any left whitespace
  , TreeDiagram -> (Int, Int)
rightLimit  :: (Int,Int) -- ^ index of lines of maximum row width
  }

-- | TreeDiagram settings when rendering the graph line
data GraphEnvironment = GraphEnvironment
  { GraphEnvironment -> Bool
isLeftmost  :: !Bool -- ^ whether this part of the graph is the leftmost part of the graph
  , GraphEnvironment -> Bool
isRightmost :: !Bool -- ^ whether this part of the graph is the rightmost part of the graph
  , GraphEnvironment -> Int
uptickIndex :: !Int -- ^ index  of the uptick, relative to this part of the graph
  }

-- | render a tree diagram as a function that prepends a multi-line string
showTreeDiagram :: TreeDiagram -> ShowS
showTreeDiagram :: TreeDiagram -> ShowS
showTreeDiagram TreeDiagram
Empty = forall a. a -> a
id
showTreeDiagram NonEmpty{Int
[(Int, ShowS)]
(Int, Int)
GraphEnvironment -> ShowS
rightLimit :: (Int, Int)
leftLimit :: (Int, Int)
rows :: [(Int, ShowS)]
graphDedent :: Int
graphIndent :: Int
graphWidth :: Int
graph :: GraphEnvironment -> ShowS
rightLimit :: TreeDiagram -> (Int, Int)
leftLimit :: TreeDiagram -> (Int, Int)
rows :: TreeDiagram -> [(Int, ShowS)]
graphDedent :: TreeDiagram -> Int
graphIndent :: TreeDiagram -> Int
graphWidth :: TreeDiagram -> Int
graph :: TreeDiagram -> GraphEnvironment -> ShowS
..} = 
  let graphLine :: ShowS
graphLine =
        Int -> Char -> ShowS
replicateChar Int
graphIndent Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        GraphEnvironment -> ShowS
graph GraphEnvironment
          { isLeftmost :: Bool
isLeftmost = Bool
True
          , isRightmost :: Bool
isRightmost = Bool
True
          , uptickIndex :: Int
uptickIndex = Int
graphWidth -- don't show the uptick
          }
      rowLines :: [ShowS]
rowLines = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, ShowS)]
rows
  in [ShowS] -> ShowS
concatShowS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'\n') forall a b. (a -> b) -> a -> b
$ ShowS
graphLine forall a. a -> [a] -> [a]
: [ShowS]
rowLines

-- | print a tree diagram
printTreeDiagram :: TreeDiagram -> IO ()
printTreeDiagram :: TreeDiagram -> IO ()
printTreeDiagram = String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeDiagram -> ShowS
showTreeDiagram

-- | draw a value as a simple, single-line tree diagram
--
-- >>> printTreeDiagram $ singleton 'a'
-- 'a'
singleton :: Show a => a -> TreeDiagram
singleton :: forall a. Show a => a -> TreeDiagram
singleton a
a = NonEmpty
  { graph :: GraphEnvironment -> ShowS
graph = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ShowS
shows a
a
  , graphWidth :: Int
graphWidth = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
a
  , graphIndent :: Int
graphIndent = Int
0
  , graphDedent :: Int
graphDedent = Int
0
  , rows :: [(Int, ShowS)]
rows = []
  , leftLimit :: (Int, Int)
leftLimit = (Int
0,Int
0)
  , rightLimit :: (Int, Int)
rightLimit = (Int
0,Int
0)
  }

-- |
-- '<>' composes two tree diagrams horizontally, connecting them via horizontal line
--
-- >>> printTreeDiagram $ singleton 'a' <> singleton 'b'
-- 'a'─'b'
instance Semigroup TreeDiagram where
  TreeDiagram
Empty <> :: TreeDiagram -> TreeDiagram -> TreeDiagram
<> TreeDiagram
d = TreeDiagram
d
  TreeDiagram
d <> TreeDiagram
Empty = TreeDiagram
d
  TreeDiagram
a <> TreeDiagram
b = NonEmpty
    { graph :: GraphEnvironment -> ShowS
graph = \GraphEnvironment
o -> 
        let uptickIndex' :: Int
uptickIndex' = GraphEnvironment -> Int
uptickIndex GraphEnvironment
o forall a. Num a => a -> a -> a
- TreeDiagram -> Int
graphWidth TreeDiagram
a
            midline :: ShowS
midline = if Int
0 forall a. Ord a => a -> a -> Bool
<= Int
uptickIndex' Bool -> Bool -> Bool
&& Int
uptickIndex' forall a. Ord a => a -> a -> Bool
< Int
graphPadding
                        then Int -> Char -> ShowS
replicateChar Int
uptickIndex' Char
'─' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                             Char -> ShowS
showChar Char
'┴' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                             Int -> Char -> ShowS
replicateChar (Int
graphPadding forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
uptickIndex') Char
'─'
                        else Int -> Char -> ShowS
replicateChar Int
graphPadding Char
'─'
        in
        TreeDiagram -> GraphEnvironment -> ShowS
graph TreeDiagram
a GraphEnvironment
o{ isRightmost :: Bool
isRightmost = Bool
False } forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
        ShowS
midline forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        TreeDiagram -> GraphEnvironment -> ShowS
graph TreeDiagram
b GraphEnvironment
o{ isLeftmost :: Bool
isLeftmost = Bool
False, uptickIndex :: Int
uptickIndex = Int
uptickIndex' forall a. Num a => a -> a -> a
- Int
graphPadding }
    , graphWidth :: Int
graphWidth = TreeDiagram -> Int
graphWidth TreeDiagram
a forall a. Num a => a -> a -> a
+ Int
graphPadding forall a. Num a => a -> a -> a
+ TreeDiagram -> Int
graphWidth TreeDiagram
b
    , graphIndent :: Int
graphIndent = TreeDiagram -> Int
graphIndent TreeDiagram
a
    , graphDedent :: Int
graphDedent = TreeDiagram -> Int
graphDedent TreeDiagram
b
    , rows :: [(Int, ShowS)]
rows = Int -> [(Int, ShowS)] -> [(Int, ShowS)] -> [(Int, ShowS)]
alongside (TreeDiagram -> Int
width TreeDiagram
a forall a. Num a => a -> a -> a
+ Int
padding) (TreeDiagram -> [(Int, ShowS)]
rows TreeDiagram
a) (TreeDiagram -> [(Int, ShowS)]
rows TreeDiagram
b)
    , leftLimit :: (Int, Int)
leftLimit = TreeDiagram -> (Int, Int)
leftLimit TreeDiagram
a
    , rightLimit :: (Int, Int)
rightLimit = TreeDiagram -> (Int, Int)
rightLimit TreeDiagram
b
    }
    where graphPadding :: Int
graphPadding = TreeDiagram -> Int
graphDedent TreeDiagram
a forall a. Num a => a -> a -> a
+ Int
padding forall a. Num a => a -> a -> a
+ TreeDiagram -> Int
graphIndent TreeDiagram
b
          padding :: Int
padding = forall a. Enum a => a -> Int
fromEnum (Int
blo forall a. Ord a => a -> a -> Bool
<= Int
ahi Bool -> Bool -> Bool
&& Int
alo forall a. Ord a => a -> a -> Bool
<= Int
bhi)
          (Int
alo,Int
ahi) = TreeDiagram -> (Int, Int)
rightLimit TreeDiagram
a
          (Int
blo,Int
bhi) = TreeDiagram -> (Int, Int)
leftLimit TreeDiagram
b
-- |
-- 'mempty' is the empty tree diagram
--
-- >>> printTreeDiagram mempty
-- <BLANKLINE>
-- >>> printTreeDiagram $ mempty <> singleton 'a' <> mempty
-- 'a'
instance Monoid TreeDiagram where
  mempty :: TreeDiagram
mempty = TreeDiagram
Empty
  mappend :: TreeDiagram -> TreeDiagram -> TreeDiagram
mappend = forall a. Semigroup a => a -> a -> a
(<>)


-- | Full width of a tree diagram
--
-- >>> let d = singleton 'a' <> subtree (subtree (singleton 'b') <> singleton 'c')
-- >>> printTreeDiagram d
-- 'a'───┐
--       │
--     ┌─'c'
--     │
--    'b'
-- >>> width d
-- 9
width :: TreeDiagram -> Int
width :: TreeDiagram -> Int
width TreeDiagram
Empty = Int
0
width TreeDiagram
d = TreeDiagram -> Int
graphIndent TreeDiagram
d forall a. Num a => a -> a -> a
+ TreeDiagram -> Int
graphWidth TreeDiagram
d forall a. Num a => a -> a -> a
+ TreeDiagram -> Int
graphDedent TreeDiagram
d

-- | Full height of a tree diagram
--
-- >>> let d = singleton 'a' <> subtree (subtree (singleton 'b') <> singleton 'c')
-- >>> printTreeDiagram d
-- 'a'───┐
--       │
--     ┌─'c'
--     │
--    'b'
-- >>> height d
-- 5
height :: TreeDiagram -> Int
height :: TreeDiagram -> Int
height TreeDiagram
Empty = Int
0
height TreeDiagram
d = Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (TreeDiagram -> [(Int, ShowS)]
rows TreeDiagram
d)

-- | open zip of two blocks of text, padding the left block to a set width
alongside :: Int -> [(Int,ShowS)] -> [(Int,ShowS)] -> [(Int,ShowS)]
alongside :: Int -> [(Int, ShowS)] -> [(Int, ShowS)] -> [(Int, ShowS)]
alongside Int
n ((Int
mx,ShowS
dx):[(Int, ShowS)]
xs) ((Int
my,ShowS
dy):[(Int, ShowS)]
ys) = (Int
n forall a. Num a => a -> a -> a
+ Int
my, ShowS
dx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> ShowS
replicateChar (Int
n forall a. Num a => a -> a -> a
- Int
mx) Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dy) forall a. a -> [a] -> [a]
: Int -> [(Int, ShowS)] -> [(Int, ShowS)] -> [(Int, ShowS)]
alongside Int
n [(Int, ShowS)]
xs [(Int, ShowS)]
ys
alongside Int
_ [(Int, ShowS)]
xs [] = [(Int, ShowS)]
xs
alongside Int
n [] [(Int, ShowS)]
ys = [(Int
n forall a. Num a => a -> a -> a
+ Int
my, Int -> Char -> ShowS
replicateChar Int
n Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dy) | (Int
my,ShowS
dy) <- [(Int, ShowS)]
ys]

-- | Pick a downtick character, based on the current environment.
downtick :: GraphEnvironment -> ShowS
downtick :: GraphEnvironment -> ShowS
downtick GraphEnvironment{Bool
Int
uptickIndex :: Int
isRightmost :: Bool
isLeftmost :: Bool
uptickIndex :: GraphEnvironment -> Int
isRightmost :: GraphEnvironment -> Bool
isLeftmost :: GraphEnvironment -> Bool
..} = case (Bool
isLeftmost, Bool
isRightmost, Int
uptickIndex forall a. Eq a => a -> a -> Bool
== Int
0) of
  (Bool
False, Bool
False, Bool
False) -> Char -> ShowS
showChar Char
'┬'
  (Bool
False, Bool
False, Bool
True)  -> Char -> ShowS
showChar Char
'┼'
  (Bool
False, Bool
True, Bool
False)  -> Char -> ShowS
showChar Char
'┐'
  (Bool
False, Bool
True, Bool
True)   -> Char -> ShowS
showChar Char
'┤'
  (Bool
True, Bool
False, Bool
False)  -> Char -> ShowS
showChar Char
'┌'
  (Bool
True, Bool
False, Bool
True)   -> Char -> ShowS
showChar Char
'├'
  (Bool
True, Bool
True, Bool
False)   -> Char -> ShowS
showChar Char
'╷'
  (Bool
True, Bool
True, Bool
True)    -> Char -> ShowS
showChar Char
'│'

-- | Move a tree diagram to the subtree level, dropping a line
-- down from the graph line to connect it to the new toplevel.
--
-- >>> printTreeDiagram $ subtree (singleton 'a') <> singleton 'b' <> subtree (singleton 'c')
--  ┌─'b'─┐
--  │     │
-- 'a'   'c'
-- >>> printTreeDiagram $ subtree mempty
-- ╷
-- │
-- ╵
subtree :: TreeDiagram -> TreeDiagram
subtree :: TreeDiagram -> TreeDiagram
subtree TreeDiagram
Empty = NonEmpty
  { graph :: GraphEnvironment -> ShowS
graph = GraphEnvironment -> ShowS
downtick
  , graphWidth :: Int
graphWidth = Int
1
  , graphIndent :: Int
graphIndent = Int
0
  , graphDedent :: Int
graphDedent = Int
0
  , rows :: [(Int, ShowS)]
rows = [(Int
1, Char -> ShowS
showChar Char
'│'),(Int
1, Char -> ShowS
showChar Char
'╵')]
  , leftLimit :: (Int, Int)
leftLimit = (Int
1,Int
2)
  , rightLimit :: (Int, Int)
rightLimit = (Int
1,Int
2)
  }
subtree NonEmpty{Int
[(Int, ShowS)]
(Int, Int)
GraphEnvironment -> ShowS
rightLimit :: (Int, Int)
leftLimit :: (Int, Int)
rows :: [(Int, ShowS)]
graphDedent :: Int
graphIndent :: Int
graphWidth :: Int
graph :: GraphEnvironment -> ShowS
rightLimit :: TreeDiagram -> (Int, Int)
leftLimit :: TreeDiagram -> (Int, Int)
rows :: TreeDiagram -> [(Int, ShowS)]
graphDedent :: TreeDiagram -> Int
graphIndent :: TreeDiagram -> Int
graphWidth :: TreeDiagram -> Int
graph :: TreeDiagram -> GraphEnvironment -> ShowS
..} = NonEmpty
  { graph :: GraphEnvironment -> ShowS
graph = GraphEnvironment -> ShowS
downtick
  , graphWidth :: Int
graphWidth = Int
1
  , graphIndent :: Int
graphIndent = Int
uptickIndent
  , graphDedent :: Int
graphDedent = Int
graphIndent forall a. Num a => a -> a -> a
+ Int
graphWidth forall a. Num a => a -> a -> a
+ Int
graphDedent forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
uptickIndent
  , rows :: [(Int, ShowS)]
rows  = (Int
uptickIndent forall a. Num a => a -> a -> a
+ Int
1, Int -> Char -> ShowS
replicateChar Int
uptickIndent Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'│') 
          forall a. a -> [a] -> [a]
: (Int
graphIndent forall a. Num a => a -> a -> a
+ Int
graphWidth, Int -> Char -> ShowS
replicateChar Int
graphIndent Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
graphLine)
          forall a. a -> [a] -> [a]
: [(Int, ShowS)]
rows
  , leftLimit :: (Int, Int)
leftLimit = (if Int
llo forall a. Ord a => a -> a -> Bool
> Int
1 then Int
llo forall a. Num a => a -> a -> a
+ Int
2 else if Int
graphWidth forall a. Ord a => a -> a -> Bool
> Int
1 then Int
2 else Int
1, Int
lhi forall a. Num a => a -> a -> a
+ Int
2)
  , rightLimit :: (Int, Int)
rightLimit = (if Int
rlo forall a. Ord a => a -> a -> Bool
> Int
1 then Int
rlo forall a. Num a => a -> a -> a
+ Int
2 else if Int
graphWidth forall a. Ord a => a -> a -> Bool
> Int
2 then Int
2 else Int
1, Int
rhi forall a. Num a => a -> a -> a
+ Int
2)
  }
  where uptickIndent :: Int
uptickIndent = Int
graphIndent forall a. Num a => a -> a -> a
+ Int
uptickIndex
        uptickIndex :: Int
uptickIndex = Int
graphWidth forall a. Integral a => a -> a -> a
`div` Int
2
        (Int
llo,Int
lhi) = (Int, Int)
leftLimit
        (Int
rlo,Int
rhi) = (Int, Int)
rightLimit
        graphLine :: ShowS
graphLine = GraphEnvironment -> ShowS
graph GraphEnvironment
          { isLeftmost :: Bool
isLeftmost = Bool
True
          , isRightmost :: Bool
isRightmost = Bool
True
          , uptickIndex :: Int
uptickIndex = Int
uptickIndex
          }