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

import           Control.Applicative ((<$>), (<*>), (<*))
import           Control.Arrow ((***), first)
import qualified Control.Exception as Exception
import           Control.Monad (Monad(..), guard, liftM, join, forM, void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (ExceptT(..), throwE)
import           Data.Time.LocalTime (TimeZone(..))
import           Data.Bool
import           Data.Decimal
import           Data.Char (Char)
import qualified Data.Char as Char
import           Data.Either (Either(..), either)
import           Data.Eq (Eq(..))
import           Data.Ord (Ord(..))
import           Data.Function (($), (.), id, const, flip)
import           Data.Functor (Functor(..))
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), fromMaybe, maybe)
import           Data.Monoid (Monoid(..))
import           Data.String (String, fromString)
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.IO as Text.IO (readFile)
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           Prelude (Int, Integer, Num(..), fromIntegral)
import qualified System.FilePath.Posix as Path
import           System.IO (IO, FilePath)
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           Text.Show (Show)

import qualified Hcompta.Account as Account
import           Hcompta.Account (Account_Tags(..))
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Balance as Balance
import qualified Hcompta.Chart as Chart
import           Hcompta.Date (Date)
import qualified Hcompta.Date as Date
import           Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path
import           Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Regex as Regex
import qualified Hcompta.Lib.TreeMap as TreeMap
import qualified Hcompta.Polarize as Polarize
import           Hcompta.Posting (Posting_Tags(..))
import qualified Hcompta.Quantity as Quantity
import           Hcompta.Tag (Tag, Tags(..))
import qualified Hcompta.Tag as Tag
import           Hcompta.Transaction (Transaction_Tags(..))
import qualified Hcompta.Unit as Unit
import qualified Hcompta.Filter.Date.Read as Filter.Date.Read
import           Hcompta.Filter.Date.Read (Error(..))

import           Hcompta.Format.Ledger

-- * Type 'Read_Context'

data Read_Context c j
 =   Read_Context
 { read_context_account_prefix :: !(Maybe Account)
 , read_context_aliases_exact  :: !(Map Account Account)
 , read_context_aliases_joker  :: ![(Account_Joker, Account)]
 , read_context_aliases_regex  :: ![(Regex, Account)]
 , read_context_cons           :: Charted Transaction -> c
 , read_context_date           :: !Date
 , read_context_journal        :: !(Journal j)
 , read_context_unit           :: !(Maybe Unit)
 , read_context_year           :: !Date.Year
 }

read_context
 :: Consable c j
 => (Charted Transaction -> c)
 -> Journal j
 -> Read_Context c j
read_context read_context_cons read_context_journal =
	Read_Context
	 { read_context_account_prefix = Nothing
	 , read_context_aliases_exact  = mempty
	 , read_context_aliases_joker  = []
	 , read_context_aliases_regex  = []
	 , read_context_cons
	 , read_context_date           = Date.nil
	 , read_context_journal
	 , read_context_unit           = Nothing
	 , read_context_year           = Date.year Date.nil
	 }

-- * Type 'Read_Error'

data Read_Error
 =   Read_Error_date Date_Error
 |   Read_Error_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , Balance.Unit_Sum Account
          (Polarize.Polarized Quantity)
       )]
 |   Read_Error_virtual_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , Balance.Unit_Sum Account
          (Polarize.Polarized Quantity)
       )]
 |   Read_Error_reading_file FilePath Exception.IOException
 |   Read_Error_including_file FilePath [R.Error Read_Error]
 deriving (Show)

-- * Read common patterns

read_hspaces :: Stream s m Char => ParsecT s u m ()
read_hspaces = R.skipMany R.space_horizontal

-- * Read 'Account'

read_account :: Stream s m Char => ParsecT s u m Account
read_account = do
	R.notFollowedBy $ R.space_horizontal
	Account.from_List <$> do
	R.many1_separated read_account_section $ R.char read_account_section_sep

