]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Amount/Write.hs
Correction : compatiblité avec GHC-7.6 en limitant l’usage de Prelude.
[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 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