lib/Hcompta/Filter/Amount/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.Filter.Amount.Read where
   8 import           Control.Applicative ((<$>), (<*))
   9 import           Control.Monad (Monad(..), guard, void)
  10 import           Data.Bool
  11 import           Data.Char
  12 import           Data.Decimal (DecimalRaw(..))
  13 import qualified Data.List as List
  14 import           Data.Maybe (Maybe(..))
  15 import           Data.Monoid (Monoid(..))
  16 import           Data.Ord (Ord(..))
  17 import           Data.String (String)
  18 import qualified Data.Text as Text
  19 import           Data.Typeable ()
  20 import           Prelude (($), (.), fromIntegral, Num(..), id)
  21 import qualified Text.Parsec as R hiding
  22                   ( char
  23                   , anyChar
  24                   , crlf
  25                   , newline
  26                   , noneOf
  27                   , oneOf
  28                   , satisfy
  29                   , space
  30                   , spaces
  31                   , string
  32                   )
  33 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  34
  35 import           Hcompta.Filter.Amount
  36 import qualified Hcompta.Lib.Parsec as R
  37 import qualified Hcompta.Unit as Unit
  38
  39 -- * Read 'Amount'
  40
  41 quantity :: Stream s m Char => ParsecT s u m Quantity
  42 quantity = do
  43         signing <- sign
  44         (integral, fractional) <-
  45                 R.choice_try
  46                  [ try_quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
  47                  , try_quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
  48                  , try_quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
  49                  , try_quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
  50                  ] <?> "quantity"
  51         let int       = List.concat integral
  52         let frac      = List.concat fractional
  53         let precision = List.length frac
  54         guard (precision <= 255)
  55         let mantissa = R.integer_of_digits 10 $ int `mappend` frac
  56         return $
  57                 Decimal
  58                  (fromIntegral precision)
  59                  (signing mantissa)
  60         where
  61                 try_quantity int_group_sep frac_sep frac_group_sep = do
  62                         integral <- do
  63                                 h <- R.many R.digit
  64                                 case h of
  65                                  [] -> return []
  66                                  _ -> do
  67                                         t <- R.many $ R.char int_group_sep >> R.many1 R.digit
  68                                         return (h:t)
  69                         fractional <-
  70                                 (case integral of
  71                                  [] -> id
  72                                  _ -> R.option []) $ do
  73                                         void $ R.char frac_sep
  74                                         h <- R.many R.digit
  75                                         t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
  76                                         return (h:t)
  77                         return ((integral::[String]), (fractional::[String]))
  78
  79 unit :: Stream s m Char => ParsecT s u m Unit
  80 unit =
  81         (quoted <|> unquoted) <?> "unit"
  82         where
  83                 unquoted :: Stream s m Char => ParsecT s u m Unit
  84                 unquoted =
  85                         Unit . Text.pack <$> do
  86                         R.many1 $
  87                                 R.satisfy $ \c ->
  88                                         case Data.Char.generalCategory c of
  89                                          Data.Char.CurrencySymbol  -> True
  90                                          Data.Char.LowercaseLetter -> True
  91                                          Data.Char.ModifierLetter  -> True
  92                                          Data.Char.OtherLetter     -> True
  93                                          Data.Char.TitlecaseLetter -> True
  94                                          Data.Char.UppercaseLetter -> True
  95                                          _ -> False
  96                 quoted :: Stream s m Char => ParsecT s u m Unit
  97                 quoted =
  98                         Unit . Text.pack <$> do
  99                         R.between (R.char '"') (R.char '"') $
 100                                 R.many1 $
 101                                         R.noneOf ";\n\""
 102
 103 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
 104 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
 105 sign =
 106             (R.char '-' >> return negate)
 107         <|> (R.char '+' >> return id)
 108         <|> return id
 109
 110 amount :: Stream s m Char => ParsecT s u m Amount
 111 amount = do
 112         left_signing <- sign
 113         left_unit <-
 114                 R.option Nothing $ do
 115                         u <- unit
 116                         R.skipMany R.space_horizontal
 117                         return $ Just u
 118         quantity_ <- quantity
 119         unit_ <-
 120                 case left_unit of
 121                  Just u -> return u
 122                  Nothing ->
 123                         R.option (Unit.unit_empty) $ R.try $ do
 124                                 R.skipMany R.space_horizontal
 125                                 unit
 126         return $
 127                 Amount
 128                  { amount_quantity = left_signing quantity_
 129                  , amount_unit = unit_
 130                  }