{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.Format.Ledger.Read where

import           Control.Applicative ((<$>), (<*>), (<*))
import qualified Control.Exception as Exception
import           Control.Arrow ((***))
import           Control.Monad (guard, join, liftM, (>=>))
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 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           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Data.Text.IO as Text.IO (readFile)
import qualified Data.Text as Text
import qualified System.FilePath.Posix as Path

import qualified Hcompta.Calc.Balance as Calc.Balance
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.Lib.Regex as Regex
import           Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path

data Context
 =   Context
 { 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_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
 , context_journal :: !Journal
 , context_year :: !Date.Year
 } deriving (Show)

nil_Context :: Context
nil_Context =
	Context
	 { context_account_prefix = Nothing
	 , context_aliases_exact = Data.Map.empty
	 , context_aliases_joker = []
	 , context_aliases_regex = []
	 , context_date = Date.nil
	 , context_unit_and_style = Nothing
	 , context_journal = Journal.nil
	 , context_year = (\(year, _ , _) -> year) $
		Time.toGregorian $ Time.utctDay $
		Journal.last_read_time Journal.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

-- * Parsing 'Account'

account_name_sep :: Char
account_name_sep = ':'

-- | Parse an 'Account'.
account :: Stream s m Char => ParsecT s u m Account
account = do
	R.notFollowedBy $ R.space_horizontal
	Account.from_List <$> do
	R.many1_separated account_name $ R.char account_name_sep

-- | Parse an Account.'Account.Name'.
account_name :: Stream s m Char => ParsecT s u m Account.Name
account_name = do
	Text.pack <$> do
	R.many1 $ R.try account_name_char
	where
		account_name_char :: Stream s m Char => ParsecT s u m Char
		account_name_char = do
			c <- R.anyChar
			case c of
			 _ | c == comment_begin -> R.parserZero
			 _ | c == account_name_sep -> R.parserZero
			 _ | 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
				 ))
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> R.parserZero

-- | Parse 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)
	case n of
	 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
	 Just n' -> return $ Account.Joker_Name n'

-- | Parse an Account.'Account.Joker'.
account_joker :: Stream s m Char => ParsecT s u m Account.Joker
account_joker = do
	R.notFollowedBy $ R.space_horizontal
	R.many1_separated account_joker_name $ R.char account_name_sep

-- | Parse a 'Regex'.
account_regex :: Stream s m Char => ParsecT s u m Regex
account_regex = do
	re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
	Regex.of_StringM re

-- | Parse an Account.'Account.Filter'.
account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
account_pattern = do
	R.choice_try
	 [ Account.Pattern_Exact <$> (R.char '=' >> account)
	 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
	 , 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 $ R.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) $ R.try $ do
				s <- R.many $ R.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 = do
	_ <- R.string "alias"
	R.skipMany1 $ R.space_horizontal
	pattern <- account_pattern
	R.skipMany $ R.space_horizontal
	_ <- R.char '='
	R.skipMany $ R.space_horizontal
	repl <- account
	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}
	 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
		(jokr, repl):context_aliases_joker ctx}
	 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
		(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 $ R.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 $ R.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'

comment_begin :: Char
comment_begin = ';'

comment :: Stream s m Char => ParsecT s u m Comment
comment = (do
	_ <- R.char comment_begin
	Text.pack <$> do
	R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
	) <?> "comment"

comments :: Stream s m Char => ParsecT s u m [Comment]
comments = (do
	R.try $ do
		_ <- R.spaces
		R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
	<|> return []
	) <?> "comments"

-- * Parsing 'Tag'

tag_value_sep :: Char
tag_value_sep = ':'

tag_sep :: Char
tag_sep = ','

-- | Parse a 'Tag'.
tag :: Stream s m Char => ParsecT s u m Tag
tag = (do
	n <- tag_name
	_ <- R.char tag_value_sep
	v <- tag_value
	return (n, v)
	) <?> "tag"

tag_name :: Stream s m Char => ParsecT s u m Tag.Name
tag_name = do
	Text.pack <$> 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 = do
	Text.pack <$> do
	R.manyTill R.anyChar $ do
		R.lookAhead $ do
			R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
			<|> R.try R.new_line
			<|> R.eof

tags :: Stream s m Char => ParsecT s u m Tag.By_Name
tags = do
	Tag.from_List <$> do
		R.many_separated tag $ do
			_ <- R.char tag_sep
			R.skipMany $ R.space_horizontal
			return ()

not_tag :: Stream s m Char => ParsecT s u m ()
not_tag = do
	R.skipMany $ R.try $ do
		R.skipMany $ R.satisfy
		 (\c -> c /= tag_value_sep
			 && not (Data.Char.isSpace c))
		R.space_horizontal

-- * Parsing 'Posting'

-- | Parse a 'Posting'.
posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
posting = (do
	ctx <- R.getState
	sourcepos <- R.getPosition
	R.skipMany1 $ R.space_horizontal
	status_ <- status
	R.skipMany $ R.space_horizontal
	acct <- account
	let (type_, account_) = posting_type acct
	amounts_ <-
		R.choice_try
		 [ do
			_ <- 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 $ do
					R.skipMany $ R.space_horizontal
					_ <- R.char amount_sep
					R.skipMany $ R.space_horizontal
					return ()
		 , return Data.Map.empty
		 ] <?> "amounts"
	R.skipMany $ R.space_horizontal
	-- TODO: balance assertion
	-- TODO: conversion
	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) () ""
				>=> \x -> case x of
				 Left  ko -> fail $ show ko
				 Right ok -> return ok
			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_
	 }, type_)
	) <?> "posting"

