{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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.Monad (guard, (>=>), 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 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 P
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Data.Text.IO as Text.IO (readFile)
import qualified Data.Text as Text (pack)
import           System.Directory (getHomeDirectory)
import qualified System.FilePath.Posix as Path
import           System.FilePath ((</>))

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)
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)

data Context
 =   Context
 { context_account_prefix :: !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 = []
	 , 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
	 }

-- * Utilities

-- ** Combinators

-- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
choice_try :: Stream s m t => [ParsecT s st m a] -> ParsecT s st m a
choice_try = Data.List.foldr (\a -> (<|>) (P.try a)) P.parserZero
-- choice_try = P.choice . Data.List.map P.try

-- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
many_separated
 :: Stream s m t
 => ParsecT s st m a
 -> ParsecT s st m b
 -> ParsecT s st m [a]
many_separated p sep =
	many1_separated p sep <|> return []

-- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
many1_separated
 :: Stream s m t
 => ParsecT s st m a
 -> ParsecT s st m b
 -> ParsecT s st m [a]
many1_separated p sep = do
	x <- p
	xs <- P.many (P.try (sep >> p))
	return $ x:xs
-- (:) <$> p <*> P.many (P.try (sep >> p))

and_context
 :: Stream s m t
 => ParsecT s st m a
 -> ParsecT s st m (a, st)
and_context p = do
	a <- p
	s <- P.getState
	return (a, s)

-- | Return an absolute 'FilePath', given the current working directory and a path.
--
--   * "~" as prefix is expanded to the process's user's home directory
--   * "-" as path is unchanged
--   * ~USER is not supported
path_abs :: FilePath -> FilePath -> IO FilePath
path_abs _ "-" = return "-"
path_abs cwd path =
	liftM
	 (if Path.isRelative path
		then (cwd </>)
		else id)
	 (expand path)
	where
		expand :: FilePath -> IO FilePath
		expand ('~':sep:p) =
			if Path.isPathSeparator sep
			then liftIO $ (</> p) <$> getHomeDirectory
			else fail "~USERNAME in path is not supported"
		expand p = return p

-- ** Numbers

-- | Return the 'Integer' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
integer_of_digits
 :: Integer -- ^ Base.
 -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 -> Integer
integer_of_digits base =
	Data.List.foldl (\x d ->
		base*x + toInteger (Data.Char.digitToInt d)) 0

decimal :: Stream s m Char => ParsecT s st m Integer
decimal = integer 10 P.digit
hexadecimal :: Stream s m Char => ParsecT s st m Integer
hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
octal :: Stream s m Char => ParsecT s st m Integer
octal = P.oneOf "oO" >> integer 8 P.octDigit

-- | Parse an 'Integer'.
integer :: Stream s m t
       => Integer -> ParsecT s st m Char
       -> ParsecT s st m Integer
integer base digit = do
	digits <- P.many1 digit
	let n = integer_of_digits base digits
	seq n (return n)

-- | Parse either '-' into 'negate', or '+' or '' into 'id'.
sign :: (Stream s m Char, Num i) => ParsecT s st m (i -> i)
sign =
	(P.char '-' >> return negate) <|>
	(P.char '+' >> return id) <|>
	return id

-- ** Whites

-- | Return 'True' if and only if the given 'Char' is an horizontal space.
is_space_horizontal :: Char -> Bool
is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c