read_account_section :: Stream s m Char => ParsecT s u m Text
read_account_section = do
	fromString <$> (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 == read_comment_begin -> R.parserZero
			 _ | c == read_account_section_sep -> R.parserZero
			 _ | c /= '\t' && R.is_space_horizontal c -> do
				_ <- R.notFollowedBy $ R.space_horizontal
				return c <* (R.lookAhead $ R.try $
				 ( R.try (R.char read_account_section_sep)
				 <|> account_name_char
				 ))
			 _ | not (Char.isSpace c) -> return c
			 _ -> R.parserZero

read_account_section_sep :: Char
read_account_section_sep = ':'

read_comment_begin :: Char
read_comment_begin = ';'

read_account_section_joker :: Stream s m Char => ParsecT s u m Account_Joker_Section
read_account_section_joker = do
	n <- R.option Nothing $ (Just <$> read_account_section)
	case n of
	 Nothing -> R.char read_account_section_sep >> return Account_Joker_Any
	 Just n' -> return $ Account_Joker_Section n'

read_account_joker :: Stream s m Char => ParsecT s u m Account_Joker
read_account_joker = do
	R.notFollowedBy $ R.space_horizontal
	R.many1_separated read_account_section_joker $ R.char read_account_section_sep

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

read_account_pattern :: Stream s m Char => ParsecT s u m Account_Pattern
read_account_pattern = do
	R.choice_try
	 [ Account_Pattern_Exact <$> (R.char '=' >> read_account)
	 , Account_Pattern_Joker <$> (R.char '*' >> read_account_joker)
	 , Account_Pattern_Regex <$> (R.option '~' (R.char '~') >> read_account_regex)
	 ]

-- * Read 'Quantity'

read_quantity
 :: Stream s m Char
 => Char -- ^ Integral grouping separator.
 -> Char -- ^ Fractioning separator.
 -> Char -- ^ Fractional grouping separator.
 -> ParsecT s u m
 ( [String] -- integral
 , [String] -- fractional
 , Maybe Amount_Style_Fractioning -- fractioning
 , Maybe Amount_Style_Grouping -- grouping_integral
 , Maybe Amount_Style_Grouping -- grouping_fractional
 )
read_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 $ List.reverse digits)
	return $
	 ( integral
	 , fractional
	 , fractioning
	 , grouping_integral
	 , grouping_fractional
	 )
	where
		grouping_of_digits :: Char -> [String] -> Maybe Amount_Style_Grouping
		grouping_of_digits group_sep digits =
			case digits of
			 []  -> Nothing
			 [_] -> Nothing
			 _   -> Just $
				Amount_Style_Grouping group_sep $
				canonicalize_grouping $
				List.map List.length $ digits
		canonicalize_grouping :: [Int] -> [Int]
		canonicalize_grouping groups =
			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

-- * Read 'Unit'

read_unit :: Stream s m Char => ParsecT s u m Unit
read_unit =
	(quoted <|> unquoted) <?> "unit"
	where
		unquoted :: Stream s m Char => ParsecT s u m Unit
		unquoted =
			fromString <$> do
			R.many1 $
				R.satisfy $ \c ->
					case Char.generalCategory c of
					 Char.CurrencySymbol  -> True
					 Char.LowercaseLetter -> True
					 Char.ModifierLetter  -> True
					 Char.OtherLetter     -> True
					 Char.TitlecaseLetter -> True
					 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\""

-- * Read 'Amount'

read_amount
 :: Stream s m Char
 => ParsecT s u m (Amount_Styled Amount)
read_amount = do
	left_signing <- read_sign
	left_unit <-
		R.option Nothing $ do
			u <- read_unit
			s <- R.many $ R.space_horizontal
			return $ Just $ (u, not $ List.null s)
	(qty, style) <- do
		signing <- read_sign
		(  amount_style_integral
		 , amount_style_fractional
		 , amount_style_fractioning
		 , amount_style_grouping_integral
		 , amount_style_grouping_fractional
		 ) <-
			R.choice_try
			 [ read_quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , read_quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , read_quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , read_quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 ] <?> "quantity"
		let int  = List.concat amount_style_integral
		let frac = List.concat amount_style_fractional
		let precision = List.length frac
		guard (precision <= 255)
		let mantissa = R.integer_of_digits 10 $ int `mappend` frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral precision)
			 (signing mantissa)
		 , mempty
			 { amount_style_fractioning
			 , amount_style_grouping_integral
			 , amount_style_grouping_fractional
			 }
		 )
	(  amount_unit
	 , amount_style_unit_side
	 , amount_style_unit_spaced ) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Amount_Style_Side_Left, Just s)
		 Nothing ->
			R.option (Unit.unit_empty, Nothing, Nothing) $ R.try $ do
				s <- R.many R.space_horizontal
				u <- read_unit
				return $
				 ( u
				 , Just Amount_Style_Side_Right
				 , Just $ not $ List.null s )
	return $
		( style
		 { amount_style_unit_side
		 , amount_style_unit_spaced
		 }
		, Amount
		 { amount_quantity = left_signing qty
		 , amount_unit
		 }
		)

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

