]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Amount/Write.hs
Polissage : hlint.
[comptalang.git] / 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 null 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