space_horizontal :: Stream s m Char => ParsecT s st m Char
{-# INLINEABLE space_horizontal #-}
space_horizontal = P.satisfy is_space_horizontal <?> "horizontal space"

newline :: Stream s m Char => ParsecT s st m ()
newline = ((P.try (P.string "\r\n") <|> P.string "\n") >> return ()) <?> "newline"

-- * Parsing 'Account'.

account_name_sep :: Char
account_name_sep = ':'

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

-- | Parse an Account.'Account.Name'.
account_name :: Stream s m Char => ParsecT s st m Account.Name
account_name = do
	Text.pack <$> do
	P.many1 $ P.try account_name_char
	where
		account_name_char :: Stream s m Char => ParsecT s st m Char
		account_name_char = do
			c <- P.anyChar
			case c of
			 _ | c == comment_begin -> P.parserZero
			 _ | c == account_name_sep -> P.parserZero
			 _ | c == posting_type_virtual_end
			  || c == posting_type_virtual_balanced_end ->
				return c <* (P.lookAhead $ account_name_char)
			 _ | is_space_horizontal c -> do
				_ <- P.notFollowedBy $ space_horizontal
				return c <* (P.lookAhead
				 ( P.try (P.char account_name_sep)
				 <|> account_name_char
				 ))
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> P.parserZero

-- | Parse an Account.'Account.Joker_Name'.
account_joker_name :: Stream s m Char => ParsecT s st m Account.Joker_Name
account_joker_name = do
	n <- P.option Nothing $ (Just <$> account_name)
	case n of
	 Nothing -> P.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 st m Account.Joker
account_joker = do
	P.notFollowedBy $ space_horizontal
	many1_separated account_joker_name $ P.char account_name_sep

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

-- | Parse an Account.'Account.Filter'.
account_pattern :: Stream s m Char => ParsecT s st m Account.Pattern
account_pattern = do
	choice_try
	 [ Account.Pattern_Exact <$> (P.char '=' >> account)
	 , Account.Pattern_Joker <$> (P.char '*' >> account_joker)
	 , Account.Pattern_Regex <$> (P.option '~' (P.char '~') >> account_regex)
	 ]

-- * Parsing 'Amount'.

-- | Parse an 'Amount'.
amount :: Stream s m Char => ParsecT s st m Amount
amount = do
	left_signing <- sign
	left_unit <-
		P.option Nothing $ do
			u <- unit
			s <- P.many $ space_horizontal
			return $ Just $ (u, not $ null s)
	(quantity_, style) <- do
		signing <- sign
		Quantity
		 { integral
		 , fractional
		 , fractioning
		 , grouping_integral
		 , grouping_fractional
		 } <-
			choice_try
			 [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '.' ',' '_' <* (P.notFollowedBy $ P.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 = integer_of_digits 10 $ int ++ frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral place)
			 (signing mantissa)
		 , Style.nil
			 { Style.fractioning = fractioning
			 , Style.grouping_integral = grouping_integral
			 , Style.grouping_fractional = grouping_fractional
			 , Style.precision = fromIntegral $ length frac_flat
			 }
		 )
	(unit_, side, spaced) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Style.Side_Left, Just s)
		 Nothing ->
			P.option (Unit.nil, Nothing, Nothing) $ do
				s <- P.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 = side
			 , Style.unit_spaced = 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 st m Quantity
quantity int_group_sep frac_sep frac_group_sep = do
	(integral, grouping_integral) <- do
		h <- P.many P.digit
		case h of
		 [] -> return ([], Nothing)
		 _ -> do
			t <- P.many $ P.char int_group_sep >> P.many1 P.digit
			let digits = h:t
			return (digits, grouping_of_digits int_group_sep digits)
	(fractional, fractioning, grouping_fractional) <-
		(case integral of
		 [] -> id
		 _ -> P.option ([], Nothing, Nothing)) $ do
			fractioning <- P.char frac_sep
			h <- P.many P.digit
			t <- P.many $ P.char frac_group_sep >> P.many1 P.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 st m Unit
unit =
	(quoted <|> unquoted) <?> "unit"
	where
		unquoted :: Stream s m Char => ParsecT s st m Unit
		unquoted =
			Text.pack <$> do
			P.many1 $
				P.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 st m Unit
		quoted =
			Text.pack <$> do
			P.between (P.char '"') (P.char '"') $
				P.many1 $
					P.noneOf ";\n\""

-- * Directives

