lcc/Hcompta/LCC/Write/Table.hs

   1 module Hcompta.LCC.Write.Table where
   2
   3 import Data.Bool
   4 import Data.Char (Char)
   5 import Data.Eq (Eq(..))
   6 import Data.Foldable (any, foldr)
   7 import Data.Functor ((<$>))
   8 import Data.Maybe (Maybe(..), fromMaybe)
   9 import Data.Ord (Ord(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.Text (Text)
  12 import Data.Tuple (curry)
  13 import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
  14 import Text.Show (Show)
  15 import qualified Data.List as L
  16 import qualified Data.Text as T
  17 import qualified Data.Text.Lazy as TL
  18
  19 import Hcompta.LCC.Write.Compta
  20 import qualified Language.Symantic.Document as D
  21
  22 -- * Type 'TablePlain'
  23 type TablePlain d = [ColumnPlain d]
  24
  25 instance (D.Doc_Text d, D.Doc_Color d) => Writeable d (TablePlain d) where
  26         write cols' =
  27                 let cols        = refreshWidthCol <$> cols' in
  28                 let rows        = L.transpose $ columnPlain_rows <$> cols in
  29                 let has_title   = any (not . T.null . columnPlain_title) cols in
  30                 let titles :: d = D.catH $ L.intersperse (d_sep '|') $ d_title <$> cols in
  31                 D.catV (
  32                         (if has_title then (:) titles else id) $
  33                         (<$> rows) $ \row ->
  34                                 D.catH $
  35                                 L.intersperse (D.space <> d_sep '|') $
  36                                 ((D.space <>) <$>) $
  37                                 zipWith (curry $ alignCellPlain Nothing) cols row
  38                  ) <>
  39                 (case cols of { [] -> D.empty; _ -> D.eol })
  40                 where
  41                 refreshWidthCol col@ColumnPlain{columnPlain_width=w} =
  42                         if w == 0
  43                         then col{columnPlain_width = widthCol col}
  44                         else col
  45                         where
  46                         widthCol :: ColumnPlain d -> Int
  47                         widthCol ColumnPlain
  48                          { columnPlain_title
  49                          , columnPlain_rows } =
  50                                 max (T.length columnPlain_title) $
  51                                 foldr (max . cellPlain_width) 0 columnPlain_rows
  52                 d_title :: ColumnPlain d -> d
  53                 d_title col@ColumnPlain{columnPlain_title} = do
  54                         let pad len = D.blacker $ D.text $ T.pack $ L.replicate len '_'
  55                         alignCellPlain (Just pad) (col, CellPlain
  56                          { cellPlain_width   = T.length columnPlain_title
  57                          , cellPlain_content = d_under <> d_underline columnPlain_title <> d_under
  58                          , cellPlain_align   = Just AlignPlainC
  59                          })
  60                 d_sep = D.blacker . D.charH
  61                 d_under = d_sep '_'
  62                 d_underline t =
  63                         D.catH $ (<$> T.unpack t) $ \case
  64                          ' ' -> d_under
  65                          c -> D.charH c
  66
  67                 alignCellPlain ::
  68                  D.Doc_Text d =>
  69                  D.Doc_Color d =>
  70                  Maybe (Int -> d) ->
  71                  (ColumnPlain d, CellPlain d) -> d
  72                 alignCellPlain may_padding
  73                  ( ColumnPlain{columnPlain_align, columnPlain_width}
  74                  , CellPlain{cellPlain_width, cellPlain_content, cellPlain_align} ) =
  75                         let pad = columnPlain_width - cellPlain_width in
  76                         case columnPlain_align `fromMaybe` cellPlain_align of
  77                          AlignPlainL -> cellPlain_content <> padding pad
  78                          AlignPlainC -> padding half <> cellPlain_content <> padding (pad - half)
  79                                 where half = fromInteger $ quot (toInteger pad) 2
  80                          AlignPlainR -> padding pad <> cellPlain_content
  81                         where padding = D.spaces `fromMaybe` may_padding
  82                 alignCellPlain _filling
  83                  ( ColumnPlain{columnPlain_width}
  84                  , CellPlain_Line{cellPlain_pad} ) =
  85                         D.blacker $ D.ltextH $
  86                         TL.replicate (fromIntegral columnPlain_width) $
  87                         TL.singleton cellPlain_pad
  88
  89 -- ** Class 'TablePlainOf'
  90 class TablePlainOf a d where
  91         tablePlainOf :: a -> TablePlain d
  92
  93 -- * Type 'ColumnPlain'
  94 data ColumnPlain d
  95  =   ColumnPlain
  96  {   columnPlain_title :: Text
  97  ,   columnPlain_align :: AlignPlain
  98  ,   columnPlain_width :: Int
  99  ,   columnPlain_rows  :: [CellPlain d]
 100  } deriving (Eq, Show)
 101
 102 columnPlain :: Text -> AlignPlain -> [CellPlain d] -> ColumnPlain d
 103 columnPlain t a r =
 104         ColumnPlain
 105          { columnPlain_title = t
 106          , columnPlain_align = a
 107          , columnPlain_width = 0
 108          , columnPlain_rows  = r
 109          }
 110
 111 -- ** Type 'AlignPlain'
 112 data AlignPlain
 113  =   AlignPlainL
 114  |   AlignPlainC
 115  |   AlignPlainR
 116  deriving (Eq, Show)
 117
 118 -- ** Class 'columnPlainOf'
 119 class ColumnPlainOf a d where
 120         columnPlainOf :: a -> ColumnPlain d
 121
 122 -- * Type 'CellPlain'
 123 data CellPlain d
 124  =   CellPlain { cellPlain_align   :: Maybe AlignPlain
 125                , cellPlain_width   :: Int
 126                , cellPlain_content :: d
 127                }
 128  |   CellPlain_Line { cellPlain_pad     :: Char
 129                     , cellPlain_width   :: Int
 130                     }
 131  deriving (Eq, Show)
 132
 133 -- ** Class 'CellPlainOf'
 134 class CellPlainOf a d where
 135         cellPlainOf :: a -> CellPlain d
 136         default cellPlainOf ::
 137          Writeable D.Dim a =>
 138          Writeable d a =>
 139          a -> CellPlain d
 140         cellPlainOf = cellPlain
 141
 142 instance D.Doc_Text d => CellPlainOf () d where
 143         cellPlainOf () = CellPlain
 144          { cellPlain_width   = 0
 145          , cellPlain_align   = Nothing
 146          , cellPlain_content = D.empty
 147          }
 148
 149 cellPlain ::
 150  Writeable D.Dim a =>
 151  Writeable d a =>
 152  a -> CellPlain d
 153 cellPlain a =
 154         CellPlain
 155          { cellPlain_width   = D.width $ D.dim $ write a
 156          , cellPlain_align   = Nothing
 157          , cellPlain_content = write a
 158          }
 159
 160
 161
 162
 163
 164
 165 {-
 166 instance ToDoc ColumnPlain CellPlain where
 167         toDoc = alignCellPlain Nothing
 168
 169 -- ** Class 'CellOf'
 170 class CellOf context x where
 171         cellOf :: context -> x -> CellPlain
 172
 173 instance CellOf context x => CellOf context (Maybe x) where
 174         cellOf ctx = maybe cellPlain (cellOf ctx)
 175
 176 -- ** Class 'Cell_of_forall_param'
 177
 178 -- | A class useful when using a context of kind '*' is not wanted
 179 --   for example in a class instance constraint
 180 --   to keep the instance decidable (i.e. avoid UndecidableInstances).
 181 class Cell_of_forall_param f x where
 182         cellPlain_of_forall_param :: forall m. f m -> x -> CellPlain
 183 -- instance Cell_of_forall_param f x => CellOf (f m) x where
 184 --      cellOf = cellPlain_of_forall_param
 185 instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
 186         cellPlain_of_forall_param ctx = maybe cellPlain (cellPlain_of_forall_param ctx)
 187 -}