]> Git — Sourcephile - comptalang.git/blob - jcc/Hcompta/Format/JCC/Amount/Write.hs
Ajout : Hcompta.Format.JCC.
[comptalang.git] / jcc / Hcompta / Format / JCC / Amount / Write.hs
1 {-# LANGUAGE MagicHash #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Hcompta.Format.JCC.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.JCC.Amount (Amount(..))
22 import qualified Hcompta.Format.JCC.Amount as JCC.Amount
23 import qualified Hcompta.Format.JCC.Amount.Style as Amount.Style
24 import Hcompta.Format.JCC.Quantity (Quantity)
25 import qualified Hcompta.Format.JCC.Quantity as JCC.Quantity
26 import qualified Hcompta.Format.JCC.Unit as JCC.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 :: JCC.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 JCC.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 :: JCC.Unit.Unit -> Doc
70 unit = W.yellow . W.strict_text . Unit.unit_text
71
72 -- * Write 'Quantity'
73 quantity :: JCC.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 :: JCC.Amount.Style -> JCC.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