directive_alias :: Stream s m Char => ParsecT s Context m ()
directive_alias = do
	_ <- P.string "alias"
	P.skipMany1 $ space_horizontal
	pattern <- account_pattern
	P.skipMany $ space_horizontal
	_ <- P.char '='
	P.skipMany $ space_horizontal
	repl <- account
	P.skipMany $ space_horizontal
	case pattern of
	 Account.Pattern_Exact acct -> P.modifyState $ \ctx -> ctx{context_aliases_exact=
		Data.Map.insert acct repl $ context_aliases_exact ctx}
	 Account.Pattern_Joker jokr -> P.modifyState $ \ctx -> ctx{context_aliases_joker=
		(jokr, repl):context_aliases_joker ctx}
	 Account.Pattern_Regex regx -> P.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 st m Char
date_separator = P.satisfy (\c -> c == '/' || c == '-')

-- | Parse the hour, minute and second separator: ':'.
hour_separator :: Stream s m Char => ParsecT s st m Char
hour_separator = P.char ':'

-- * Parsing 'Date'.

-- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
date :: Stream s m Char => Maybe Integer -> ParsecT s st m Date
date def_year = do
	n0 <- P.many1 P.digit
	date_sep <- date_separator
	n1 <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
	n2 <- P.option Nothing $ P.try $ do
		_ <- P.char date_sep
		Just <$> do P.try (P.count 2 P.digit) <|> P.count 1 P.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 (integer_of_digits 10 n0, n1, d)
	let month = fromInteger $ integer_of_digits 10 m
	let day   = fromInteger $ 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) <-
		P.option (0, 0, 0, Time.utc) $ P.try $ do
			P.skipMany1 $ space_horizontal
			hour <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
			sep <- hour_separator
			minu <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
			sec <- P.option Nothing $ P.try $ do
				_ <- P.char sep
				Just <$> (P.try (P.count 2 P.digit) <|> P.count 1 P.digit)
			-- DO: timezone
			tz <- P.option Time.utc $ P.try $ do
				P.skipMany $ space_horizontal
				time_zone
			return
			 ( integer_of_digits 10 hour
			 , integer_of_digits 10 minu
			 , maybe 0 (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.
	P.choice
	 [ P.char 'A' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
		 , P.string "DT" >> return (TimeZone ((-3) * 60) False "ADT")
		 , return (TimeZone ((-1) * 60) False "A")
		 ]
	 , P.char 'B' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
		 , P.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
		 ]
	 , P.char 'C' >> P.choice
		 [ P.char 'E' >> P.choice
			 [ P.string "T" >> return (TimeZone ((1) * 60) False "CET")
			 , P.string "ST" >> return (TimeZone ((2) * 60) True  "CEST")
			 ]
		 , P.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
		 , P.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
		 ]
	 , P.char 'E' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
		 , P.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
		 ]
	 , P.string "GMT" >> return (TimeZone 0 False "GMT")
	 , P.char 'H' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
		 , P.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
		 ]
	 , P.char 'M' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
		 , P.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
		 , return (TimeZone ((-12) * 60) False "M")
		 ]
	 , P.char 'N' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
		 , return (TimeZone (1 * 60) False "N")
		 ]
	 , P.char 'P' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
		 , P.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
		 ]
	 , P.char 'Y' >> P.choice
		 [ P.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
		 , P.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
		 , return (TimeZone (12 * 60) False "Y")
		 ]
	 , P.char 'Z' >> return (TimeZone 0 False "Z")
	 , time_zone_digits
	 ]

