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