lib/Hcompta/Amount/Read.hs

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