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