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