-- | Basic table building for prettier futhark-test output.
module Futhark.Util.Table
  ( hPutTable,
    mkEntry,
    Entry,
    AnsiStyle,
    Color (..),
    color,
  )
where

import Data.List (intersperse, transpose)
import Futhark.Util (maxinum)
import Futhark.Util.Pretty hiding (sep, width)
import System.IO (Handle)

data RowTemplate = RowTemplate [Int] Int deriving (Int -> RowTemplate -> ShowS
[RowTemplate] -> ShowS
RowTemplate -> String
(Int -> RowTemplate -> ShowS)
-> (RowTemplate -> String)
-> ([RowTemplate] -> ShowS)
-> Show RowTemplate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RowTemplate -> ShowS
showsPrec :: Int -> RowTemplate -> ShowS
$cshow :: RowTemplate -> String
show :: RowTemplate -> String
$cshowList :: [RowTemplate] -> ShowS
showList :: [RowTemplate] -> ShowS
Show)

-- | A table entry. Consists of the content as well as how it should
-- be styled..
data Entry = Entry {Entry -> String
entryText :: String, Entry -> AnsiStyle
_entryStyle :: AnsiStyle}

-- | Makes a table entry.
mkEntry :: String -> AnsiStyle -> Entry
mkEntry :: String -> AnsiStyle -> Entry
mkEntry = String -> AnsiStyle -> Entry
Entry

buildRowTemplate :: [[Entry]] -> Int -> RowTemplate
buildRowTemplate :: [[Entry]] -> Int -> RowTemplate
buildRowTemplate [[Entry]]
rows = [Int] -> Int -> RowTemplate
RowTemplate [Int]
widths
  where
    widths :: [Int]
widths = ([Entry] -> Int) -> [[Entry]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall a (f :: * -> *). (Num a, Ord a, Foldable f) => f a -> a
maxinum ([Int] -> Int) -> ([Entry] -> [Int]) -> [Entry] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry -> Int) -> [Entry] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Entry -> String) -> Entry -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> String
entryText)) ([[Entry]] -> [Int])
-> ([[Entry]] -> [[Entry]]) -> [[Entry]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Entry]] -> [[Entry]]
forall a. [[a]] -> [[a]]
transpose ([[Entry]] -> [Int]) -> [[Entry]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Entry]]
rows

buildRow :: RowTemplate -> [Entry] -> Doc AnsiStyle
buildRow :: RowTemplate -> [Entry] -> Doc AnsiStyle
buildRow (RowTemplate [Int]
widths Int
pad) [Entry]
entries = Doc AnsiStyle
cells Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
  where
    bar :: Doc AnsiStyle
bar = Doc AnsiStyle
"\x2502"
    cells :: Doc AnsiStyle
cells = [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat ((Entry -> Int -> Doc AnsiStyle)
-> [Entry] -> [Int] -> [Doc AnsiStyle]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Entry -> Int -> Doc AnsiStyle
buildCell [Entry]
entries [Int]
widths) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
bar
    buildCell :: Entry -> Int -> Doc AnsiStyle
buildCell (Entry String
entry AnsiStyle
sgr) Int
width =
      let padding :: Int
padding = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
entry Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pad
       in Doc AnsiStyle
bar Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
sgr (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
entry) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat (Int -> Doc AnsiStyle -> [Doc AnsiStyle]
forall a. Int -> a -> [a]
replicate Int
padding Doc AnsiStyle
" ")

buildSep :: Char -> Char -> Char -> RowTemplate -> Doc AnsiStyle
buildSep :: Char -> Char -> Char -> RowTemplate -> Doc AnsiStyle
buildSep Char
lCorner Char
rCorner Char
sep (RowTemplate [Int]
widths Int
pad) =
  String -> Doc AnsiStyle
forall {a} {ann}. Pretty a => [a] -> Doc ann
corners (String -> Doc AnsiStyle)
-> ([Int] -> String) -> [Int] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> String
cellFloor ([Int] -> Doc AnsiStyle) -> [Int] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Int]
widths
  where
    cellFloor :: Int -> String
cellFloor Int
width = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
'\x2500' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char
sep]
    corners :: [a] -> Doc ann
corners [] = Doc ann
""
    corners [a]
s = Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
lCorner Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [a] -> Doc ann
forall ann. [a] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
s) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
rCorner

-- | Produce a table from a list of entries and a padding amount that
-- determines padding from the right side of the widest entry in each column.
hPutTable :: Handle -> [[Entry]] -> Int -> IO ()
hPutTable :: Handle -> [[Entry]] -> Int -> IO ()
hPutTable Handle
h [[Entry]]
rows Int
pad = Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
h (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ RowTemplate -> Doc AnsiStyle
buildTop RowTemplate
template Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
sepRows Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> RowTemplate -> Doc AnsiStyle
buildBottom RowTemplate
template Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
  where
    sepRows :: Doc AnsiStyle
sepRows = [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
intersperse (RowTemplate -> Doc AnsiStyle
buildFloor RowTemplate
template) [Doc AnsiStyle]
builtRows
    builtRows :: [Doc AnsiStyle]
builtRows = ([Entry] -> Doc AnsiStyle) -> [[Entry]] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (RowTemplate -> [Entry] -> Doc AnsiStyle
buildRow RowTemplate
template) [[Entry]]
rows
    template :: RowTemplate
template = [[Entry]] -> Int -> RowTemplate
buildRowTemplate [[Entry]]
rows Int
pad
    buildTop :: RowTemplate -> Doc AnsiStyle
buildTop RowTemplate
rt = Char -> Char -> Char -> RowTemplate -> Doc AnsiStyle
buildSep Char
'\x250C' Char
'\x2510' Char
'\x252C' RowTemplate
rt Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
    buildFloor :: RowTemplate -> Doc AnsiStyle
buildFloor RowTemplate
rt = Char -> Char -> Char -> RowTemplate -> Doc AnsiStyle
buildSep Char
'\x251C' Char
'\x2524' Char
'\x253C' RowTemplate
rt Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
    buildBottom :: RowTemplate -> Doc AnsiStyle
buildBottom = Char -> Char -> Char -> RowTemplate -> Doc AnsiStyle
buildSep Char
'\x2514' Char
'\x2518' Char
'\x2534'