Polissage : CLI.Command.Balance : is_worth.
[comptalang.git] / lib / Hcompta / Format / Ledger / Read.hs
index 2d0ccd7f050031c14db1c894033df835299363ce..ad9a9571d2cba0c86cdc1612822c2127ccebc191 100644 (file)
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
 module Hcompta.Format.Ledger.Read where
 
-import           Control.Applicative ((<$>), (<*>), (<*))
+-- import           Control.Applicative ((<$>), (<*>), (<*))
 import qualified Control.Exception as Exception
-import           Control.Arrow ((***))
-import           Control.Monad (guard, join, liftM, (>=>))
+import           Control.Arrow ((***), first)
+import           Control.Monad (guard, join, liftM, forM, void)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
 import qualified Data.Char
-import qualified Data.Decimal
 import qualified Data.Either
 import qualified Data.List
+import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Map.Strict as Data.Map
 import           Data.Maybe (fromMaybe)
+import           Data.String (fromString)
 import qualified Data.Time.Calendar  as Time
 import qualified Data.Time.Clock     as Time
 import qualified Data.Time.LocalTime as Time
-import           Data.Time.LocalTime (TimeZone(..))
 import           Data.Typeable ()
-import qualified Text.Parsec as R
+import qualified Text.Parsec as R hiding
+                  ( char
+                  , anyChar
+                  , crlf
+                  , newline
+                  , noneOf
+                  , oneOf
+                  , satisfy
+                  , space
+                  , spaces
+                  , string
+                  , tab
+                  )
 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+import qualified Text.Parsec.Pos as R
 import qualified Data.Text.IO as Text.IO (readFile)
-import qualified Data.Text as Text (pack)
+import qualified Data.Text as Text
 import qualified System.FilePath.Posix as Path
 
-import qualified Hcompta.Model.Account as Account
-import           Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import           Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Amount.Style as Style
-import qualified Hcompta.Model.Amount.Unit as Unit
-import           Hcompta.Model.Amount.Unit (Unit)
-import qualified Hcompta.Model.Transaction as Transaction
-import           Hcompta.Model.Transaction (Transaction, Comment)
-import qualified Hcompta.Model.Transaction.Posting as Posting
-import           Hcompta.Model.Transaction (Posting)
-import qualified Hcompta.Model.Transaction.Tag as Tag
-import           Hcompta.Model.Transaction (Tag)
-import qualified Hcompta.Model.Date as Date
-import           Hcompta.Model.Date (Date)
-import           Hcompta.Format.Ledger.Journal as Journal
+import qualified Hcompta.Balance as Balance
+import qualified Hcompta.Account as Account
+import           Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Style as Style
+import qualified Hcompta.Amount.Read as Amount.Read
+import qualified Hcompta.Amount.Unit as Unit
+import qualified Hcompta.Date as Date
+import           Hcompta.Date (Date)
+import qualified Hcompta.Date.Read as Date.Read
+import qualified Hcompta.Format.Ledger as Ledger
+import           Hcompta.Format.Ledger
+                  ( Comment
+                  , Journal(..)
+                  , Posting(..), Posting_Type(..)
+                  , Tag, Tag_Name, Tag_Value, Tag_by_Name
+                  , Transaction(..)
+                  )
+import           Hcompta.Lib.Consable (Consable(..))
 import qualified Hcompta.Lib.Regex as Regex
 import           Hcompta.Lib.Regex (Regex)
-import           Hcompta.Lib.Parsec as R
+import qualified Hcompta.Lib.Parsec as R
 import qualified Hcompta.Lib.Path as Path
 
-data Context
+data Context f ts t
  =   Context
