{-# LANGUAGE StrictData #-}

module Little.Earley.Internal.Render where

import Little.Earley.Internal.Core
import Little.Earley.Internal.Tree
import Little.Earley.Internal.Pretty

-- * Render parse trees

data Box a = Box
  { Box a -> Int
height :: Int
  , Box a -> Int
width :: Int
  , Box a -> a
contents :: a
  } deriving (Box a -> Box a -> Bool
(Box a -> Box a -> Bool) -> (Box a -> Box a -> Bool) -> Eq (Box a)
forall a. Eq a => Box a -> Box a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Box a -> Box a -> Bool
$c/= :: forall a. Eq a => Box a -> Box a -> Bool
== :: Box a -> Box a -> Bool
$c== :: forall a. Eq a => Box a -> Box a -> Bool
Eq, Int -> Box a -> ShowS
[Box a] -> ShowS
Box a -> String
(Int -> Box a -> ShowS)
-> (Box a -> String) -> ([Box a] -> ShowS) -> Show (Box a)
forall a. Show a => Int -> Box a -> ShowS
forall a. Show a => [Box a] -> ShowS
forall a. Show a => Box a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Box a] -> ShowS
$cshowList :: forall a. Show a => [Box a] -> ShowS
show :: Box a -> String
$cshow :: forall a. Show a => Box a -> String
showsPrec :: Int -> Box a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Box a -> ShowS
Show)

data PicTree
  = PTBranch String [(Int, PicTree)]  -- Implicit space between columns
  | PTCenterLine Int PicTree
  | PTEmpty
  deriving (PicTree -> PicTree -> Bool
(PicTree -> PicTree -> Bool)
-> (PicTree -> PicTree -> Bool) -> Eq PicTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PicTree -> PicTree -> Bool
$c/= :: PicTree -> PicTree -> Bool
== :: PicTree -> PicTree -> Bool
$c== :: PicTree -> PicTree -> Bool
Eq, Int -> PicTree -> ShowS
[PicTree] -> ShowS
PicTree -> String
(Int -> PicTree -> ShowS)
-> (PicTree -> String) -> ([PicTree] -> ShowS) -> Show PicTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PicTree] -> ShowS
$cshowList :: [PicTree] -> ShowS
show :: PicTree -> String
$cshow :: PicTree -> String
showsPrec :: Int -> PicTree -> ShowS
$cshowsPrec :: Int -> PicTree -> ShowS
Show)

-- | Draw a tree in the terminal.
drawTree :: (n -> String) -> (c -> String) -> Tree n t c -> [String]
drawTree :: (n -> String) -> (c -> String) -> Tree n t c -> [String]
drawTree n -> String
showN c -> String
showC = Box PicTree -> [String]
drawPicTree (Box PicTree -> [String])
-> (Tree n t c -> Box PicTree) -> Tree n t c -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
forall n c t.
(n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
formatTree n -> String
showN c -> String
showC

ptLeaf :: String -> PicTree
ptLeaf :: String -> PicTree
ptLeaf String
s = String -> [(Int, PicTree)] -> PicTree
PTBranch String
s []

drawPicTree :: Box PicTree -> [String]
drawPicTree :: Box PicTree -> [String]
drawPicTree Box PicTree
u = Int -> [(Int, PicTree)] -> [String]
forall t. (Eq t, Num t) => t -> [(Int, PicTree)] -> [String]
draw (Box PicTree -> Int
forall a. Box a -> Int
height Box PicTree
u) [(Box PicTree -> Int
forall a. Box a -> Int
width Box PicTree
u, Box PicTree -> PicTree
forall a. Box a -> a
contents Box PicTree
u)] where
  draw :: t -> [(Int, PicTree)] -> [String]
draw t
0 [(Int, PicTree)]
_ = String -> [String]
forall a. HasCallStack => String -> a
error String
"Should not happen"
  draw t
h [(Int, PicTree)]
xs
    | t
h t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
1 = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Box PicTree -> Int
forall a. Box a -> Int
width Box PicTree
u) Char
'-' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []
    | Bool