-- * Read 'Date'

type Date_Error = Filter.Date.Read.Error

-- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
read_date
 :: (Stream s (R.Error_State e m) Char, Monad m)
 => (Date_Error -> e) -> Maybe Integer
 -> ParsecT s u (R.Error_State e m) Date
read_date err def_year = (do
	let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
	n0 <- R.many1 R.digit
	day_sep <- read_date_separator
	n1 <- read_2_or_1_digits
	n2 <- R.option Nothing $ R.try $ do
		_ <- R.char day_sep
		Just <$> read_2_or_1_digits
	(year, m, d) <-
		case (n2, def_year) of
		 (Nothing, Nothing) -> R.fail_with "date" (err $ Error_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 dom   = fromInteger $ R.integer_of_digits 10 d
	day <- case Time.fromGregorianValid year month dom of
	 Nothing  -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
	 Just day -> return day
	(hour, minu, sec, tz) <-
		R.option (0, 0, 0, Time.utc) $ R.try $ do
			_ <- R.char '_'
			hour <- read_2_or_1_digits
			sep <- R.char read_hour_separator
			minu <- read_2_or_1_digits
			sec <- R.option Nothing $ R.try $ do
				_ <- R.char sep
				Just <$> read_2_or_1_digits
			tz <- R.option Time.utc $ R.try $
				read_time_zone
			return
			 ( fromInteger $ R.integer_of_digits 10 hour
			 , fromInteger $ R.integer_of_digits 10 minu
			 , maybe 0      (R.integer_of_digits 10) sec
			 , tz )
	tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
	 Nothing  -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
	 Just tod -> return tod
	return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
	) <?> "date"

-- | Separator for year, month and day: "/" or "-".
read_date_separator :: Stream s m Char => ParsecT s u m Char
read_date_separator = R.char '/' <|> R.char '-'

-- | Separator for hour, minute and second: ":".
read_hour_separator :: Char
read_hour_separator = ':'

read_time_zone :: Stream s m Char => ParsecT s u m TimeZone
read_time_zone = Filter.Date.Read.time_zone

read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
read_time_zone_digits = Filter.Date.Read.time_zone_digits

-- * Read 'Comment'

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

-- ** Read 'Comment's

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

-- * Read 'Tag'

read_tag_value_sep :: Char
read_tag_value_sep = ':'

read_tag_sep :: Char
read_tag_sep = ','

read_tag_path_section_char
 :: Stream s m Char
 => ParsecT s u m Char
read_tag_path_section_char =
	R.satisfy (\c -> c /= read_tag_value_sep
	 && c /= read_tag_sep
	 && not (Char.isSpace c))

read_tag :: Stream s m Char => ParsecT s u m Tag
read_tag = ((,) <$> read_tag_path <*> read_tag_value) <?> "tag"

read_tag_path :: Stream s m Char => ParsecT s u m Tag.Path
read_tag_path = do
	NonEmpty.fromList <$> do
	R.many1 $ R.try read_tag_path_section

read_tag_path_section :: Stream s m Char => ParsecT s u m Tag.Section
read_tag_path_section = do
	fromString <$> do
		((R.many1 $ read_tag_path_section_char) <* R.char read_tag_value_sep)

read_tag_value :: Stream s m Char => ParsecT s u m Tag.Value
read_tag_value = do
	fromString <$> do
	R.manyTill R.anyChar $ do
		R.lookAhead $ do
			R.try (R.char read_tag_sep
			 >> R.many R.space_horizontal
			 >> void read_tag_path_section)
			<|> R.try (void (R.try R.new_line))
			<|> R.eof

-- ** Read 'Tag's

read_tags
 :: Stream s m Char
 => ParsecT s u m (Map Tag.Path [Tag.Value])
read_tags = do
	Map.fromListWith (flip mappend)
	. List.map (\(p, v) -> (p, [v])) <$> do
		R.many_separated read_tag $ do
			_ <- R.char read_tag_sep
			read_hspaces

read_not_tag :: Stream s m Char => ParsecT s u m [Char]
read_not_tag = do
	R.many $ R.try $ do
		R.skipMany $
			R.satisfy (\c -> c /= read_tag_value_sep && not (Char.isSpace c))
		R.space_horizontal

-- * Read 'Posting'

read_posting ::
 ( Consable c j
 , Monad m
 , Stream s (R.Error_State Read_Error m) Char
 ) => ParsecT s (Read_Context c j)
                (R.Error_State Read_Error m)
                (Posting_Typed Posting)
read_posting = (do
	posting_sourcepos <- R.getPosition
	R.skipMany1 $ R.space_horizontal
	posting_status <- read_status
	read_hspaces
	acct <- read_account
	let Posting_Typed type_ posting_account = read_posting_type acct
	posting_amounts <-
		R.choice_try
		 [ do
			(void R.tab <|> void (R.count 2 R.space_horizontal))
			read_hspaces
			amts <-
				R.many_separated read_amount $ do
					read_hspaces
					_ <- R.char read_amount_sep
					read_hspaces
			ctx <- flip liftM R.getState $ \ctx ->
				ctx
				 { read_context_journal=
					let jnl = read_context_journal ctx in
					jnl
					 { journal_amount_styles =
						List.foldl'
						 (\(Amount_Styles styles) (style, amt) ->
							Amount_Styles $
							Map.insertWith (flip mappend) -- NOTE: prefer first style
							 (Amount.amount_unit amt)
							 style styles)
						 (journal_amount_styles jnl)
						 amts
					 }
				 }
			R.setState ctx
			return $
				Map.fromListWith Quantity.quantity_add $
				List.map
				 (\(_sty, amt) ->
					let unit = Amount.amount_unit amt in
					( if unit == Unit.unit_empty
						then maybe unit id (read_context_unit ctx)
						else unit
					, Amount.amount_quantity amt
					)
				 )
				 amts
		 , return mempty
		 ] <?> "amounts"
	read_hspaces
	-- TODO: balance assertion
	-- TODO: conversion
	posting_comments <- read_comments
	let posting_tags@(Tags tags_) =
		tags_of_comments posting_comments
	posting_dates <- do
		ctx <- R.getState
		case Map.lookup ("date":|[]) tags_ of
		 Nothing -> return []
		 Just dates -> do
			let date2s = Map.lookup ("date2":|[]) tags_ -- NOTE: support hledger's date2
			do
			forM (dates `mappend` fromMaybe [] date2s) $ \s ->
				R.runParserT_with_Error_fail "tag date" id
				 (read_date Read_Error_date (Just $ read_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 $ read_context_date ctx:dates_
			 _ -> return $ dates_
	return $ Posting_Typed type_ Posting
	 { posting_account
	 , posting_amounts
	 , posting_comments
	 , posting_dates
	 , posting_sourcepos
	 , posting_status
	 , posting_tags = Posting_Tags posting_tags
	 }
	) <?> "posting"

read_amount_sep :: Char
read_amount_sep = '+'

tags_of_comments :: [Comment] -> Tags
tags_of_comments =
	Tags .
	Map.unionsWith mappend
	. List.map
	 ( Data.Either.either (const Map.empty) id
	 . R.runParser (read_not_tag >> read_tags <* R.eof) () "" )

comments_without_tags :: [Comment] -> [Comment]
comments_without_tags =
	List.map
	 (\c ->
		Data.Either.either (const c) Text.pack $
		R.runParser
		 (read_not_tag <* read_tags <* R.eof)
		 () "" c
	 )

read_status :: Stream s m Char => ParsecT s u m Status
read_status = (do
	( R.try $ do
		read_hspaces
		_ <- (R.char '*' <|> R.char '!')
		return True )
	<|> return False
	) <?> "status"

-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
read_posting_type :: Account -> (Posting_Typed Account)
read_posting_type acct =
	fromMaybe (Posting_Typed 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_Typed 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_Typed Posting_Type_Virtual_Balanced $ name':|[]
		 first_name:|acct' -> do
			let rev_acct' = List.reverse acct'
			let last_name = 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_Typed
					Posting_Type_Virtual $
					first_name':| List.reverse (last_name':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_Typed
					Posting_Type_Virtual_Balanced $
					first_name':|List.reverse (last_name':List.tail rev_acct')
	where
		virtual_begin          = Text.singleton read_posting_type_virtual_begin
		virtual_end            = Text.singleton read_posting_type_virtual_end
		virtual_balanced_begin = Text.singleton read_posting_type_virtual_balanced_begin
		virtual_balanced_end   = Text.singleton read_posting_type_virtual_balanced_end

read_posting_type_virtual_begin :: Char
read_posting_type_virtual_begin = '('
read_posting_type_virtual_balanced_begin :: Char
read_posting_type_virtual_balanced_begin = '['
read_posting_type_virtual_end :: Char
read_posting_type_virtual_end = ')'
read_posting_type_virtual_balanced_end :: Char
read_posting_type_virtual_balanced_end = ']'

-- * Read 'Transaction'

read_transaction ::
 ( Consable c j
 , Monad m
 , Stream s (R.Error_State Read_Error m) Char
 ) => ParsecT s (Read_Context c j)
              (R.Error_State Read_Error m)
              Transaction
read_transaction = (do
	ctx <- R.getState
	transaction_sourcepos <- R.getPosition
	transaction_comments_before <-
		read_comments
		>>= \x -> case x of
		 [] -> return []
		 _  -> return x <* R.new_line
	date_ <- read_date Read_Error_date (Just $ read_context_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			read_hspaces
			_ <- R.char read_date_sep
			read_hspaces
			R.many_separated
			 (read_date Read_Error_date (Just $ read_context_year ctx)) $
				R.try $ do
					R.many $ R.space_horizontal
					>> R.char read_date_sep
					>> (R.many $ R.space_horizontal)
	let transaction_dates = (date_, dates_)
	read_hspaces
	transaction_status <- read_status
	transaction_code <- R.option "" $ R.try read_code
	read_hspaces
	transaction_wording <- read_wording
	read_hspaces
	transaction_comments_after <- read_comments
	let transaction_tags =
		Transaction_Tags $
		mappend
		 (tags_of_comments transaction_comments_before)
		 (tags_of_comments transaction_comments_after)
	R.new_line
	(postings_unchecked, postings_not_regular) <-
		first (postings_by_account . List.map
		 (\(Posting_Typed _ p) -> p)) .
		List.partition (\(Posting_Typed pt _) ->
			Posting_Type_Regular == pt) <$>
		R.many1_separated read_posting R.new_line
	let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
		join (***) (postings_by_account . List.map
		 (\(Posting_Typed _ p) -> p)) $
		List.partition (\(Posting_Typed pt _) ->
			Posting_Type_Virtual == pt)
		 postings_not_regular
	let tr_unchecked =
		Transaction
		 { transaction_code
		 , transaction_comments_before
		 , transaction_comments_after
		 , transaction_dates
		 , transaction_wording
		 , transaction_postings=postings_unchecked
		 , transaction_sourcepos
		 , transaction_status
		 , transaction_tags
		 }
	let styles = journal_amount_styles $ read_context_journal ctx
	transaction_postings <-
		case Balance.infer_equilibrium postings_unchecked of
		 (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
			Read_Error_transaction_not_equilibrated styles 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" $
			Read_Error_virtual_transaction_not_equilibrated styles tr_unchecked ko
		 (_bal, Right ok) -> return ok
	return $
		tr_unchecked
		 { transaction_postings =
			Map.unionsWith mappend
			 [ transaction_postings
			 , fmap (fmap set_virtual_tag) transaction_virtual_postings
			 , fmap (fmap set_virtual_tag) transaction_balanced_virtual_postings
			 ]
		 }
	) <?> "transaction"
	where
		set_virtual_tag :: Posting -> Posting
		set_virtual_tag
		 p@Posting{posting_tags=Posting_Tags (Tags attrs)} =
			p{posting_tags = Posting_Tags $ Tags $ Map.insert ("Virtual":|[]) [] attrs}

read_date_sep :: Char
read_date_sep = '='

read_code
 :: ( Consable c j
    , Stream s m Char )
 => ParsecT s (Read_Context c j) m Code
read_code = (do
	fromString <$> do
	read_hspaces
	R.between (R.char '(') (R.char ')') $
		R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
	) <?> "code"

read_wording
 :: Stream s m Char
 => ParsecT s u m Wording
read_wording = (do
	fromString <$> do
	R.many $ R.try description_char
	) <?> "wording"
	where
		description_char :: Stream s m Char => ParsecT s u m Char
		description_char = do
			c <- R.anyChar
			case c of
			 _ | c == read_comment_begin -> R.parserZero
			 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
			 _ | not (Char.isSpace c) -> return c
			 _ -> R.parserZero

-- * Read directives

read_directive_alias
 :: (Consable c j, Stream s m Char)
 => ParsecT s (Read_Context c j) m ()
read_directive_alias = do
	_ <- R.string "alias"
	R.skipMany1 $ R.space_horizontal
	pattern <- read_account_pattern
	read_hspaces
	_ <- R.char '='
	read_hspaces
	repl <- read_account
	read_hspaces
	case pattern of
	 Account_Pattern_Exact acct ->
		R.modifyState $ \ctx -> ctx{read_context_aliases_exact=
			Map.insert acct repl $ read_context_aliases_exact ctx}
	 Account_Pattern_Joker jokr ->
		R.modifyState $ \ctx -> ctx{read_context_aliases_joker=
			(jokr, repl):read_context_aliases_joker ctx}
	 Account_Pattern_Regex regx ->
		R.modifyState $ \ctx -> ctx{read_context_aliases_regex=
			(regx, repl):read_context_aliases_regex ctx}
	return ()

read_default_year
 :: (Consable c j, Stream s m Char)
 => ParsecT s (Read_Context c j) m ()
read_default_year = (do
	year <- R.integer_of_digits 10 <$> R.many1 R.digit
	read_hspaces
	read_context_ <- R.getState
	R.setState read_context_{read_context_year=year}
	) <?> "default year"

read_default_unit_and_style
 :: ( Consable c j
    , Stream s m Char )
 => ParsecT s (Read_Context c j) m ()
read_default_unit_and_style = (do
	(sty, amt) <- read_amount
	read_hspaces
	ctx <- R.getState
	let unit = Amount.amount_unit amt
	R.setState ctx
	 { read_context_journal =
		let jnl = read_context_journal ctx in
		jnl
		 { journal_amount_styles =
			let Amount_Styles styles =
				journal_amount_styles jnl in
			Amount_Styles $
			Map.insertWith const unit sty styles
		 }
	 , read_context_unit = Just unit
	 }
	) <?> "default unit and style"

read_include ::
 ( Consable c j
 , Monoid j
 , Stream s (R.Error_State Read_Error IO) Char
 ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
read_include = (do
	sourcepos <- R.getPosition
	filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
	read_context_including <- R.getState
	let journal_including = read_context_journal read_context_including
	let cwd = Path.takeDirectory (R.sourceName sourcepos)
	journal_file <- liftIO $ Path.abs cwd filename
	content <- do
		join $ liftIO $ Exception.catch
		 (liftM return $ Text.IO.readFile journal_file)
		 (return . R.fail_with "include reading" . Read_Error_reading_file journal_file)
	(journal_included, read_context_included) <- do
		liftIO $
			R.runParserT_with_Error
			 (R.and_state $ read_journal_rec journal_file)
			 read_context_including
				 { read_context_journal=
					journal
					 { journal_chart         = journal_chart         journal_including
					 , journal_amount_styles = journal_amount_styles journal_including
					 }
				 }
			 journal_file content
		>>= \x -> case x of
		 Right ok -> return ok
		 Left  ko -> R.fail_with "include parsing" (Read_Error_including_file journal_file ko)
	R.setState $
		read_context_included
		 { read_context_journal=
			journal_including
			 { journal_includes=
				journal_included{journal_files=[journal_file]} :
				journal_includes journal_including
			 , journal_chart=
				journal_chart journal_included
			 , journal_amount_styles=
				journal_amount_styles journal_included
			 }
		 }
	) <?> "include"

-- * Read 'Chart'

read_chart ::
 ( Consable c j
 , Stream s (R.Error_State Read_Error IO) Char
 ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
read_chart = (do
	-- sourcepos <- R.getPosition
	acct <- read_account
	read_hspaces
	_ <- read_comments
	R.new_line
	tags_ <- R.many_separated
	 (R.try (R.skipMany1 R.space_horizontal >> read_tag
	 <* read_hspaces <* read_comments))
	 R.new_line
	R.skipMany R.space
	let chart_accounts =
		TreeMap.singleton acct $
		Account_Tags $
		Tag.from_List tags_
	{-
	let chart_tags =
		foldl'
		 (flip (\(p:|ps, v) ->
			TreeMap.insert mappend
			 (p:|ps `mappend` [v])
			 [acct]))
		 mempty
		 tags_
	-}
	ctx <- R.getState
	let j = read_context_journal ctx
	R.setState $
		ctx{read_context_journal=
			j{journal_chart=
				mappend
				 (journal_chart j)
				 Chart.Chart
					 { Chart.chart_accounts
					 , Chart.chart_anchors = mempty
					 -- , Chart.chart_tags
					 }
			 }
		 }
	) <?> "chart"

-- * Read 'Journal'

read_journal ::
 ( Consable c j
 , Monoid j
 , Stream s (R.Error_State Read_Error IO) Char
 ) => FilePath
 -> ParsecT s (Read_Context c j)
              (R.Error_State Read_Error IO)
              (Journal j)
read_journal filepath = (do
	currentLocalTime <- liftIO $
		Time.utcToLocalTime
		<$> Time.getCurrentTimeZone
		<*> Time.getCurrentTime
	let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
	ctx <- R.getState
	R.setState $ ctx{read_context_year=currentLocalYear}
	read_journal_rec filepath
	) <?> "journal"

read_journal_rec ::
 ( Consable c j
 , Monoid j
 , Stream s (R.Error_State Read_Error IO) Char
 )
 => FilePath
 -> ParsecT s (Read_Context c j)
              (R.Error_State Read_Error IO)
              (Journal j)
read_journal_rec journal_file = do
	last_read_time <- liftIO Date.now
	loop $
		R.choice_try
		 [ jump_comment
		 , jump_directive
		 , jump_transaction
		 , jump_chart
		 ]
	journal_ <- read_context_journal <$> R.getState
	return $
		journal_
		 { journal_files = [journal_file]
		 , journal_includes = List.reverse $ journal_includes journal_
		 , journal_last_read_time = last_read_time
		 }
	where
		loop
		 :: Stream s m Char
		 => ParsecT s u m (ParsecT s u m ())
		 -> ParsecT s u m ()
		loop r = do
			R.skipMany (read_hspaces >> R.new_line)
			_ <- join r
			R.skipMany (read_hspaces >> R.new_line)
			R.try (read_hspaces >> R.eof) <|> loop r
		jump_comment ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Read_Context c j
		 , m ~ R.Error_State Read_Error IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_comment = do
			_ <- R.spaces
			_ <- R.lookAhead (R.try $ R.char read_comment_begin)
			return $ do
				_cmts <- read_comments
				{-
				R.modifyState $ \ctx ->
					let j = read_context_journal ctx in
					ctx{read_context_journal=
						j{journal_content=
							mcons (read_context_filter ctx) cmts $
								journal_content j}}
				-}
				return ()
		jump_directive ::
		 ( Consable c j
		 , Monoid j
		 , Stream s m Char
		 , u ~ Read_Context c j
		 , m ~ R.Error_State Read_Error IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_directive = do
			let choice s = R.string s >> R.skipMany1 R.space_horizontal
			R.choice_try
			 [ choice "Y"        >> return read_default_year
			 , choice "D"        >> return read_default_unit_and_style
			 , choice "!include" >> return read_include
			 ] <?> "directive"
		jump_transaction ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Read_Context c j
		 , m ~ R.Error_State Read_Error IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_transaction = do
			_ <- R.lookAhead $ R.try (R.many1 R.digit >> read_date_separator)
			return $ do
				t <- read_transaction
				R.modifyState $ \ctx ->
					let j = read_context_journal ctx in
					ctx{read_context_journal=
						j{journal_content=
							mcons
							 (read_context_cons ctx $
								Chart.Charted (journal_chart j) t)
							 (journal_content j)}}
		jump_chart ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Read_Context c j
		 , m ~ R.Error_State Read_Error IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_chart = do
			return read_chart

-- * Read

read
 :: (Consable c j, Monoid j)
 => Read_Context c j
 -> FilePath
 -> ExceptT [R.Error Read_Error] IO (Journal j)
read ctx path = do
	ExceptT $
		Exception.catch
		 (liftM Right $ Text.IO.readFile path) $
		 \ko -> return $ Left $
			 [R.Error_Custom (R.initialPos path) $
				Read_Error_reading_file path ko]
	>>= liftIO . R.runParserT_with_Error
	 (read_journal path) ctx path
	>>= \x -> case x of
	 Left  ko -> throwE $ ko
	 Right ok -> ExceptT $ return $ Right ok