ledger/Hcompta/Format/Ledger/Amount/Read.hs

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