]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Amount/Read.hs
Correction : compatiblité avec GHC-7.6 en limitant l’usage de Prelude.
[comptalang.git] / lib / Hcompta / Amount / Read.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 module Hcompta.Amount.Read where
4
5 import Control.Applicative ((<$>), (<*))
6 import Control.Applicative ((<|>))
7 import Control.Monad (Monad(..), guard)
8 import Data.Bool
9 import Data.Char
10 import qualified Data.Decimal
11 import Data.Eq (Eq(..))
12 import Data.List
13 import Data.Maybe (Maybe(..))
14 import Data.Ord (Ord(..))
15 import Data.String (String, fromString)
16 import Data.Typeable ()
17 import Prelude (($), Int, fromIntegral, Num(..), id)
18 import qualified Text.Parsec as R hiding
19 ( char
20 , noneOf
21 , oneOf
22 , satisfy
23 )
24 import Text.Parsec (Stream, ParsecT, (<?>))
25
26 import qualified Hcompta.Amount as Amount
27 import Hcompta.Amount (Amount, Unit)
28 import qualified Hcompta.Amount.Style as Style
29 import qualified Hcompta.Amount.Unit as Unit
30 import qualified Hcompta.Lib.Parsec as R
31
32 -- * Read 'Quantity'
33 data Quantity
34 = Quantity
35 { integral :: [String]
36 , fractional :: [String]
37 , fractioning :: Maybe Style.Fractioning
38 , grouping_integral :: Maybe Style.Grouping
39 , grouping_fractional :: Maybe Style.Grouping
40 }
41
42 quantity
43 :: Stream s m Char
44 => Char -- ^ Integral grouping separator.
45 -> Char -- ^ Fractioning separator.
46 -> Char -- ^ Fractional grouping separator.
47 -> ParsecT s u m Quantity
48 quantity int_group_sep frac_sep frac_group_sep = do
49 (integral, grouping_integral) <- do
50 h <- R.many R.digit
51 case h of
52 [] -> return ([], Nothing)
53 _ -> do
54 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
55 let digits = h:t
56 return (digits, grouping_of_digits int_group_sep digits)
57 (fractional, fractioning, grouping_fractional) <-
58 (case integral of
59 [] -> id
60 _ -> R.option ([], Nothing, Nothing)) $ do
61 fractioning <- R.char frac_sep
62 h <- R.many R.digit
63 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
64 let digits = h:t
65 return (digits, Just fractioning
66 , grouping_of_digits frac_group_sep $ reverse digits)
67 return $
68 Quantity
69 { integral
70 , fractional
71 , fractioning
72 , grouping_integral
73 , grouping_fractional
74 }
75 where
76 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
77 grouping_of_digits group_sep digits =
78 case digits of
79 [] -> Nothing
80 [_] -> Nothing
81 _ -> Just $
82 Style.Grouping group_sep $
83 canonicalize_grouping $
84 map length $ digits
85 canonicalize_grouping :: [Int] -> [Int]
86 canonicalize_grouping groups =
87 foldl' -- NOTE: remove duplicates at beginning and reverse.
88 (\acc l0 -> case acc of
89 l1:_ -> if l0 == l1 then acc else l0:acc
90 _ -> l0:acc) [] $
91 case groups of -- NOTE: keep only longer at beginning.
92 l0:l1:t -> if l0 > l1 then groups else l1:t
93 _ -> groups
94
95 -- * Read 'Unit'
96 unit :: Stream s m Char => ParsecT s u m Unit
97 unit =
98 (quoted <|> unquoted) <?> "unit"
99 where
100 unquoted :: Stream s m Char => ParsecT s u m Unit
101 unquoted =
102 fromString <$> do
103 R.many1 $
104 R.satisfy $ \c ->
105 case Data.Char.generalCategory c of
106 Data.Char.CurrencySymbol -> True
107 Data.Char.LowercaseLetter -> True
108 Data.Char.ModifierLetter -> True
109 Data.Char.OtherLetter -> True
110 Data.Char.TitlecaseLetter -> True
111 Data.Char.UppercaseLetter -> True
112 _ -> False
113 quoted :: Stream s m Char => ParsecT s u m Unit
114 quoted =
115 fromString <$> do
116 R.between (R.char '"') (R.char '"') $
117 R.many1 $
118 R.noneOf ";\n\""
119
120 -- * Read 'Amount'
121 amount :: Stream s m Char => ParsecT s u m Amount
122 amount = do
123 left_signing <- sign
124 left_unit <-
125 R.option Nothing $ do
126 u <- unit
127 s <- R.many $ R.space_horizontal
128 return $ Just $ (u, not $ null s)
129 (quantity_, style) <- do
130 signing <- sign
131 Quantity
132 { integral
133 , fractional
134 , fractioning
135 , grouping_integral
136 , grouping_fractional
137 } <-
138 R.choice_try
139 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
140 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
141 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
142 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
143 ] <?> "quantity"
144 let int = Data.List.concat integral
145 let frac_flat = Data.List.concat fractional
146 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
147 let place = length frac
148 guard (place <= 255)
149 let mantissa = R.integer_of_digits 10 $ int ++ frac
150 return $
151 ( Data.Decimal.Decimal
152 (fromIntegral place)
153 (signing mantissa)
154 , Style.nil
155 { Style.fractioning
156 , Style.grouping_integral
157 , Style.grouping_fractional
158 , Style.precision = fromIntegral $ length frac_flat
159 }
160 )
161 (unit_, unit_side, unit_spaced) <-
162 case left_unit of
163 Just (u, s) ->
164 return (u, Just Style.Side_Left, Just s)
165 Nothing ->
166 R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
167 s <- R.many $ R.space_horizontal
168 u <- unit
169 return $ (u, Just Style.Side_Right, Just $ not $ null s)
170 return $
171 Amount.Amount
172 { Amount.quantity = left_signing $ quantity_
173 , Amount.style = style
174 { Style.unit_side
175 , Style.unit_spaced
176 }
177 , Amount.unit = unit_
178 }
179
180 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
181 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
182 sign =
183 (R.char '-' >> return negate)
184 <|> (R.char '+' >> return id)
185 <|> return id