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, toInteger)
  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 import qualified Language.Symantic.Document.Term.Dimension as Dim
  22
  23 -- * Type 'Table'
  24 type Table d = [Column d]
  25
  26 instance (D.Textable d, D.Colorable d, D.Indentable d) => Writeable d (Table d) where
  27         write cols' =
  28                 let cols        = refreshWidthCol <$> cols' in
  29                 let rows        = L.transpose $ column_rows <$> cols in
  30                 let has_title   = any (not . T.null . column_title) cols in
  31                 let titles :: d = D.catH $ L.intersperse (d_sep '|') $ d_title <$> cols in
  32                 D.catV (
  33                         (if has_title then (:) titles else id) $
  34                         (<$> rows) $ \row ->
  35                                 D.catH $
  36                                 L.intersperse (D.space <> d_sep '|') $
  37                                 ((D.space <>) <$>) $
  38                                 zipWith (curry $ alignCell Nothing) cols row
  39                  ) <>
  40                 (case cols of { [] -> D.empty; _ -> D.newline })
  41                 where
  42                 refreshWidthCol col@Column{column_width=w} =
  43                         if w == 0
  44                         then col{column_width = widthCol col}
  45                         else col
  46                         where
  47                         widthCol :: Column d -> Int
  48                         widthCol Column
  49                          { column_title
  50                          , column_rows } =
  51                                 max (T.length column_title) $
  52                                 foldr (max . cell_width) 0 column_rows
  53                 d_title :: Column d -> d
  54                 d_title col@Column{column_title} = do
  55                         let pad len = D.blacker $ D.text $ T.pack $ L.replicate len '_'
  56                         alignCell (Just pad) (col, Cell
  57                          { cell_width   = T.length column_title
  58                          , cell_content = d_under <> d_underline column_title <> d_under
  59                          , cell_align   = Just AlignC
  60                          })
  61                 d_sep = D.blacker . D.charH
  62                 d_under = d_sep '_'
  63                 d_underline t =
  64                         D.catH $ (<$> T.unpack t) $ \case
  65                          ' ' -> d_under
  66                          c -> D.charH c
  67
  68                 alignCell ::
  69                  D.Textable d =>
  70                  D.Colorable d => D.Indentable d =>
  71                  Maybe (Int -> d) ->
  72                  (Column d, Cell d) -> d
  73                 alignCell may_padding
  74                  ( Column{column_align, column_width}
  75                  , Cell{cell_width, cell_content, cell_align} ) =
  76                         let pad = column_width - cell_width in
  77                         case column_align `fromMaybe` cell_align of
  78                          AlignL -> cell_content <> padding pad
  79                          AlignC -> padding half <> cell_content <> padding (pad - half)
  80                                 where half = fromInteger $ quot (toInteger pad) 2
  81                          AlignR -> padding pad <> cell_content
  82                         where padding = (D.spaces . D.Nat . toInteger) `fromMaybe` may_padding
  83                 alignCell _filling
  84                  ( Column{column_width}
  85                  , Cell_Line{cell_pad} ) =
  86                         D.blacker $ D.ltextH $
  87                         TL.replicate (fromIntegral column_width) $
  88                         TL.singleton cell_pad
  89
  90 -- ** Class 'TableOf'
  91 class TableOf a d where
  92         tableOf :: a -> Table d
  93
  94 -- * Type 'Column'
  95 data Column d
  96  =   Column
  97  {   column_title :: Text
  98  ,   column_align :: Align
  99  ,   column_width :: Int
 100  ,   column_rows  :: [Cell d]
 101  } deriving (Eq, Show)
 102
 103 column :: Text -> Align -> [Cell d] -> Column d
 104 column t a r =
 105         Column
 106          { column_title = t
 107          , column_align = a
 108          , column_width = 0
 109          , column_rows  = r
 110          }
 111
 112 -- ** Type 'Align'
 113 data Align
 114  =   AlignL
 115  |   AlignC
 116  |   AlignR
 117  deriving (Eq, Show)
 118
 119 -- ** Class 'columnOf'
 120 class ColumnOf a d where
 121         columnOf :: a -> Column d
 122
 123 -- * Type 'Cell'
 124 data Cell d
 125  =   Cell      { cell_align   :: Maybe Align
 126                     , cell_width   :: Int
 127                     , cell_content :: d
 128                     }
 129  |   Cell_Line { cell_pad     :: Char
 130                     , cell_width   :: Int
 131                     }
 132  deriving (Eq, Show)
 133
 134 -- ** Class 'CellOf'
 135 class CellOf a d where
 136         cellOf :: a -> Cell d
 137         default cellOf ::
 138          Writeable Dim.Dimension a =>
 139          Writeable d a =>
 140          a -> Cell d
 141         cellOf = cell
 142
 143 instance D.Textable d => CellOf () d where
 144         cellOf () = Cell
 145          { cell_width   = 0
 146          , cell_align   = Nothing
 147          , cell_content = D.empty
 148          }
 149
 150 cell ::
 151  Writeable Dim.Dimension a =>
 152  Writeable d a =>
 153  a -> Cell d
 154 cell a =
 155         Cell
 156          { cell_width   = fromIntegral $ D.unNat $ Dim.dim_width $ Dim.dim $ write a
 157          , cell_align   = Nothing
 158          , cell_content = write a
 159          }
 160
 161
 162
 163
 164
 165
 166 {-
 167 instance ToDoc Column Cell where
 168         toDoc = alignCell Nothing
 169
 170 -- ** Class 'CellOf'
 171 class CellOf context x where
 172         cellOf :: context -> x -> Cell
 173
 174 instance CellOf context x => CellOf context (Maybe x) where
 175         cellOf ctx = maybe cell (cellOf ctx)
 176
 177 -- ** Class 'Cell_of_forall_param'
 178
 179 -- | A class useful when using a context of kind '*' is not wanted
 180 --   for example in a class instance constraint
 181 --   to keep the instance decidable (i.e. avoid UndecidableInstances).
 182 class Cell_of_forall_param f x where
 183         cell_of_forall_param :: forall m. f m -> x -> Cell
 184 -- instance Cell_of_forall_param f x => CellOf (f m) x where
 185 --      cellOf = cell_of_forall_param
 186 instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
 187         cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)
 188 -}