otherwise = String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: t -> [(Int, PicTree)] -> [String]
draw (t
ht -> t -> t
forall a. Num a => a -> a -> a
-t
1) [(Int, PicTree)]
ys
    where (String
l, [(Int, PicTree)]
ys) = [(Int, PicTree)] -> (String, [(Int, PicTree)])
drawLine [(Int, PicTree)]
xs

drawLine :: [(Int, PicTree)] -> (String, [(Int, PicTree)])
drawLine :: [(Int, PicTree)] -> (String, [(Int, PicTree)])
drawLine = ((Int, PicTree) -> (String, [(Int, PicTree)]))
-> [(Int, PicTree)] -> (String, [(Int, PicTree)])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, PicTree) -> (String, [(Int, PicTree)])
drawElem

drawElem :: (Int, PicTree) -> (String, [(Int, PicTree)])
drawElem :: (Int, PicTree) -> (String, [(Int, PicTree)])
drawElem (Int
w, PicTree
PTEmpty) = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
w Char
' ', [(Int
w, PicTree
PTEmpty)])
drawElem (Int
w, PTCenterLine Int
h PicTree
p) = (Int -> ShowS
center Int
w String
"|", [(Int
w, if Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then PicTree
p else Int -> PicTree -> PicTree
PTCenterLine (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) PicTree
p)])
drawElem (Int
w, PTBranch String
s []) = (Int -> ShowS
center Int
w String
s, [(Int
w, PicTree
PTEmpty)])
drawElem (Int
w, PTBranch String
s [(Int, PicTree)]
us) = (String
hdr, [(Int, PicTree)]
ps) where
  hdr :: String
hdr = String -> ShowS
forall a. [a] -> [a] -> [a]
pasteCenter String
s ([Int] -> String
drawConnector (((Int, PicTree) -> Int) -> [(Int, PicTree)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, PicTree) -> Int
forall a b. (a, b) -> a
fst [(Int, PicTree)]
ps))
  ps :: [(Int, PicTree)]
ps = (Int -> (Int, PicTree) -> (Int, PicTree))
-> [Int] -> [(Int, PicTree)] -> [(Int, PicTree)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
w' (Int
w0, PicTree
p) -> (Int
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w0, PicTree
p)) (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
qw (Int
dw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
dw) [(Int, PicTree)]
us
  totalWidthChildren :: Int
totalWidthChildren = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, PicTree) -> Int) -> [(Int, PicTree)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, PicTree) -> Int
forall a b. (a, b) -> a
fst [(Int, PicTree)]
us)
  extraW :: Int