time_zone_digits :: Stream s m Char => ParsecT s st m TimeZone
{-# INLINEABLE time_zone_digits #-}
time_zone_digits = do
	sign_ <- sign
	hour <- integer_of_digits 10 <$> P.count 2 P.digit
	_ <- P.option ':' (P.char ':')
	minute <- integer_of_digits 10 <$> P.count 2 P.digit
	let tz = TimeZone
		 { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
		 , timeZoneSummerOnly = False
		 , timeZoneName       = Time.timeZoneOffsetString tz
		 }
	return tz

-- * Parsing 'Comment'.

type Comment = Transaction.Comment

comment_begin :: Char
comment_begin = ';'

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

comments :: Stream s m Char => ParsecT s st m [Comment]
comments = do
	many_separated comment $
		Text.pack <$> do
		P.many1 $ P.satisfy Data.Char.isSpace

-- * Parsing 'Tag'.

tag_value_sep :: Char
tag_value_sep = ':'

tag_sep :: Char
tag_sep = ','

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

tag_name :: Stream s m Char => ParsecT s st m Tag.Name
tag_name = do
	P.many1 $ P.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))

tag_value :: Stream s m Char => ParsecT s st m Tag.Value
tag_value = do
	P.many $
		P.satisfy (\c -> c /= tag_sep && c /= '\n')

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

-- * Parsing 'Posting'.

