{-# 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           Control.Monad.Trans.Class (lift)
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.Typeable ()
import qualified Text.Parsec as R hiding
                  ( char
                  , anyChar
                  , crlf
                  , newline
                  , noneOf
                  , oneOf
                  , satisfy
                  , space
                  , spaces
                  , string
                  )
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
import qualified System.FilePath.Posix as Path

import qualified Hcompta.Calc.Balance as 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.Date as Date
import           Hcompta.Model.Date (Date)
import qualified Hcompta.Model.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 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 = Ledger.journal
	 , context_year = (\(year, _ , _) -> year) $
		Time.toGregorian $ Time.utctDay $
		journal_last_read_time Ledger.journal
	 }

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)

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

-- * Read '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
	fromString <$> 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)
	 ]

-- * Read '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 =
			fromString <$> 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 =
			fromString <$> 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 ()


-- * Read 'Comment'

comment_begin :: Char
comment_begin = ';'

comment :: Stream s m Char => ParsecT s u m Comment
comment = (do
	_ <- R.char comment_begin
	fromString <$> 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"

-- * Read '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
	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 = do
	fromString <$> 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
	Ledger.tag_by_Name <$> 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

-- * Read 'Posting'

-- | Parse a 'Posting'.
posting
 :: (Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s Context (R.Error_State Error 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
			do 
			(flip mapM) (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_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 Ledger.Status
status = (do
	( R.try $ do
		R.skipMany $ R.space_horizontal
		_ <- (R.char '*' <|> R.char '!')
		return True )
	<|> return False
	) <?> "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'' <-
					    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 = ']'

-- * Read 'Transaction'

transaction
 :: (Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s Context (R.Error_State Error m) Transaction
transaction = (do
	ctx <- R.getState
	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 $ R.space_horizontal
			_ <- R.char date_sep
			R.skipMany $ R.space_horizontal
			R.many_separated
			 (Date.Read.date Error_date (Just $ context_year ctx)) $
				R.try $ do
					R.many $ R.space_horizontal
					>> R.char date_sep
					>> (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 transaction_comments_before)
		 (tags_of_comments transaction_comments_after)
	R.new_line
	(postings_unchecked, postings_not_regular) <-
		((Ledger.posting_by_Account . Data.List.map fst) *** id) .
		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 $
		tr_unchecked
		 { transaction_postings
		 , transaction_balanced_virtual_postings
		 }
	) <?> "transaction"

date_sep :: Char
date_sep = '='

code :: Stream s m Char => ParsecT s Context 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 (R.is_space_horizontal c))
	) <?> "code"

description :: Stream s m Char => ParsecT s u m Ledger.Description
description = (do
	fromString <$> 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

-- * Read 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 (R.Error_State Error IO) Char
 => ParsecT s Context (R.Error_State Error 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_path <- liftIO $ Path.abs cwd filename
	content <- do
		liftIO $ Exception.catch
		 (liftM return $ readFile file_path)
		 (return . R.fail_with "include reading" . Error_reading_file file_path)
		>>= id
	(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_path}
				: journal_includes journal_}}
	) <?> "include"

-- * Read 'Journal'

journal
 :: Stream s (R.Error_State Error IO) Char
 => FilePath
 -> ParsecT s Context (R.Error_State Error 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 (R.Error_State Error IO) Char
 => FilePath
 -> ParsecT s Context (R.Error_State Error IO) Journal
journal_rec file_ = do
	last_read_time <- lift $ 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=last_read_time
		 , journal_includes = reverse $ journal_includes journal_
		 }

-- ** Read 'Journal' from a file

file :: FilePath -> ExceptT [R.Error Error] IO Journal
file path = do
	ExceptT $
		Exception.catch
		 (liftM Right $ Text.IO.readFile path) $
		 \ko -> return $ Left $
			 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
	>>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
	>>= \x -> case x of
	 Left  ko -> throwE $ ko
	 Right ok -> ExceptT $ return $ Right ok