lib/Hcompta/Amount/Write.hs

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