extraW = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
totalWidthChildren
  (Int
dw, Int
qw) = Int
extraW Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` [(Int, PicTree)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, PicTree)]
us

drawConnector :: [Int] -> String
drawConnector :: [Int] -> String
drawConnector [] = ShowS
forall a. HasCallStack => String -> a
error String
"Should not be empty"
drawConnector [Int
w] = Int -> ShowS
center Int
w String
"+"
drawConnector (Int
w : Int
w' : [Int]
ws) = Char -> Char -> Int -> ShowS
forall a. a -> a -> Int -> [a] -> [a]
center_ Char
' ' Char
'-' Int
w String
"+" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> String
drawConnector' Int
w' [Int]
ws where
  drawConnector' :: Int -> [Int] -> String
drawConnector' Int
w0 [] = Char -> Char -> Int -> ShowS
forall a. a -> a -> Int -> [a] -> [a]
center_ Char
'-' Char
' ' Int
w0 String
"+"
  drawConnector' Int
w0 (Int
w1 : [Int]
ws1) = Char -> Char -> Int -> ShowS
forall a. a -> a -> Int -> [a] -> [a]
center_ Char
'-' Char
'-' Int
w0 String
"+" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> String
drawConnector' Int
w1 [Int]
ws1

pasteCenter :: [a] -> [a] -> [a]
pasteCenter :: [a] -> [a] -> [a]
pasteCenter [a]
mid [a]
full = [a]
xl [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
mid [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xr where
  nmid :: Int
nmid = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
mid
  nfull :: Int
nfull = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
full
  wl :: Int
wl = (Int
nfull Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nmid) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  ([a]
xl, [a]
full') = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
wl [a]
full
  xr :: [a]
xr = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
nmid [a]
full'

center :: Int -> String -> String
center :: Int -> ShowS
center = Char -> Char -> Int -> ShowS
forall a. a -> a -> Int -> [a] -> [a]
center_ Char
' ' Char
' '

center_ :: a -> a -> Int -> [a] -> [a]
center_ :: a -> a -> Int -> [a] -> [a]
center_ a
cl a
cr Int
w [a]
s = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
wl a
cl [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
wr a
cr where
  len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s
  wl :: Int
wl = (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  wr :: Int
wr = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wl

formatTree :: (n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
formatTree :: (n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
formatTree n -> String
_drawN c -> String
drawC (Leaf t
_t c
c) = Box :: forall a. Int -> Int -> a -> Box a
Box
  { height :: Int
height = Int
1
  , width :: Int
width = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c'
  , contents :: PicTree
contents = String -> PicTree
ptLeaf String
c'
  } where c' :: String
c' = c -> String
drawC c
c
formatTree n -> String
drawN c -> String
_drawC (RuleId n
n Int
j ::- []) = Box :: forall a. Int -> Int -> a -> Box a
Box
  { height :: Int
height = Int
3
  , width :: Int
width = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
nj'
  , contents :: PicTree
contents = String -> PicTree
ptLeaf String
nj'
  } where nj' :: String
nj' = n -> String
drawN n
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j
formatTree n -> String
drawN c -> String
drawC (RuleId n
n Int
j ::- [(Int, Tree n t c)]
us) = Box :: forall a. Int -> Int -> a -> Box a
Box
  { height :: Int
height = Int
height'
  , width :: Int
width = Int
width'
  , contents :: PicTree
contents = String -> [(Int, PicTree)] -> PicTree
PTBranch String
nj'
      [(Box PicTree -> Int
forall a. Box a -> Int
width Box PicTree
u', Int -> PicTree -> PicTree
PTCenterLine (Int
maxHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Box PicTree -> Int
forall a. Box a -> Int
height Box PicTree
u' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Box PicTree -> PicTree
forall a. Box a -> a
contents Box PicTree
u')) | Box PicTree
u' <- [Box PicTree]
us']
  } where
      us' :: [Box PicTree]
us' = ((Int, Tree n t c) -> Box PicTree)
-> [(Int, Tree n t c)] -> [Box PicTree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
forall n c t.
(n -> String) -> (c -> String) -> Tree n t c -> Box PicTree
formatTree n -> String
drawN c -> String
drawC (Tree n t c -> Box PicTree)
-> ((Int, Tree n t c) -> Tree n t c)
-> (Int, Tree n t c)
-> Box PicTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Tree n t c) -> Tree n t c
forall a b. (a, b) -> b
snd) [(Int, Tree n t c)]
us
      totalWidthChildren :: Int
totalWidthChildren = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Box PicTree -> Int) -> [Box PicTree] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Box PicTree -> Int
forall a. Box a -> Int
width [Box PicTree]
us') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Box PicTree] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box PicTree]
us' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      maxHeight :: Int
maxHeight = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Box PicTree -> Int) -> [Box PicTree] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Box PicTree -> Int
forall a. Box a -> Int
height [Box PicTree]
us')
      nj' :: String
nj' = n -> String
drawN n
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j
      height' :: Int
height' = Int
maxHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
      width' :: Int
width' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
totalWidthChildren (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
nj')

-- | 'drawTree' using 'prettyPrint' to show symbols.
prettyTree :: (PrettyPrint n, PrettyPrint c) => Tree n t c -> [String]
prettyTree :: Tree n t c -> [String]
prettyTree = (n -> String) -> (c -> String) -> Tree n t c -> [String]
forall n c t.
(n -> String) -> (c -> String) -> Tree n t c -> [String]
drawTree n -> String
forall a. PrettyPrint a => a -> String
prettyPrint c -> String
forall a. PrettyPrint a => a -> String
prettyPrint