- { context_account_prefix :: !Account
+ { context_account_prefix :: !(Maybe Account)
  , context_aliases_exact :: !(Data.Map.Map Account Account)
  , context_aliases_joker :: ![(Account.Joker, Account)]
  , context_aliases_regex :: ![(Regex, Account)]
  , context_date :: !Date
+ , context_filter :: !f
+ , context_journal :: !(Journal (ts t))
  , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
- , context_journal :: !Journal
  , context_year :: !Date.Year
  } deriving (Show)
 
-nil_Context :: Context
-nil_Context =
+context
+ :: (Show f, Consable f ts t)
+ => f -> Journal (ts t) -> Context f ts t
+context flt context_journal =
        Context
-        { context_account_prefix = []
+        { context_account_prefix = Nothing
         , context_aliases_exact = Data.Map.empty
         , context_aliases_joker = []
         , context_aliases_regex = []
         , context_date = Date.nil
+        , context_filter = flt
+        , context_journal
         , context_unit_and_style = Nothing
-        , context_journal = Journal.nil
-        , context_year = (\(year, _ , _) -> year) $
-               Time.toGregorian $ Time.utctDay $
-               Journal.last_read_time Journal.nil
+        , context_year = Date.year Date.nil
         }
 
--- | Parse either '-' into 'negate', or '+' or '' into 'id'.
-sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
-sign =
-           (R.char '-' >> return negate)
-       <|> (R.char '+' >> return id)
-       <|> return id
+data Error
+ =   Error_date Date.Read.Error
+ |   Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ |   Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ |   Error_reading_file FilePath Exception.IOException
+ |   Error_including_file FilePath [R.Error Error]
+ deriving (Show)
 
--- * Parsing 'Account'
+-- * Read 'Account'
 
 account_name_sep :: Char
 account_name_sep = ':'
 
--- | Parse an 'Account'.
+-- | Read an 'Account'.
 account :: Stream s m Char => ParsecT s u m Account
 account = do
-       R.notFollowedBy $ space_horizontal
-       many1_separated account_name $ R.char account_name_sep
+       R.notFollowedBy $ R.space_horizontal
+       Account.from_List <$> do
+       R.many1_separated account_name $ R.char account_name_sep
 
--- | Parse an Account.'Account.Name'.
+-- | Read an Account.'Account.Name'.
 account_name :: Stream s m Char => ParsecT s u m Account.Name
 account_name = do
-       Text.pack <$> do
+       fromString <$> do
        R.many1 $ R.try account_name_char
        where
                account_name_char :: Stream s m Char => ParsecT s u m Char
@@ -108,11 +127,8 @@ account_name = do
                        case c of
                         _ | c == comment_begin -> R.parserZero
                         _ | c == account_name_sep -> R.parserZero
-                        _ | c == posting_type_virtual_end
-                         || c == posting_type_virtual_balanced_end ->
-                               return c <* (R.lookAhead $ R.try $ account_name_char)
-                        _ | is_space_horizontal c -> do
-                               _ <- R.notFollowedBy $ space_horizontal
+                        _ | c /= '\t' && R.is_space_horizontal c -> do
+                               _ <- R.notFollowedBy $ R.space_horizontal
                                return c <* (R.lookAhead $ R.try $
                                 ( R.try (R.char account_name_sep)
                                 <|> account_name_char
@@ -120,7 +136,7 @@ account_name = do
                         _ | not (Data.Char.isSpace c) -> return c
                         _ -> R.parserZero
 
--- | Parse an Account.'Account.Joker_Name'.
+-- | Read an Account.'Account.Joker_Name'.
 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
 account_joker_name = do
        n <- R.option Nothing $ (Just <$> account_name)
@@ -128,19 +144,19 @@ account_joker_name = do
         Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
         Just n' -> return $ Account.Joker_Name n'
 
--- | Parse an Account.'Account.Joker'.
+-- | Read an Account.'Account.Joker'.
 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
 account_joker = do
-       R.notFollowedBy $ space_horizontal
-       many1_separated account_joker_name $ R.char account_name_sep
+       R.notFollowedBy $ R.space_horizontal
+       R.many1_separated account_joker_name $ R.char account_name_sep
 
--- | Parse a 'Regex'.
+-- | Read a 'Regex'.
 account_regex :: Stream s m Char => ParsecT s u m Regex
 account_regex = do
-       re <- R.many1 $ R.satisfy (not . is_space_horizontal)
+       re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
        Regex.of_StringM re
 
--- | Parse an Account.'Account.Filter'.
+-- | Read an Account.'Account.Filter'.
 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
 account_pattern = do
        R.choice_try
@@ -149,168 +165,20 @@ account_pattern = do
         , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
         ]
 
--- * Parsing 'Amount'
-
--- | Parse an 'Amount'.
-amount :: Stream s m Char => ParsecT s u m Amount
-amount = do
-       left_signing <- sign
-       left_unit <-
-               R.option Nothing $ do
-                       u <- unit
-                       s <- R.many $ space_horizontal
-                       return $ Just $ (u, not $ null s)
-       (quantity_, style) <- do
-               signing <- sign
-               Quantity
-                { integral
-                , fractional
-                , fractioning
-                , grouping_integral
-                , grouping_fractional
-                } <-
-                       R.choice_try
-                        [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
-                        , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
-                        , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
-                        , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
-                        ] <?> "quantity"
-               let int = Data.List.concat integral
-               let frac_flat = Data.List.concat fractional
-               let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
-               let place = length frac
-               guard (place <= 255)
-               let mantissa = R.integer_of_digits 10 $ int ++ frac
-               return $
-                ( Data.Decimal.Decimal
-                        (fromIntegral place)
-                        (signing mantissa)
-                , Style.nil
-                        { Style.fractioning
-                        , Style.grouping_integral
-                        , Style.grouping_fractional
-                        , Style.precision = fromIntegral $ length frac_flat
-                        }
-                )
-       (unit_, unit_side, unit_spaced) <-
-               case left_unit of
-                Just (u, s) ->
-                       return (u, Just Style.Side_Left, Just s)
-                Nothing ->
-                       R.option (Unit.nil, Nothing, Nothing) $ do
-                               s <- R.many $ space_horizontal
-                               u <- unit
-                               return $ (u, Just Style.Side_Right, Just $ not $ null s)
-       return $
-               Amount.Amount
-                { Amount.quantity = left_signing $ quantity_
-                , Amount.style = style
-                        { Style.unit_side
-                        , Style.unit_spaced
-                        }
-                , Amount.unit = unit_
-                }
-
-data Quantity
- =   Quantity
- { integral :: [String]
- , fractional :: [String]
- , fractioning :: Maybe Style.Fractioning
- , grouping_integral :: Maybe Style.Grouping
- , grouping_fractional :: Maybe Style.Grouping
- }
-
--- | Parse a 'Quantity'.
-quantity
- :: Stream s m Char
- => Char -- ^ Integral grouping separator.
- -> Char -- ^ Fractioning separator.
- -> Char -- ^ Fractional grouping separator.
- -> ParsecT s u m Quantity
-quantity int_group_sep frac_sep frac_group_sep = do
-       (integral, grouping_integral) <- do
-               h <- R.many R.digit
-               case h of
-                [] -> return ([], Nothing)
-                _ -> do
-                       t <- R.many $ R.char int_group_sep >> R.many1 R.digit
-                       let digits = h:t
-                       return (digits, grouping_of_digits int_group_sep digits)
-       (fractional, fractioning, grouping_fractional) <-
-               (case integral of
-                [] -> id
-                _ -> R.option ([], Nothing, Nothing)) $ do
-                       fractioning <- R.char frac_sep
-                       h <- R.many R.digit
-                       t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
-                       let digits = h:t
-                       return (digits, Just fractioning
-                        , grouping_of_digits frac_group_sep $ reverse digits)
-       return $
-               Quantity
-                { integral
-                , fractional
-                , fractioning
-                , grouping_integral
-                , grouping_fractional
-                }
-       where
-               grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
-               grouping_of_digits group_sep digits =
-                       case digits of
-                        [] -> Nothing
-                        [_] -> Nothing
-                        _ -> Just $
-                               Style.Grouping group_sep $
-                               canonicalize_grouping $
-                               map length $ digits
-               canonicalize_grouping :: [Int] -> [Int]
-               canonicalize_grouping groups =
-                       Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
-                        (\acc l0 -> case acc of
-                                l1:_ -> if l0 == l1 then acc else l0:acc
-                                _ -> l0:acc) [] $
-                       case groups of -- NOTE: keep only longer at beginning.
-                        l0:l1:t -> if l0 > l1 then groups else l1:t
-                        _ -> groups
-
--- | Parse an 'Unit'.
-unit :: Stream s m Char => ParsecT s u m Unit
-unit =
-       (quoted <|> unquoted) <?> "unit"
-       where
-               unquoted :: Stream s m Char => ParsecT s u m Unit
-               unquoted =
-                       Text.pack <$> do
-                       R.many1 $
-                               R.satisfy $ \c ->
-                                       case Data.Char.generalCategory c of
-                                        Data.Char.CurrencySymbol  -> True
-                                        Data.Char.LowercaseLetter -> True
-                                        Data.Char.ModifierLetter  -> True
-                                        Data.Char.OtherLetter     -> True
-                                        Data.Char.TitlecaseLetter -> True
-                                        Data.Char.UppercaseLetter -> True
-                                        _ -> False
-               quoted :: Stream s m Char => ParsecT s u m Unit
-               quoted =
-                       Text.pack <$> do
-                       R.between (R.char '"') (R.char '"') $
-                               R.many1 $
-                                       R.noneOf ";\n\""
-
 -- * Directives
 
-directive_alias :: Stream s m Char => ParsecT s Context m ()
+directive_alias
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
 directive_alias = do
        _ <- R.string "alias"
-       R.skipMany1 $ space_horizontal
+       R.skipMany1 $ R.space_horizontal
        pattern <- account_pattern
-       R.skipMany $ space_horizontal
+       R.skipMany $ R.space_horizontal
        _ <- R.char '='
-       R.skipMany $ space_horizontal
+       R.skipMany $ R.space_horizontal
        repl <- account
-       R.skipMany $ space_horizontal
+       R.skipMany $ R.space_horizontal
        case pattern of
         Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
                Data.Map.insert acct repl $ context_aliases_exact ctx}
@@ -320,162 +188,27 @@ directive_alias = do
                (regx, repl):context_aliases_regex ctx}
        return ()
 
--- | Parse the year, month and day separator: '/' or '-'.
-date_separator :: Stream s m Char => ParsecT s u m Char
-date_separator = R.satisfy (\c -> c == '/' || c == '-')
-
--- | Parse the hour, minute and second separator: ':'.
-hour_separator :: Stream s m Char => ParsecT s u m Char
-hour_separator = R.char ':'
-
--- * Parsing 'Date'
-
--- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
-date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
-date def_year = do
-       n0 <- R.many1 R.digit
-       day_sep <- date_separator
-       n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
-       n2 <- R.option Nothing $ R.try $ do
-               _ <- R.char day_sep
-               Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
-       (year, m, d) <-
-               case (n2, def_year) of
-                (Nothing, Nothing) -> fail "year or day is missing"
-                (Nothing, Just year) -> return (year, n0, n1)
-                (Just d, _)  -> return (R.integer_of_digits 10 n0, n1, d)
-       let month = fromInteger $ R.integer_of_digits 10 m
-       let day   = fromInteger $ R.integer_of_digits 10 d
-       guard $ month >= 1 && month <= 12
-       guard $ day   >= 1 && day   <= 31
-       day_ <- case Time.fromGregorianValid year month day of
-        Nothing  -> fail "invalid day"
-        Just day_ -> return day_
-       (hour, minu, sec, tz) <-
-               R.option (0, 0, 0, Time.utc) $ R.try $ do
-                       R.skipMany1 $ space_horizontal
-                       hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
-                       sep <- hour_separator
-                       minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
-                       sec <- R.option Nothing $ R.try $ do
-                               _ <- R.char sep
-                               Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
-                       -- DO: timezone
-                       tz <- R.option Time.utc $ R.try $ do
-                               R.skipMany $ space_horizontal
-                               time_zone
-                       return
-                        ( R.integer_of_digits 10 hour
-                        , R.integer_of_digits 10 minu
-                        , maybe 0 (R.integer_of_digits 10) sec
-                        , tz )
-       guard $ hour >= 0 && hour <= 23
-       guard $ minu >= 0 && minu <= 59
-       guard $ sec  >= 0 && sec  <= 60 -- NOTE: allow leap second
-       tod <- case Time.makeTimeOfDayValid
-        (fromInteger hour)
-        (fromInteger minu)
-        (fromInteger sec) of
-        Nothing  -> fail "invalid time of day"
-        Just tod -> return tod
-       return $
-               Time.ZonedTime
-                (Time.LocalTime day_ tod)
-                tz
-       <?> "date"
-
-time_zone :: Stream s m Char => ParsecT s u m TimeZone
-time_zone =
-       -- DOC: http://www.timeanddate.com/time/zones/
-       -- TODO: only a few time zones are suported below.
-       -- TODO: check the timeZoneSummerOnly values
-       R.choice
-        [ R.char 'A' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
-                , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
-                , return (TimeZone ((-1) * 60) False "A")
-                ]
-        , R.char 'B' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
-                , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
-                ]
-        , R.char 'C' >> R.choice
-                [ R.char 'E' >> R.choice
-                        [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
-                        , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
-                        ]
-                , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
-                , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
-                ]
-        , R.char 'E' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
-                , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
-                ]
-        , R.string "GMT" >> return (TimeZone 0 False "GMT")
-        , R.char 'H' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
-                , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
-                ]
-        , R.char 'M' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
-                , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
-                , return (TimeZone ((-12) * 60) False "M")
-                ]
-        , R.char 'N' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
-                , return (TimeZone (1 * 60) False "N")
-                ]
-        , R.char 'P' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
-                , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
-                ]
-        , R.char 'Y' >> R.choice
-                [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
-                , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
-                , return (TimeZone (12 * 60) False "Y")
-                ]
-        , R.char 'Z' >> return (TimeZone 0 False "Z")
-        , time_zone_digits
-        ]
-
-time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
-{-# INLINEABLE time_zone_digits #-}
-time_zone_digits = do
-       sign_ <- sign
-       hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
-       _ <- R.option ':' (R.char ':')
-       minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
-       let tz = TimeZone
-                { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
-                , timeZoneSummerOnly = False
-                , timeZoneName       = Time.timeZoneOffsetString tz
-                }
-       return tz
-
--- * Parsing 'Comment'
+-- * Read 'Comment'
 
 comment_begin :: Char
 comment_begin = ';'
 
 comment :: Stream s m Char => ParsecT s u m Comment
-comment = do
+comment = (do
        _ <- R.char comment_begin
-       Text.pack <$> do
+       fromString <$> do
        R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
-       <?> "comment"
+       <?> "comment"
 
 comments :: Stream s m Char => ParsecT s u m [Comment]
-comments = do
+comments = (do
        R.try $ do
-               R.skipMany $ R.satisfy Data.Char.isSpace
-               many1_separated comment $
-                       Text.pack <$> do
-                       R.many1 $ do
-                               R.try space_horizontal
-                               <|> (R.new_line >> space_horizontal)
+               _ <- R.spaces
+               R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
        <|> return []
+       ) <?> "comments"
 
--- * Parsing 'Tag'
+-- * Read 'Tag'
 
 tag_value_sep :: Char
 tag_value_sep = ':'
@@ -483,35 +216,35 @@ tag_value_sep = ':'
 tag_sep :: Char
 tag_sep = ','
 
--- | Parse a 'Tag'.
+-- | Read a 'Tag'.
 tag :: Stream s m Char => ParsecT s u m Tag
-tag = do
+tag = (do
        n <- tag_name
        _ <- R.char tag_value_sep
        v <- tag_value
        return (n, v)
-       <?> "tag"
+       <?> "tag"
 
-tag_name :: Stream s m Char => ParsecT s u m Tag.Name
+tag_name :: Stream s m Char => ParsecT s u m Tag_Name
 tag_name = do
-       Text.pack <$> do
+       fromString <$> do
        R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
 
-tag_value :: Stream s m Char => ParsecT s u m Tag.Value
+tag_value :: Stream s m Char => ParsecT s u m Tag_Value
 tag_value = do
-       Text.pack <$> do
+       fromString <$> do
        R.manyTill R.anyChar $ do
                R.lookAhead $ do
-                       R.try (R.char tag_sep >> R.many space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
+                       R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> void (R.char tag_value_sep))
                        <|> R.try R.new_line
                        <|> R.eof
 
-tags :: Stream s m Char => ParsecT s u m Tag.By_Name
+tags :: Stream s m Char => ParsecT s u m Tag_by_Name
 tags = do
-       Tag.from_List <$> do
+       Ledger.tag_by_Name <$> do
                R.many_separated tag $ do
                        _ <- R.char tag_sep
-                       R.skipMany $ space_horizontal
+                       R.skipMany $ R.space_horizontal
                        return ()
 
 not_tag :: Stream s m Char => ParsecT s u m ()
@@ -520,94 +253,140 @@ not_tag = do
                R.skipMany $ R.satisfy
                 (\c -> c /= tag_value_sep
                         && not (Data.Char.isSpace c))
-               space_horizontal
+               R.space_horizontal
 
--- * Parsing 'Posting'
+-- * Read 'Posting'
 
--- | Parse a 'Posting'.
-posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
-posting = do
+posting
+ :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context f ts t) (R.Error_State Error m) (Posting, Posting_Type)
+posting = (do
        ctx <- R.getState
        sourcepos <- R.getPosition
-       comments_ <- comments
-       R.skipMany1 $ space_horizontal
+       R.skipMany1 $ R.space_horizontal
        status_ <- status
-       R.skipMany $ space_horizontal
-       (account_, type_) <- account_with_posting_type
+       R.skipMany $ R.space_horizontal
+       acct <- account
+       let (type_, account_) = posting_type acct
        amounts_ <-
                R.choice_try
                 [ do
-                       _ <- R.count 2 space_horizontal
-                       R.skipMany $ space_horizontal
-                       Amount.from_List <$> do
-                               R.many_separated amount $ R.try $ do
-                                       R.skipMany $ space_horizontal
+                       (void R.tab <|> void (R.count 2 R.space_horizontal))
+                       R.skipMany $ R.space_horizontal
+                       maybe id (\(u, s) ->
+                               if u == Unit.nil then id
+                               else
+                                       Data.Map.adjust (\a ->
+                                               a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
+                                                , Amount.unit  = u })
+                                        Unit.nil)
+                        (context_unit_and_style ctx) .
+                        Amount.from_List <$> do
+                               R.many_separated Amount.Read.amount $ do
+                                       R.skipMany $ R.space_horizontal
                                        _ <- R.char amount_sep
-                                       R.skipMany $ space_horizontal
+                                       R.skipMany $ R.space_horizontal
                                        return ()
                 , return Data.Map.empty
-                ]
-       R.skipMany $ space_horizontal
+                ] <?> "amounts"
+       R.skipMany $ R.space_horizontal
        -- TODO: balance assertion
        -- TODO: conversion
-       comments__ <- (comments_ ++) <$> comments
-       let tags_ = tags_of_comments comments__
+       comments_ <- comments
+       let tags_ = tags_of_comments comments_
        dates_ <-
                case Data.Map.lookup "date" tags_ of
                 Nothing -> return []
                 Just dates -> do
                        let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
-                       dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
-                               R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
-                               >=> \case
-                                Left err -> fail $ show err
-                                Right x -> return x
-                       case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
+                       do
+                       forM (dates ++ fromMaybe [] date2s) $ \s ->
+                               R.runParserT_with_Error_fail "tag date" id
+                                (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
+                                (Text.unpack s) s
+                       >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
                         ([], Just (_:_)) ->
                                return $ context_date ctx:dates_
                         _ -> return $ dates_
-       return (Posting.Posting
-        { Posting.account=account_
-        , Posting.amounts=amounts_
-        , Posting.comments=comments__
-        , Posting.dates=dates_
-        , Posting.sourcepos=sourcepos
-        , Posting.status=status_
-        , Posting.tags=tags_
+       return (Posting
+        { posting_account=account_
+        , posting_amounts=amounts_
+        , posting_comments=comments_
+        , posting_dates=dates_
+        , posting_sourcepos=sourcepos
+        , posting_status=status_
+        , posting_tags=tags_
         }, type_)
-       <?> "posting"
+       <?> "posting"
 
 amount_sep :: Char
 amount_sep = '+'
 
-tags_of_comments :: [Comment] -> Tag.By_Name
+tags_of_comments :: [Comment] -> Tag_by_Name
 tags_of_comments =
        Data.Map.unionsWith (++)
        . Data.List.map
         ( Data.Either.either (const Data.Map.empty) id
         . R.runParser (not_tag >> tags <* R.eof) () "" )
 
-status :: Stream s m Char => ParsecT s u m Transaction.Status
-status =
+status :: Stream s m Char => ParsecT s u m Ledger.Status
+status = (do
        ( R.try $ do
-               R.skipMany $ space_horizontal
-               _ <- (R.char '*' <|> R.char '!') <?> "status"
+               R.skipMany $ R.space_horizontal
+               _ <- (R.char '*' <|> R.char '!')
                return True )
        <|> return False
-       <?> "status"
-
--- | Parse an 'Account' with Posting.'Posting.Type'.
-account_with_posting_type :: Stream s m Char => ParsecT s u m (Account, Posting.Type)
-account_with_posting_type = do
-       R.choice_try
-        [ (, Posting.Type_Virtual)          <$> R.between (R.char posting_type_virtual_begin)
-                                                          (R.char posting_type_virtual_end)
-                                                          account
-        , (, Posting.Type_Virtual_Balanced) <$> R.between (R.char posting_type_virtual_balanced_begin)
-                                                          (R.char posting_type_virtual_balanced_end)
-                                                          account
-        , (, Posting.Type_Regular)          <$> account
-        ]
+       ) <?> "status"
+
+-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
+posting_type :: Account -> (Posting_Type, Account)
+posting_type acct =
+       fromMaybe (Posting_Type_Regular, acct) $ do
+               case acct of
+                name:|[] ->
+                       case Text.stripPrefix virtual_begin name of
+                        Just name' -> do
+                               name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
+                               guard $ not $ Text.null name''
+                               Just (Posting_Type_Virtual, name'':|[])
+                        Nothing -> do
+                               name' <- liftM Text.strip $
+                                           Text.stripPrefix virtual_balanced_begin name
+                                       >>= Text.stripSuffix virtual_balanced_end
+                               guard $ not $ Text.null name'
+                               Just (Posting_Type_Virtual_Balanced, name':|[])
+                first_name:|acct' -> do
+                               let rev_acct' = Data.List.reverse acct'
+                               let last_name = Data.List.head rev_acct'
+                               case liftM Text.stripStart $
+                                       Text.stripPrefix virtual_begin first_name of
+                                Just first_name' -> do
+                                       last_name' <- liftM Text.stripEnd $
+                                               Text.stripSuffix virtual_end last_name
+                                       guard $ not $ Text.null first_name'
+                                       guard $ not $ Text.null last_name'
+                                       Just $
+                                               ( Posting_Type_Virtual
+                                               , first_name':|
+                                                       Data.List.reverse (last_name':Data.List.tail rev_acct')
+                                               )
+                                Nothing -> do
+                                       first_name' <- liftM Text.stripStart $
+                                               Text.stripPrefix virtual_balanced_begin first_name
+                                       last_name'  <- liftM Text.stripEnd $
+                                               Text.stripSuffix virtual_balanced_end last_name
+                                       guard $ not $ Text.null first_name'
+                                       guard $ not $ Text.null last_name'
+                                       Just $
+                                               ( Posting_Type_Virtual_Balanced
+                                               , first_name':|
+                                                       Data.List.reverse (last_name':Data.List.tail rev_acct')
+                                               )
+       where
+               virtual_begin          = Text.singleton posting_type_virtual_begin
+               virtual_end            = Text.singleton posting_type_virtual_end
+               virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
+               virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 
 posting_type_virtual_begin :: Char
 posting_type_virtual_begin = '('
@@ -618,195 +397,247 @@ posting_type_virtual_end = ')'
 posting_type_virtual_balanced_end :: Char
 posting_type_virtual_balanced_end = ']'
 
--- * Parsing 'Transaction'
+-- * Read 'Transaction'
 
-transaction :: Stream s m Char => ParsecT s Context m Transaction
-transaction = do
-       sourcepos <- R.getPosition
+transaction
+ :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
+transaction = (do
        ctx <- R.getState
-       comments_before <- comments
-       date_ <- date (Just $ context_year ctx)
+       transaction_sourcepos <- R.getPosition
+       transaction_comments_before <-
+               comments
+               >>= \x -> case x of
+                [] -> return []
+                _  -> return x <* R.new_line
+       date_ <- Date.Read.date Error_date (Just $ context_year ctx)
        dates_ <-
                R.option [] $ R.try $ do
-                       R.skipMany $ space_horizontal
+                       R.skipMany $ R.space_horizontal
                        _ <- R.char date_sep
-                       R.skipMany $ space_horizontal
+                       R.skipMany $ R.space_horizontal
                        R.many_separated
-                        (date (Just $ context_year ctx)) $
+                        (Date.Read.date Error_date (Just $ context_year ctx)) $
                                R.try $ do
-                                       R.many $ space_horizontal
+                                       R.many $ R.space_horizontal
                                        >> R.char date_sep
-                                       >> (R.many $ space_horizontal)
-       R.skipMany $ space_horizontal
-       status_ <- status
-       code_ <- R.option "" $ R.try code
-       R.skipMany $ space_horizontal
-       description_ <- description
-       R.skipMany $ space_horizontal
-       comments_after <- comments
-       let tags_ =
+                                       >> (R.many $ R.space_horizontal)
+       let transaction_dates = (date_, dates_)
+       R.skipMany $ R.space_horizontal
+       transaction_status <- status
+       transaction_code <- R.option "" $ R.try code
+       R.skipMany $ R.space_horizontal
+       transaction_description <- description
+       R.skipMany $ R.space_horizontal
+       transaction_comments_after <- comments
+       let transaction_tags =
                Data.Map.unionWith (++)
-                (tags_of_comments comments_before)
-                (tags_of_comments comments_after)
+                (tags_of_comments transaction_comments_before)
+                (tags_of_comments transaction_comments_after)
        R.new_line
-       postings_ <- many1_separated posting R.new_line
-       let (postings, postings__) =
-               (Posting.from_List . Data.List.map fst) *** id $
-               Data.List.partition
-                ((Posting.Type_Regular ==) . snd)
-                postings_
-       let (virtual_postings, balanced_virtual_postings) =
-               join (***) (Posting.from_List . Data.List.map fst) $
-               Data.List.partition
-                ((Posting.Type_Virtual ==) . snd)
-                postings__
+       (postings_unchecked, postings_not_regular) <-
+               first (Ledger.posting_by_Account . Data.List.map fst) .
+               Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
+               R.many1_separated posting R.new_line
+       let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
+               join (***) (Ledger.posting_by_Account . Data.List.map fst) $
+               Data.List.partition ((Posting_Type_Virtual ==) . snd)
+                postings_not_regular
+       let tr_unchecked =
+               Transaction
+                { transaction_code
+                , transaction_comments_before
+                , transaction_comments_after
+                , transaction_dates
+                , transaction_description
+                , transaction_postings=postings_unchecked
+                , transaction_virtual_postings
+                , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
+                , transaction_sourcepos
+                , transaction_status
+                , transaction_tags
+                }
+       transaction_postings <-
+               case Balance.infer_equilibrium postings_unchecked of
+                (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+                                            (Error_transaction_not_equilibrated tr_unchecked ko)
+                (_bal, Right ok) -> return ok
+       transaction_balanced_virtual_postings <-
+               case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
+                (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+                                            (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
+                (_bal, Right ok) -> return ok
        return $
-               Transaction.Transaction
-                { Transaction.code=code_
-                , Transaction.comments_before
-                , Transaction.comments_after
-                , Transaction.dates=(date_, dates_)
-                , Transaction.description=description_
-                , Transaction.postings
-                , Transaction.virtual_postings
-                , Transaction.balanced_virtual_postings
-                , Transaction.sourcepos
-                , Transaction.status=status_
-                , Transaction.tags=tags_
+               tr_unchecked
+                { transaction_postings
+                , transaction_balanced_virtual_postings
                 }
-       <?> "transaction"
+       <?> "transaction"
 
 date_sep :: Char
 date_sep = '='
 
-code :: Stream s m Char => ParsecT s Context m Transaction.Code
-code = do
-       Text.pack <$> do
-       R.skipMany $ space_horizontal
+code :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m Ledger.Code
+code = (do
+       fromString <$> do
+       R.skipMany $ R.space_horizontal
        R.between (R.char '(') (R.char ')') $
-               R.many $ R.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
-       <?> "code"
+               R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
+       <?> "code"
 
-description :: Stream s m Char => ParsecT s u m Transaction.Description
-description = do
-       Text.pack <$> do
+description :: Stream s m Char => ParsecT s u m Ledger.Description
+description = (do
+       fromString <$> do
        R.many $ R.try description_char
-       <?> "description"
+       <?> "description"
        where
                description_char :: Stream s m Char => ParsecT s u m Char
                description_char = do
                        c <- R.anyChar
                        case c of
                         _ | c == comment_begin -> R.parserZero
-                        _ | is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
+                        _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
                         _ | not (Data.Char.isSpace c) -> return c
                         _ -> R.parserZero
 
--- * Parsing directives
+-- * Read directives
 
-default_year :: Stream s m Char => ParsecT s Context m ()
-default_year = do
+default_year
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
+default_year = (do
        year <- R.integer_of_digits 10 <$> R.many1 R.digit
+       R.skipMany R.space_horizontal >> R.new_line
        context_ <- R.getState
        R.setState context_{context_year=year}
-
-default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
-default_unit_and_style = do
-       R.skipMany1 space_horizontal
-       amount_ <- amount
-       R.skipMany space_horizontal >> R.new_line >> R.skipMany space_horizontal
+       ) <?> "default year"
+
+default_unit_and_style
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
+default_unit_and_style = (do
+       amount_ <- Amount.Read.amount
+       R.skipMany R.space_horizontal >> R.new_line
        context_ <- R.getState
-       R.setState context_{context_unit_and_style=Just $
-        ( Amount.unit  amount_
-        , Amount.style amount_ )}
-
-include :: Stream s IO Char => ParsecT s Context IO ()
-include = do
+       R.setState context_{context_unit_and_style =
+               Just $
+                ( Amount.unit  amount_
+                , Amount.style amount_ )}
+       ) <?> "default unit and style"
+
+include ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => ParsecT s (Context f ts Transaction) (R.Error_State Error IO) ()
+include = (do
        sourcepos <- R.getPosition
-       R.skipMany1 $ space_horizontal
        filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
        context_ <- R.getState
        let journal_ = context_journal context_
        let cwd = Path.takeDirectory (R.sourceName sourcepos)
-       file_ <- liftIO $ Path.abs cwd filename
-       (journal_included, context_included) <- liftIO $
-               Exception.catch
-                (readFile file_)
-                (\ko -> fail $ concat -- TODO: i18n by using a custom data type
-                        [ show sourcepos
-                        , " reading "
-                        , file_
-                        , ":\n", show (ko::Exception.IOException)
-                        ])
-               >>= R.runParserT (R.and_state $ journal_rec file_)
-                        context_{context_journal = Journal.nil}
-                        file_
-               >>= \case
-                Left  ko -> fail $ show ko
+       file_path <- liftIO $ Path.abs cwd filename
+       content <- do
+               join $ liftIO $ Exception.catch
+                (liftM return $ readFile file_path)
+                (return . R.fail_with "include reading" . Error_reading_file file_path)
+       (journal_included, context_included) <- do
+               liftIO $
+                       R.runParserT_with_Error (R.and_state $ journal_rec file_path)
+                        context_{context_journal = Ledger.journal}
+                        file_path content
+               >>= \x -> case x of
                 Right ok -> return ok
+                Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
        R.setState $
                context_included{context_journal=
-                       journal_{Journal.includes=
-                               journal_included{Journal.file=file_}
-                               : Journal.includes journal_}}
-       <?> "include"
-
--- * Parsing 'Journal'
-
-journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
-journal file_ = do
+                       journal_{journal_includes=
+                               journal_included{journal_file=file_path}
+                               : journal_includes journal_}}
+       ) <?> "include"
+
+-- * Read 'Journal'
+
+journal ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => FilePath
+ -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
+journal file_ = (do
        currentLocalTime <- liftIO $
                Time.utcToLocalTime
                <$> Time.getCurrentTimeZone
                <*> Time.getCurrentTime
        let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
-       context_ <- R.getState
-       R.setState $ context_{context_year=currentLocalYear}
+       ctx <- R.getState
+       R.setState $ ctx{context_year=currentLocalYear}
        journal_rec file_
-       <?> "journal"
-
-journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
+       ) <?> "journal"
+
+journal_rec ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => FilePath
+ -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
 journal_rec file_ = do
-       last_read_time <- liftIO $ Time.getCurrentTime
+       last_read_time <- liftIO Date.now
        R.skipMany $ do
-               R.skipMany1 R.space
-               <|> ((R.choice_try
-                        [ R.string "Y" >> return default_year
-                        , R.string "D" >> return default_unit_and_style
+               R.choice_try
+                [ R.skipMany1 R.space
+                , (do (R.choice_try
+                        [ R.string "Y"        >> return default_year
+                        , R.string "D"        >> return default_unit_and_style
                         , R.string "!include" >> return include
-                        ] <?> "directive") >>= id)
-               <|> do
-               t <- transaction
-               context_' <- R.getState
-               let j = context_journal context_'
-               R.setState $ context_'{context_journal=
-                       j{Journal.transactions=
-                               Data.Map.insertWith (flip (++))
-                                -- NOTE: flip-ing preserves order but slows down
-                                -- when many transactions have the very same date.
-                                (Date.to_UTC $ fst $ Transaction.dates t) [t]
-                                (Journal.transactions j)}}
-               R.new_line <|> R.eof
-       
-       R.skipMany $ R.satisfy Data.Char.isSpace
+                        ] <?> "directive")
+                               >>= \r -> R.skipMany1 R.space_horizontal >> r)
+                , ((do
+                               t <- transaction
+                               ctx <- R.getState
+                               let j = context_journal ctx
+                               R.setState $
+                                       ctx{context_journal=
+                                               j{journal_transactions=
+                                                       mcons (context_filter ctx) t $
+                                                               journal_transactions j}}
+                               R.new_line <|> R.eof))
+                , R.try (void $ comment)
+                ]
        R.eof
        journal_ <- context_journal <$> R.getState
        return $
                journal_
-                { Journal.file = file_
-                , Journal.last_read_time
-                , Journal.includes = reverse $ Journal.includes journal_
+                { journal_file = file_
+                , journal_last_read_time = last_read_time
+                , journal_includes = reverse $ journal_includes journal_
                 }
 
--- ** Parsing 'Journal' from a file
-
-file :: FilePath -> ExceptT String IO Journal
-file path = do
+-- ** Read 'Journal' from a file
+
+file
+ ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ )
+ => Context f ts Transaction
+ -> FilePath
+ -> ExceptT [R.Error Error] IO (Journal (ts Transaction))
+file ctx path = do
        ExceptT $
                Exception.catch
                 (liftM Right $ Text.IO.readFile path) $
-                \ko -> return $ Left $ show (ko::Exception.IOException)
-       >>= liftIO . R.runParserT (journal path) nil_Context path
-       >>= \case
-        Left  ko -> throwE $ show ko
+                \ko -> return $ Left $
+                        [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
+       >>= liftIO . R.runParserT_with_Error (journal path) ctx path
+       >>= \x -> case x of
+        Left  ko -> throwE $ ko
         Right ok -> ExceptT $ return $ Right ok