-- | Parse a 'Posting'.
posting :: Stream s m Char => ParsecT s Context m Posting
posting = do
	ctx <- P.getState
	sourcepos <- P.getPosition
	P.skipMany1 $ space_horizontal
	status_ <- status
	P.skipMany $ space_horizontal
	(account_, type_) <- account_with_posting_type
	amounts_ <-
		choice_try
		 [ do
			_ <- P.count 2 (space_horizontal)
			Amount.from_List <$> do
				many_separated amount $ P.try $ do
					P.skipMany $ space_horizontal
					_ <- P.char '+'
					P.skipMany $ space_horizontal
					return ()
		 , return Data.Map.empty
		 ]
	P.skipMany $ 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) $
				P.runParserT (date (Just $ context_year ctx) <* P.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
			 ([], 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_
	 , Posting.type_=type_
	 }
	<?> "posting"

tags_of_comments :: [Comment] -> Tag.By_Name
tags_of_comments =
	Data.Map.unionsWith (++)
	. Data.List.map
	 ( Data.Either.either (const Data.Map.empty) id
	 . P.runParser (do
			P.skipMany $ P.try $ do
				P.skipMany $ P.satisfy
				 (\c -> c /= tag_value_sep
					 && not (Data.Char.isSpace c))
				space_horizontal
			tags <* P.eof)
		 () "" )

status :: Stream s m Char => ParsecT s st m Bool
status =
	( P.try $ do
		P.skipMany $ space_horizontal
		_ <- (P.char '*' <|> P.char '!') <?> "status"
		return True )
	<|> return False
	<?> "status"

-- | Parse an 'Account' with Posting.'Posting.Type'.
account_with_posting_type :: Stream s m Char => ParsecT s st m (Account, Posting.Type)
account_with_posting_type = do
	choice_try
	 [ (, Posting.Type_Virtual)          <$> P.between (P.char '(') (P.char posting_type_virtual_end) account
	 , (, Posting.Type_Virtual_Balanced) <$> P.between (P.char '[') (P.char posting_type_virtual_balanced_end) account
	 , (, Posting.Type_Regular)          <$> account
	 ]

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 <- P.getPosition
	ctx <- P.getState
	comments_before <- comments
	date_ <- date (Just $ context_year ctx)
	dates_ <-
		P.option [] $ P.try $ do
			_ <- P.many $ space_horizontal
			_ <- P.char '='
			_ <- P.many $ space_horizontal
			many_separated
			 (date (Just $ context_year ctx)) $
				P.try $ do
					P.many $ space_horizontal
					>> P.char '='
					>> (P.many $ space_horizontal)
	_ <- P.many $ space_horizontal
	status_ <- status
	code_ <- P.option "" $ P.try code
	P.skipMany $ space_horizontal
	description_ <- description
	P.skipMany $ space_horizontal
	comments_after <- comments
	let tags_ =
		Data.Map.unionWith (++) -- TODO: check order is preserved on equality, or flip (++)
		 (tags_of_comments comments_before)
		 (tags_of_comments comments_after)
	newline
	postings_ <- Posting.from_List <$> many1_separated posting (newline)
	return $
		Transaction.Transaction
		 { Transaction.code=code_
		 , Transaction.comments_before=comments_before
		 , Transaction.comments_after=comments_after
		 , Transaction.dates=(date_, dates_)
		 , Transaction.description=description_
		 , Transaction.postings=postings_
		 , Transaction.sourcepos
		 , Transaction.status=status_
		 , Transaction.tags=tags_
		 }
	<?> "transaction"

code :: Stream s m Char => ParsecT s Context m Transaction.Code
code = do
	Text.pack <$> do
	P.skipMany $ space_horizontal
	P.between (P.char '(') (P.char ')') $
		P.many $ P.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
	<?> "code"

description :: Stream s m Char => ParsecT s st m Transaction.Description
description = do
	Text.pack <$> do
	P.many $ P.try description_char
	<?> "description"
	where
		description_char :: Stream s m Char => ParsecT s st m Char
		description_char = do
			c <- P.anyChar
			case c of
			 _ | c == comment_begin -> P.parserZero
			 _ | is_space_horizontal c -> return c <* P.lookAhead description_char
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> P.parserZero

-- * Parsing directives.

default_year :: Stream s m Char => ParsecT s Context m ()
default_year = do
	year <- integer_of_digits 10 <$> P.many1 P.digit
	context_ <- P.getState
	P.setState context_{context_year=year}

default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
default_unit_and_style = do
	P.skipMany1 space_horizontal
	amount_ <- amount
	P.skipMany space_horizontal >> newline >> P.skipMany space_horizontal
	context_ <- P.getState
	P.setState context_{context_unit_and_style=Just $
	 ( Amount.unit  amount_
	 , Amount.style amount_ )}

include :: Stream s IO Char => ParsecT s Context IO ()
include = do
	sourcepos <- P.getPosition
	P.skipMany1 $ space_horizontal
	(filename::String) <- P.manyTill P.anyChar (P.lookAhead newline <|> P.eof)
	context_ <- P.getState
	let journal_ = context_journal context_
	let cwd = Path.takeDirectory (P.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)
			 ])
		>>= P.runParserT (and_context $ journal_rec file_)
			 context_{context_journal=Journal.nil}
			 file_
		>>= \case
		 Left  ko -> fail $ show ko
		 Right ok -> return ok
	P.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
	currentUTC <- liftIO $ Time.getCurrentTime
	currentTimeZone <- liftIO $ Time.getCurrentTimeZone
	let currentLocalTime = Time.utcToLocalTime currentTimeZone currentUTC
	let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
	context_ <- P.getState
	P.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
	P.skipMany $ do
		P.skipMany1 P.space
		<|> ((choice_try
			 [ P.string "Y" >> return default_year
			 , P.string "D" >> return default_unit_and_style
			 , P.string "!include" >> return include
			 ] <?> "directive") >>= id)
		<|> do
		t <- transaction
		context_' <- P.getState
		let j = context_journal context_'
		P.setState $ context_'{context_journal=
			j{Journal.transactions=
				Data.Map.insertWith (++)
				 (Date.to_UTC $ fst $ Transaction.dates t) [t]
				 (Journal.transactions j)}}
		newline <|> P.eof
	
	P.skipMany $ P.satisfy Data.Char.isSpace
	P.eof
	journal_ <- context_journal <$> P.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
	content <- ExceptT $
		Exception.catch
		 (liftM Right $ Text.IO.readFile path) $
		 \ko -> return $ Left $ show (ko::Exception.IOException)
	liftIO $ P.runParserT (journal path) nil_Context path content
	>>= \case
	 Left  ko -> throwE $ show ko
	 Right ok -> ExceptT $ return $ Right ok