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