-- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat
-- wide characters as double width.

module Text.Tabular.AsciiWide where

import Data.List (intersperse, transpose)
import Text.Tabular
import Hledger.Utils.String

-- | for simplicity, we assume that each cell is rendered
--   on a single line
render :: Bool -- ^ pretty tables
       -> (rh -> String)
       -> (ch -> String)
       -> (a -> String)
       -> Table rh ch a
       -> String
render :: Bool
-> (rh -> String)
-> (ch -> String)
-> (a -> String)
-> Table rh ch a
-> String
render pretty :: Bool
pretty fr :: rh -> String
fr fc :: ch -> String
fc f :: a -> String
f (Table rh :: Header rh
rh ch :: Header ch
ch cells :: [[a]]
cells) =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ VPos -> Properties -> String
bar VPos
VT Properties
SingleLine   -- +--------------------------------------+
            , Bool -> [Int] -> Header String -> String
renderColumns Bool
pretty [Int]
sizes Header String
ch2
            , VPos -> Properties -> String
bar VPos
VM Properties
DoubleLine   -- +======================================+
            ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            (Header String -> [String]
renderRs (Header String -> [String]) -> Header String -> [String]
forall a b. (a -> b) -> a -> b
$ (([a], String) -> String) -> Header ([a], String) -> Header String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([a], String) -> String
renderR (Header ([a], String) -> Header String)
-> Header ([a], String) -> Header String
forall a b. (a -> b) -> a -> b
$ [a] -> [[a]] -> Header String -> Header ([a], String)
forall h a. h -> [h] -> Header a -> Header (h, a)
zipHeader [] [[a]]
cells (Header String -> Header ([a], String))
-> Header String -> Header ([a], String)
forall a b. (a -> b) -> a -> b
$ (rh -> String) -> Header rh -> Header String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap rh -> String
fr Header rh
rh) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            [ VPos -> Properties -> String
bar VPos
VB Properties
SingleLine ] -- +--------------------------------------+
 where
  bar :: VPos -> Properties -> String
bar vpos :: VPos
vpos prop :: Properties
prop = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (VPos -> Bool -> [Int] -> Header String -> Properties -> [String]
renderHLine VPos
vpos Bool
pretty [Int]
sizes Header String
ch2 Properties
prop)
  -- ch2 and cell2 include the row and column labels
  ch2 :: Header String
ch2 = Properties -> [Header String] -> Header String
forall h. Properties -> [Header h] -> Header h
Group Properties
DoubleLine [String -> Header String
forall h. h -> Header h
Header "", (ch -> String) -> Header ch -> Header String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ch -> String
fc Header ch
ch]
  cells2 :: [[String]]
cells2 = Header String -> [String]
forall h. Header h -> [h]
headerContents Header String
ch2
         [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: (String -> [a] -> [String]) -> [String] -> [[a]] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\h :: String
h cs :: [a]
cs -> String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
cs) [String]
rhStrings [[a]]
cells
  --
  renderR :: ([a], String) -> String
renderR (cs :: [a]
cs,h :: String
h) = Bool -> [Int] -> Header String -> String
renderColumns Bool
pretty [Int]
sizes (Header String -> String) -> Header String -> String
forall a b. (a -> b) -> a -> b
$ Properties -> [Header String] -> Header String
forall h. Properties -> [Header h] -> Header h
Group Properties
DoubleLine
                    [ String -> Header String
forall h. h -> Header h
Header String
h
                    , ((String, ch) -> String) -> Header (String, ch) -> Header String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ch) -> String
forall a b. (a, b) -> a
fst (Header (String, ch) -> Header String)
-> Header (String, ch) -> Header String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Header ch -> Header (String, ch)
forall h a. h -> [h] -> Header a -> Header (h, a)
zipHeader "" ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
cs) Header ch
ch]
  rhStrings :: [String]
rhStrings = (rh -> String) -> [rh] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map rh -> String
fr ([rh] -> [String]) -> [rh] -> [String]
forall a b. (a -> b) -> a -> b
$ Header rh -> [rh]
forall h. Header h -> [h]
headerContents Header rh
rh
  -- maximum width for each column
  sizes :: [Int]
