ledger/Hcompta/Format/Ledger/Amount/Write.hs

   1 {-# LANGUAGE MagicHash #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Hcompta.Format.Ledger.Amount.Write where
   5
   6 import           Data.Bool
   7 import           Data.Char (Char)
   8 import           Data.Decimal (DecimalRaw(..))
   9 import           Data.Eq (Eq(..))
  10 import qualified Data.List as List
  11 import           Data.Maybe (Maybe(..), fromMaybe, maybe)
  12 import           Data.Ord (Ord(..))
  13 import qualified Data.Text as Text
  14 import qualified Data.Text.Lazy as TL
  15 import           Data.Tuple (fst)
  16 import           GHC.Exts (Int(..))
  17 import           GHC.Integer.Logarithms (integerLogBase#)
  18 import           Prelude (($), (.), Num(..), Show(..), flip, fromIntegral, id)
  19
  20 import qualified Hcompta.Amount as Amount
  21 import           Hcompta.Format.Ledger.Amount (Amount(..))
  22 import qualified Hcompta.Format.Ledger.Amount as Ledger.Amount
  23 import qualified Hcompta.Format.Ledger.Amount.Style as Amount.Style
  24 import           Hcompta.Format.Ledger.Quantity (Quantity)
  25 import qualified Hcompta.Format.Ledger.Quantity as Ledger.Quantity
  26 import qualified Hcompta.Format.Ledger.Unit as Ledger.Unit
  27 import           Hcompta.Lib.Leijen (Doc, (<>))
  28 import qualified Hcompta.Lib.Leijen as W
  29 import qualified Hcompta.Unit as Unit
  30
  31 -- * Write 'Amount'
  32 amount :: Amount.Style.Styled Amount -> Doc
  33 amount
  34  ( sty@(Amount.Style.Style
  35          { Amount.Style.unit_side
  36          , Amount.Style.unit_spaced
  37          })
  38  , amt ) =
  39         let unt = Amount.amount_unit amt in
  40         case unit_side of
  41          Just Amount.Style.Side_Left ->
  42                 unit unt <>
  43                 case unit_spaced of
  44                  Just True | unt /= Unit.unit_empty -> W.space
  45                  _ -> W.empty
  46          _ -> W.empty
  47         <> quantity (sty, Amount.amount_quantity amt)
  48         <> case unit_side of
  49          (Just Amount.Style.Side_Right) ->
  50                 (case unit_spaced of
  51                  Just True | unt /= Unit.unit_empty -> W.space
  52                  _ -> W.empty) <>
  53                 unit unt
  54          Nothing ->
  55                 (case unit_spaced of
  56                  Just True | unt /= Unit.unit_empty -> W.space
  57                  _ -> W.empty) <>
  58                 unit unt
  59          _ -> W.empty
  60
  61 amount_length :: Ledger.Amount.Styled Amount -> Int
  62 amount_length (sty@(Amount.Style.Style { Amount.Style.unit_spaced }), amt) =
  63         let unt = Amount.amount_unit amt in
  64         Ledger.Unit.unit_length unt
  65         + (case unit_spaced of { Just True | unt /= Unit.unit_empty -> 1; _ -> 0 })
  66         + quantity_length sty (Amount.amount_quantity amt)
  67
  68 -- * Write 'Unit'
  69 unit :: Ledger.Unit.Unit -> Doc
  70 unit = W.yellow . W.strict_text . Unit.unit_text
  71
  72 -- * Write 'Quantity'
  73 quantity :: Ledger.Amount.Styled Quantity -> Doc
  74 quantity
  75  ( Amount.Style.Style
  76          { Amount.Style.fractioning
  77          , Amount.Style.grouping_integral
  78          , Amount.Style.grouping_fractional
  79          }
  80  , qty ) = do
  81         let Decimal e n = qty
  82         let num = show $ abs $ n
  83         let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
  84         case e == 0 of
  85          True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
  86          False -> do
  87                 let num_len = List.length num
  88                 let padded =
  89                         List.concat
  90                          [ List.replicate (fromIntegral e + 1 - num_len) '0'
  91                          , num
  92                          -- , replicate (fromIntegral precision - fromIntegral e) '0'
  93                          ]
  94                 let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
  95                 let default_fractioning =
  96                         List.head $
  97                         del_grouping_sep grouping_integral $
  98                         del_grouping_sep grouping_fractional $
  99                         ['.', ',']
 100                 sign <> do
 101                 W.bold $ W.blue $ do
 102                         W.text (TL.pack $ maybe id
 103                          (\g -> List.reverse . group g . List.reverse)
 104                          grouping_integral $ int) <> do
 105                         (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
 106                         W.text (TL.pack $ maybe id group grouping_fractional frac)
 107         where
 108                 group :: Amount.Style.Grouping -> [Char] -> [Char]
 109                 group (Amount.Style.Grouping sep sizes_) =
 110                         List.concat . List.reverse .
 111                         List.map List.reverse . fst .
 112                         List.foldl'
 113                          (flip (\digit x -> case x of
 114                                  ([], sizes) -> ([[digit]], sizes)
 115                                  (digits:groups, []) -> ((digit:digits):groups, [])
 116                                  (digits:groups, curr_sizes@(size:sizes)) ->
 117                                         if List.length digits < size
 118                                         then (      (digit:digits):groups, curr_sizes)
 119                                         else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
 120                          ))
 121                          ([], sizes_)
 122                 del_grouping_sep grouping =
 123                         case grouping of
 124                          Just (Amount.Style.Grouping sep _) -> List.delete sep
 125                          _ -> id
 126
 127 quantity_length :: Ledger.Amount.Style -> Ledger.Quantity.Quantity -> Int
 128 quantity_length Amount.Style.Style
 129  { Amount.Style.grouping_integral
 130  , Amount.Style.grouping_fractional
 131  } qty =
 132         let Decimal e n     = qty in
 133         let sign_len        = if n < 0 then 1 else 0 in
 134         let fractioning_len = if e > 0 then 1 else 0 in
 135         let num_len         = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
 136         let pad_left_len    = max 0 (fromIntegral e + 1 - num_len) in
 137         -- let pad_right_len   = max 0 (fromIntegral precision - fromIntegral e) in
 138         let padded_len      = pad_left_len + num_len {-+ pad_right_len-} in
 139         let int_len         = max 1 (num_len - fromIntegral e) in
 140         let frac_len        = max 0 (padded_len - int_len) in
 141         ( sign_len
 142         + fractioning_len
 143         + padded_len
 144         + maybe 0 (group int_len)  grouping_integral
 145         + maybe 0 (group frac_len) grouping_fractional
 146         )
 147         where
 148                 group :: Int -> Amount.Style.Grouping -> Int
 149                 group num_len (Amount.Style.Grouping _sep sizes_) =
 150                         if num_len <= 0
 151                         then 0
 152                         else loop 0 num_len sizes_
 153                         where
 154                                 loop :: Int -> Int -> [Int] -> Int
 155                                 loop pad len =
 156                                         \x -> case x of
 157                                          [] -> 0
 158                                          sizes@[size] ->
 159                                                 let l = len - size in
 160                                                 if l <= 0 then pad
 161                                                 else loop (pad + 1) l sizes
 162                                          size:sizes ->
 163                                                 let l = len - size in
 164                                                 if l <= 0 then pad
 165                                                 else loop (pad + 1) l sizes