amount_sep :: Char
amount_sep = '+'

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 = (do
	( R.try $ do
		R.skipMany $ R.space_horizontal
		_ <- (R.char '*' <|> R.char '!')
		return True )
	<|> return False
	) <?> "status"

-- | Return the Posting.'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'' <-
					    Text.stripSuffix virtual_end name'
					>>= return . Text.strip
				guard $ not $ Text.null name''
				Just (Posting.Type_Virtual, name'':|[])
			 Nothing -> do
				name' <-
					    Text.stripPrefix virtual_balanced_begin name
					>>= Text.stripSuffix virtual_balanced_end
					>>= return . Text.strip
				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 Text.stripPrefix virtual_begin first_name
					>>= return . Text.stripStart of
				 Just first_name' -> do
					last_name' <-
						Text.stripSuffix virtual_end last_name
						>>= return . Text.stripEnd
					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' <-
						Text.stripPrefix virtual_balanced_begin first_name
						>>= return . Text.stripStart
					last_name'  <-
						Text.stripSuffix virtual_balanced_end last_name
						>>= return . Text.stripEnd
					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 = '('
posting_type_virtual_balanced_begin :: Char
posting_type_virtual_balanced_begin = '['
posting_type_virtual_end :: Char
posting_type_virtual_end = ')'
posting_type_virtual_balanced_end :: Char
posting_type_virtual_balanced_end = ']'

-- * Parsing 'Transaction'

transaction :: Stream s m Char => ParsecT s Context m Transaction
transaction = (do
	sourcepos <- R.getPosition
	ctx <- R.getState
	comments_before <-
		comments
		>>= \x -> case x of
		 [] -> return []
		 _  -> return x <* R.new_line
	date_ <- date (Just $ context_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			R.skipMany $ R.space_horizontal
			_ <- R.char date_sep
			R.skipMany $ R.space_horizontal
			R.many_separated
			 (date (Just $ context_year ctx)) $
				R.try $ do
					R.many $ R.space_horizontal
					>> R.char date_sep
					>> (R.many $ R.space_horizontal)
	R.skipMany $ R.space_horizontal
	status_ <- status
	code_ <- R.option "" $ R.try code
	R.skipMany $ R.space_horizontal
	description_ <- description
	R.skipMany $ R.space_horizontal
	comments_after <- comments
	let tags_ =
		Data.Map.unionWith (++)
		 (tags_of_comments comments_before)
		 (tags_of_comments comments_after)
	R.new_line
	(postings_unchecked, postings_not_regular) <-
		((Posting.from_List . Data.List.map fst) *** id) .
		Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
		R.many1_separated posting R.new_line
	let (virtual_postings, balanced_virtual_postings_unchecked) =
		join (***) (Posting.from_List . Data.List.map fst) $
		Data.List.partition ((Posting.Type_Virtual ==) . snd)
		 postings_not_regular
	postings <-
		case Calc.Balance.infer_equilibre postings_unchecked of
		 Left _l -> fail $ "transaction not-equilibrated"
		 Right ps -> return ps
	balanced_virtual_postings <-
		case Calc.Balance.infer_equilibre balanced_virtual_postings_unchecked of
		 Left _l -> fail $ "virtual transaction not-equilibrated"
		 Right ps -> return ps
	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_
		 }
	) <?> "transaction"

date_sep :: Char
date_sep = '='

code :: Stream s m Char => ParsecT s Context m Transaction.Code
code = (do
	Text.pack <$> do
	R.skipMany $ R.space_horizontal
	R.between (R.char '(') (R.char ')') $
		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
	R.many $ R.try description_char
	) <?> "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
			 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> R.parserZero

-- * Parsing directives

default_year :: Stream s m Char => ParsecT s Context 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 year"

default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
default_unit_and_style = (do
	amount_ <- 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_ )}
	) <?> "default unit and style"

include :: Stream s IO Char => ParsecT s Context IO ()
include = (do
	sourcepos <- R.getPosition
	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_
		>>= \x -> case x of
		 Left  ko -> fail $ show ko
		 Right ok -> return ok
	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
	currentLocalTime <- liftIO $
		Time.utcToLocalTime
		<$> Time.getCurrentTimeZone
		<*> Time.getCurrentTime
	let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
	context_ <- R.getState
	R.setState $ context_{context_year=currentLocalYear}
	journal_rec file_
	) <?> "journal"

journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
journal_rec file_ = do
	last_read_time <- liftIO $ Time.getCurrentTime
	R.skipMany $ do
		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")
				>>= \r -> R.skipMany1 R.space_horizontal >> r)
		 , ((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.try (comment >> return ())
		 ]
	R.eof
	journal_ <- context_journal <$> R.getState
	return $
		journal_
		 { Journal.file = file_
		 , Journal.last_read_time
		 , Journal.includes = reverse $ Journal.includes journal_
		 }

-- ** Parsing 'Journal' from a file

file :: FilePath -> ExceptT String IO Journal
file 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
	>>= \x -> case x of
	 Left  ko -> throwE $ show ko
	 Right ok -> ExceptT $ return $ Right ok