jcc/Hcompta/Format/JCC/Amount/Read.hs

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