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)
data Entry = Entry {Entry -> String
entryText :: String, Entry -> AnsiStyle
_entryStyle :: AnsiStyle}
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
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'