cli/Hcompta/CLI/Lib/Leijen/Table.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 module Hcompta.CLI.Lib.Leijen.Table where
   5
   6 import           Data.Bool
   7 import           Data.Char (Char)
   8 import           Data.Foldable (Foldable(..))
   9 import           Data.Foldable (any)
  10 import qualified Data.List
  11 import           Data.List (map, replicate)
  12 import           Data.Maybe (Maybe(..))
  13 import           Data.Maybe (fromMaybe)
  14 import           Data.Ord (Ord(..))
  15 import           Data.Text (Text)
  16 import qualified Data.Text as Text
  17 import qualified Data.Text.Lazy as TL
  18 import           Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
  19
  20 import qualified Hcompta.Lib.Leijen as W
  21 import           Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
  22
  23 -- * The 'Table' type
  24
  25 type Table = [Column]
  26
  27 -- * The 'Column' type
  28
  29 data Column
  30  =   Column
  31  { column_title :: Text
  32  , column_width :: Int
  33  , column_align :: Align
  34  , column_rows  :: [Cell]
  35  }
  36 instance ToDoc () [Column] where
  37         toDoc _m cols = do
  38                 let rows = Data.List.transpose $ map column_rows cols
  39                 let has_title = any (not . Text.null . column_title) cols
  40                 let titles =
  41                         W.intercalate (W.bold $ W.dullblack $ W.char '|')
  42                          (\col@Column{column_title} -> do
  43                                 let cell_width = Text.length column_title
  44                                 let under = W.bold $ W.dullblack $ W.char '_'
  45                                 let cell_content = W.enclose under under $
  46                                         W.hcat $ map
  47                                          (\c -> case c of { ' ' -> under; _ -> W.char c })
  48                                          (Text.unpack column_title)
  49                                 let pad len = W.bold $ W.dullblack $
  50                                         W.text $ TL.pack $ replicate len '_'
  51                                 align (Just pad) col
  52                                  Cell{cell_width, cell_content, cell_align=Just Align_Center}
  53                          ) cols
  54                 W.vsep (
  55                         (if has_title then (:) titles else id) $
  56                         map
  57                          ( W.intercalate (W.space <> do W.bold $ W.dullblack $ W.char '|') id
  58                          . map (W.space <>)
  59                          . zipWith toDoc cols
  60                          ) rows
  61                  ) <> do
  62                 (case cols of { [] -> W.empty; _ -> W.line })
  63 column :: Text -> Align -> [Cell] -> Column
  64 column column_title column_align column_rows =
  65         Column
  66          { column_title
  67          , column_width = max (Text.length column_title) $
  68                           foldr (max . cell_width) 0 column_rows
  69          , column_align
  70          , column_rows
  71          }
  72
  73 -- ** The 'Align' type
  74
  75 data Align
  76  = Align_Left
  77  | Align_Center
  78  | Align_Right
  79 align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
  80 align filling
  81  Column{column_width, column_align}
  82  Cell{cell_width, cell_content, cell_align} =
  83         let pad = column_width - cell_width in
  84         let fill = fromMaybe (`W.fill` W.empty) filling in
  85         case fromMaybe column_align cell_align of
  86          Align_Left   -> cell_content <> fill pad
  87          Align_Center ->
  88                 let half = fromInteger $ quot (toInteger pad) 2 in
  89                 fill half <> cell_content <> fill (pad - half)
  90          Align_Right  -> fill pad <> cell_content
  91 align _filling
  92  Column{column_width}
  93  (Cell_Line {cell_pad}) =
  94         W.bold $ W.dullblack $ W.text $
  95         TL.replicate (fromIntegral column_width) $
  96         TL.singleton cell_pad
  97
  98 -- * The 'Cell' type
  99
 100 data Cell
 101  = Cell
 102          { cell_align   :: Maybe Align
 103          , cell_width   :: Int
 104          , cell_content :: W.Doc
 105          }
 106  | Cell_Line
 107          { cell_pad     :: Char
 108          , cell_width   :: Int
 109          }
 110 cell :: Cell
 111 cell =
 112         Cell
 113          { cell_width   = 0
 114          , cell_content = W.empty
 115          , cell_align   = Nothing
 116          }
 117 instance ToDoc Column Cell where
 118         toDoc = align Nothing