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

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 module Hcompta.CLI.Lib.Leijen.Table where
   6
   7 import           Data.Bool
   8 import           Data.Char (Char)
   9 import qualified Data.Foldable as Foldable
  10 import qualified Data.List
  11 import           Data.List (map, replicate)
  12 import           Data.Maybe (Maybe(..), fromMaybe, maybe)
  13 import           Data.Monoid ((<>))
  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           Text.WalderLeijen.ANSI.Text (ToDoc(..))
  21 import qualified Text.WalderLeijen.ANSI.Text as W
  22
  23 -- * Type 'Table'
  24
  25 type Table = [Column]
  26
  27 -- ** Class 'Table_of'
  28
  29 class Table_of context x where
  30         table_of :: context -> x -> Table
  31
  32 -- * Type 'Column'
  33
  34 data Column
  35  =   Column
  36  { column_title :: Text
  37  , column_width :: Int
  38  , column_align :: Align
  39  , column_rows  :: [Cell]
  40  }
  41 instance ToDoc () [Column] where
  42         toDoc _m cols =
  43                 let rows = Data.List.transpose $ map column_rows cols in
  44                 let has_title = Foldable.any (not . Text.null . column_title) cols in
  45                 let titles =
  46                         W.intercalate (W.bold $ W.dullblack $ W.char '|')
  47                          (\col@Column{column_title} -> do
  48                                 let cell_width = Text.length column_title
  49                                 let under = W.bold $ W.dullblack $ W.char '_'
  50                                 let cell_content = W.enclose under under $
  51                                         W.hcat $ map
  52                                          (\c -> case c of { ' ' -> under; _ -> W.char c })
  53                                          (Text.unpack column_title)
  54                                 let pad len = W.bold $ W.dullblack $
  55                                         W.text $ TL.pack $ replicate len '_'
  56                                 align (Just pad) col
  57                                  Cell{cell_width, cell_content, cell_align=Just Align_Center}
  58                          ) cols in
  59                 W.vsep (
  60                         (if has_title then (:) titles else id) $
  61                         map
  62                          ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
  63                          . map (W.space <>)
  64                          . zipWith toDoc cols
  65                          ) rows
  66                  ) <>
  67                 (case cols of { [] -> W.empty; _ -> W.line })
  68 column :: Text -> Align -> [Cell] -> Column
  69 column column_title column_align column_rows =
  70         Column
  71          { column_title
  72          , column_width = max (Text.length column_title) $
  73                           Foldable.foldr (max . cell_width) 0 column_rows
  74          , column_align
  75          , column_rows
  76          }
  77
  78 -- ** Class 'Column_of'
  79
  80 class Column_of context x where
  81         column_of :: context -> x -> Column
  82
  83 -- ** Type 'Align'
  84
  85 data Align
  86  = Align_Left
  87  | Align_Center
  88  | Align_Right
  89 align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
  90 align filling
  91  Column{column_width, column_align}
  92  Cell{cell_width, cell_content, cell_align} =
  93         let pad = column_width - cell_width in
  94         let fill = fromMaybe (`W.fill` W.empty) filling in
  95         case fromMaybe column_align cell_align of
  96          Align_Left   -> cell_content <> fill pad
  97          Align_Center ->
  98                 let half = fromInteger $ quot (toInteger pad) 2 in
  99                 fill half <> cell_content <> fill (pad - half)
 100          Align_Right  -> fill pad <> cell_content
 101 align _filling
 102  Column{column_width}
 103  (Cell_Line {cell_pad}) =
 104         W.bold $ W.dullblack $ W.text $
 105         TL.replicate (fromIntegral column_width) $
 106         TL.singleton cell_pad
 107
 108 -- * Type 'Cell'
 109
 110 data Cell
 111  = Cell
 112          { cell_align   :: Maybe Align
 113          , cell_width   :: Int
 114          , cell_content :: W.Doc
 115          }
 116  | Cell_Line
 117          { cell_pad     :: Char
 118          , cell_width   :: Int
 119          }
 120 cell :: Cell
 121 cell =
 122         Cell
 123          { cell_width   = 0
 124          , cell_content = W.empty
 125          , cell_align   = Nothing
 126          }
 127 instance ToDoc Column Cell where
 128         toDoc = align Nothing
 129
 130 -- ** Class 'Cell_of'
 131
 132 class Cell_of context x where
 133         cell_of :: context -> x -> Cell
 134
 135 instance Cell_of context x => Cell_of context (Maybe x) where
 136         cell_of ctx = maybe cell (cell_of ctx)
 137
 138 -- ** Class 'Cell_of_forall_param'
 139
 140 -- | A class useful when using a context of kind '*' is not wanted
 141 --   for example in a class instance constraint
 142 --   to keep the instance decidable (i.e. avoid UndecidableInstances).
 143 class Cell_of_forall_param f x where
 144         cell_of_forall_param :: forall m. f m -> x -> Cell
 145 -- instance Cell_of_forall_param f x => Cell_of (f m) x where
 146 --      cell_of = cell_of_forall_param
 147 instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
 148         cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)