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