module Stlc.Block
( Block
, textBlock
, deductionBlock
, box
)
where
import Data.Monoid
newtype Block = Block { getBlock :: [String] }
deriving (Eq, Ord)
instance Monoid Block where
mappend = joinBlocks
mempty = Block [[]]
instance Show Block where
show = unlines . getBlock
hsepChar :: Char
hsepChar = '─'
spaceChar :: Char
spaceChar = ' '
height :: Block -> Int
height = length . getBlock
width :: Block -> Int
width (Block []) = 0
width (Block (x:_)) = length x
joinBlocks :: Block -> Block -> Block
joinBlocks u@(Block a) v@(Block b) = Block $ zipWith (++) us vs
where
us = replicate (mh - uh) (replicate uw spaceChar) ++ a
vs = replicate (mh - vh) (replicate vw spaceChar) ++ b
uh = height u
vh = height v
mh = max uh vh
uw = width u
vw = width v
stackBlocks :: String -> Block -> Block -> Block
stackBlocks label u v = Block $ getBlock ut ++ [hline] ++ getBlock vt
where
mw = max (width u) (width v)
us = centerBlock mw u
vs = centerBlock mw v
hline = replicate mw hsepChar ++ label
ut = us <> Block [replicate (length label) ' ']
vt = vs <> Block [replicate (length label) ' ']
centerBlock :: Int -> Block -> Block
centerBlock n = Block . map (centerString n) . getBlock
centerString :: Int -> String -> String
centerString n s = centered
where
w = length s
diff = n - w
semicentered = replicate (diff `div` 2 + diff `mod` 2) ' ' ++ s
centered = take n (semicentered ++ repeat ' ')
textBlock :: String -> Block
textBlock s = Block [centerString (length s) s]
deductionBlock :: Block -> String -> [Block] -> Block
deductionBlock inference label blocks = stackBlocks label top inference
where
top = if not (null blocks)
then foldr1 (\x y -> x <> Block [" "] <> y) blocks
else Block [""]
box :: Block -> Block
box c@(Block cm) = Block $
["╭" ++ replicate (width c) '─' ++ "╮"] ++
map (" " ++) cm ++
["╰" ++ replicate (width c) '─' ++ "╯"]