sizes   = ([String] -> Int) -> [[String]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([String] -> [Int]) -> [String] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
strWidth) ([[String]] -> [Int])
-> ([[String]] -> [[String]]) -> [[String]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
forall a. [[a]] -> [[a]]
transpose ([[String]] -> [Int]) -> [[String]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[String]]
cells2
  renderRs :: Header String -> [String]
renderRs (Header s :: String
s)   = [String
s]
  renderRs (Group p :: Properties
p hs :: [Header String]
hs) = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([Header String] -> [[String]]) -> [Header String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
intersperse [String]
sep ([[String]] -> [[String]])
-> ([Header String] -> [[String]]) -> [Header String] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header String -> [String]) -> [Header String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Header String -> [String]
renderRs ([Header String] -> [String]) -> [Header String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Header String]
hs
    where sep :: [String]
sep = VPos -> Bool -> [Int] -> Header String -> Properties -> [String]
renderHLine VPos
VM Bool
pretty [Int]
sizes Header String
ch2 Properties
p

verticalBar :: Bool -> Char
verticalBar :: Bool -> Char
verticalBar pretty :: Bool
pretty = if Bool
pretty then '│' else '|'

leftBar :: Bool -> String
leftBar :: Bool -> String
leftBar pretty :: Bool
pretty = Bool -> Char
verticalBar Bool
pretty Char -> String -> String
forall a. a -> [a] -> [a]
: " "

rightBar :: Bool -> String
rightBar :: Bool -> String
rightBar pretty :: Bool
pretty = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool -> Char
verticalBar Bool
pretty]

midBar :: Bool -> String
midBar :: Bool -> String
midBar pretty :: Bool
pretty = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> Char
verticalBar Bool
pretty Char -> String -> String
forall a. a -> [a] -> [a]
: " "

doubleMidBar :: Bool -> String
doubleMidBar :: Bool -> String
doubleMidBar pretty :: Bool
pretty = if Bool
pretty then " ║ " else " || "

-- | We stop rendering on the shortest list!
renderColumns :: Bool -- ^ pretty
              -> [Int] -- ^ max width for each column
              -> Header String
              -> String
renderColumns :: Bool -> [Int] -> Header String -> String
renderColumns pretty :: Bool
pretty is :: [Int]
is h :: Header String
h = Bool -> String
leftBar Bool
pretty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
coreLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
rightBar Bool
pretty
 where
  coreLine :: String
coreLine = (Either Properties (Int, String) -> String)
-> [Either Properties (Int, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either Properties (Int, String) -> String
helper ([Either Properties (Int, String)] -> String)
-> [Either Properties (Int, String)] -> String
forall a b. (a -> b) -> a -> b
$ Header (Int, String) -> [Either Properties (Int, String)]
forall h. Header h -> [Either Properties h]
flattenHeader (Header (Int, String) -> [Either Properties (Int, String)])
-> Header (Int, String) -> [Either Properties (Int, String)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> Header String -> Header (Int, String)
forall h a. h -> [h] -> Header a -> Header (h, a)
zipHeader 0 [Int]
is Header String
h
  helper :: Either Properties (Int, String) -> String
helper = (Properties -> String)
-> ((Int, String) -> String)
-> Either Properties (Int, String)
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Properties -> String
hsep ((Int -> String -> String) -> (Int, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> String -> String
padLeftWide)
  hsep :: Properties -> String
  hsep :: Properties -> String
hsep NoLine     = "  "
  hsep SingleLine = Bool -> String
midBar Bool
pretty
  hsep DoubleLine = Bool -> String
doubleMidBar Bool
pretty

renderHLine :: VPos
            -> Bool -- ^ pretty
            -> [Int] -- ^ width specifications
            -> Header String
            -> Properties
            -> [String]
renderHLine :: VPos -> Bool -> [Int] -> Header String -> Properties -> [String]
renderHLine _ _ _ _ NoLine = []
renderHLine vpos :: VPos
vpos pretty :: Bool
pretty w :: [Int]
w h :: Header String
h prop :: Properties
prop = [VPos -> Bool -> Properties -> [Int] -> Header String -> String
renderHLine' VPos
vpos Bool
pretty Properties
prop [Int]
w Header String
h]

renderHLine' :: VPos -> Bool -> Properties -> [Int] -> Header String -> String
renderHLine' :: VPos -> Bool -> Properties -> [Int] -> Header String -> String
renderHLine' vpos :: VPos
vpos pretty :: Bool
pretty prop :: Properties
prop is :: [Int]
is h :: Header String
h = HPos -> String
edge HPos
HL String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
coreLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ HPos -> String
edge HPos
HR
 where
  edge :: HPos -> String
edge hpos :: HPos
hpos       = VPos -> HPos -> Properties -> Properties -> Bool -> String
boxchar VPos
vpos HPos
hpos Properties
SingleLine Properties
prop Bool
pretty
  coreLine :: String
coreLine        = (Either Properties (Int, String) -> String)
-> [Either Properties (Int, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either Properties (Int, String) -> String
forall b. Either Properties (Int, b) -> String
helper ([Either Properties (Int, String)] -> String)
-> [Either Properties (Int, String)] -> String
forall a b. (a -> b) -> a -> b
$ Header (Int, String) -> [Either Properties (Int, String)]
forall h. Header h -> [Either Properties h]
flattenHeader (Header (Int, String) -> [Either Properties (Int, String)])
-> Header (Int, String) -> [Either Properties (Int, String)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> Header String -> Header (Int, String)
forall h a. h -> [h] -> Header a -> Header (h, a)
zipHeader 0 [Int]
is Header String
h
  helper :: Either Properties (Int, b) -> String
helper          = (Properties -> String)
-> ((Int, b) -> String) -> Either Properties (Int, b) -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Properties -> String
vsep (Int, b) -> String
forall b. (Int, b) -> String
dashes
  dashes :: (Int, b) -> String
dashes (i :: Int
i,_)    = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
i String
sep)
  sep :: String
sep             = VPos -> HPos -> Properties -> Properties -> Bool -> String
boxchar VPos
vpos HPos
HM Properties
NoLine Properties
prop Bool
pretty
  vsep :: Properties -> String
vsep v :: Properties
v          = case Properties
v of
                      NoLine -> String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep
                      _      -> String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ Properties -> Properties -> String
cross Properties
v Properties
prop String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep
  cross :: Properties -> Properties -> String
cross v :: Properties
v h :: Properties
h       = VPos -> HPos -> Properties -> Properties -> Bool -> String
boxchar VPos
vpos HPos
HM Properties
v Properties
h Bool
pretty

data VPos = VT | VM | VB -- top middle bottom
data HPos = HL | HM | HR -- left middle right

boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> String
boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> String
boxchar vpos :: VPos
vpos hpos :: HPos
hpos vert :: Properties
vert horiz :: Properties
horiz = Properties
-> Properties -> Properties -> Properties -> Bool -> String
lineart Properties
u Properties
d Properties
l Properties
r
  where
    u :: Properties
u =
      case VPos
vpos of
        VT -> Properties
NoLine
        _  -> Properties
vert
    d :: Properties
d =
      case VPos
vpos of
        VB -> Properties
NoLine
        _  -> Properties
vert
    l :: Properties
l =
      case HPos
hpos of
        HL -> Properties
NoLine
        _  -> Properties
horiz
    r :: Properties
r =
      case HPos
hpos of
        HR -> Properties
NoLine
        _  -> Properties
horiz

pick :: String -> String -> Bool -> String
pick :: String -> String -> Bool -> String
pick x :: String
x _ True  = String
x
pick _ x :: String
x False = String
x

lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> String
--      up         down       left      right
lineart :: Properties
-> Properties -> Properties -> Properties -> Bool -> String
lineart SingleLine SingleLine SingleLine SingleLine = String -> String -> Bool -> String
pick "┼" "+"
lineart SingleLine SingleLine SingleLine NoLine     = String -> String -> Bool -> String
pick "┤" "+"
lineart SingleLine SingleLine NoLine     SingleLine = String -> String -> Bool -> String
pick "├" "+"
lineart SingleLine NoLine     SingleLine SingleLine = String -> String -> Bool -> String
pick "┴" "+"
lineart NoLine     SingleLine SingleLine SingleLine = String -> String -> Bool -> String
pick "┬" "+"
lineart SingleLine NoLine     NoLine     SingleLine = String -> String -> Bool -> String
pick "└" "+"
lineart SingleLine NoLine     SingleLine NoLine     = String -> String -> Bool -> String
pick "┘" "+"
lineart NoLine     SingleLine SingleLine NoLine     = String -> String -> Bool -> String
pick "┐" "+"
lineart NoLine     SingleLine NoLine     SingleLine = String -> String -> Bool -> String
pick "┌" "+"
lineart SingleLine SingleLine NoLine     NoLine     = String -> String -> Bool -> String
pick "│" "|"
lineart NoLine     NoLine     SingleLine SingleLine = String -> String -> Bool -> String
pick "─" "-"

lineart DoubleLine DoubleLine DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╬" "++"
lineart DoubleLine DoubleLine DoubleLine NoLine     = String -> String -> Bool -> String
pick "╣" "++"
lineart DoubleLine DoubleLine NoLine     DoubleLine = String -> String -> Bool -> String
pick "╠" "++"
lineart DoubleLine NoLine     DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╩" "++"
lineart NoLine     DoubleLine DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╦" "++"
lineart DoubleLine NoLine     NoLine     DoubleLine = String -> String -> Bool -> String
pick "╚" "++"
lineart DoubleLine NoLine     DoubleLine NoLine     = String -> String -> Bool -> String
pick "╝" "++"
lineart NoLine     DoubleLine DoubleLine NoLine     = String -> String -> Bool -> String
pick "╗" "++"
lineart NoLine     DoubleLine NoLine     DoubleLine = String -> String -> Bool -> String
pick "╔" "++"
lineart DoubleLine DoubleLine NoLine     NoLine     = String -> String -> Bool -> String
pick "║" "||"
lineart NoLine     NoLine     DoubleLine DoubleLine = String -> String -> Bool -> String
pick "═" "="

lineart DoubleLine NoLine     NoLine     SingleLine = String -> String -> Bool -> String
pick "╙" "++"
lineart DoubleLine NoLine     SingleLine NoLine     = String -> String -> Bool -> String
pick "╜" "++"
lineart NoLine     DoubleLine SingleLine NoLine     = String -> String -> Bool -> String
pick "╖" "++"
lineart NoLine     DoubleLine NoLine     SingleLine = String -> String -> Bool -> String
pick "╓" "++"

lineart SingleLine NoLine     NoLine     DoubleLine = String -> String -> Bool -> String
pick "╘" "+"
lineart SingleLine NoLine     DoubleLine NoLine     = String -> String -> Bool -> String
pick "╛" "+"
lineart NoLine     SingleLine DoubleLine NoLine     = String -> String -> Bool -> String
pick "╕" "+"
lineart NoLine     SingleLine NoLine     DoubleLine = String -> String -> Bool -> String
pick "╒" "+"

lineart DoubleLine DoubleLine SingleLine NoLine     = String -> String -> Bool -> String
pick "╢" "++"
lineart DoubleLine DoubleLine NoLine     SingleLine = String -> String -> Bool -> String
pick "╟" "++"
lineart DoubleLine NoLine     SingleLine SingleLine = String -> String -> Bool -> String
pick "╨" "++"
lineart NoLine     DoubleLine SingleLine SingleLine = String -> String -> Bool -> String
pick "╥" "++"

lineart SingleLine SingleLine DoubleLine NoLine     = String -> String -> Bool -> String
pick "╡" "+"
lineart SingleLine SingleLine NoLine     DoubleLine = String -> String -> Bool -> String
pick "╞" "+"
lineart SingleLine NoLine     DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╧" "+"
lineart NoLine     SingleLine DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╤" "+"

lineart SingleLine SingleLine DoubleLine DoubleLine = String -> String -> Bool -> String
pick "╪" "+"
lineart DoubleLine DoubleLine SingleLine SingleLine = String -> String -> Bool -> String
pick "╫" "++"

lineart _          _          _          _          = String -> Bool -> String
forall a b. a -> b -> a
const ""

--