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

import           Control.Applicative ((<$>), (<*>), (<*))
import qualified Control.Exception as Exception
import           Control.Monad (Monad(..), guard, liftM, join, 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(..))
import           Data.Eq (Eq(..))
import           Data.Ord (Ord(..))
import           Data.Function (($), (.), id, const, flip)
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(..), maybe)
import           Data.Monoid (Monoid(..))
import           Data.String (String, fromString)
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           Hcompta.Anchor ( Anchors(..) )
import qualified Hcompta.Account as Account
import           Hcompta.Account ( Account_Tags(..)
                                 , Account_Tag(..)
                                 , Account_Anchor(..)
                                 )
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 qualified Hcompta.Posting as Posting
import           Hcompta.Posting ( Posting_Tag(..)
                                 , Posting_Tags(..)
                                 , Posting_Anchor(..)
                                 , Posting_Anchors(..)
                                 )
import           Hcompta.Tag (Tags(..))
import qualified Hcompta.Tag as Tag
import           Hcompta.Transaction ( Transaction_Tags(..)
                                     , Transaction_Tag(..)
                                     , Transaction_Anchor(..)
                                     , Transaction_Anchors(..)
                                     )
import qualified Hcompta.Transaction as Transaction
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.JCC

-- * 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_account_anchor_unknown R.SourcePos Account_Anchor
 |   Read_Error_account_anchor_not_unique R.SourcePos Account_Anchor
 |   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

is_space :: Char -> Bool
is_space c =
	case Char.generalCategory c of
	 Char.Space -> True
	 _ -> False
read_space :: Stream s m Char => ParsecT s u m Char
read_space = R.satisfy is_space

is_char :: Char -> Bool
is_char c =
	case Char.generalCategory c of
	 Char.UppercaseLetter      -> True
	 Char.LowercaseLetter      -> True
	 Char.TitlecaseLetter      -> True
	 Char.ModifierLetter       -> True
	 Char.OtherLetter          -> True
	 
	 Char.NonSpacingMark       -> True
	 Char.SpacingCombiningMark -> True
	 Char.EnclosingMark        -> True
	 
	 Char.DecimalNumber        -> True
	 Char.LetterNumber         -> True
	 Char.OtherNumber          -> True
	 
	 Char.ConnectorPunctuation -> True
	 Char.DashPunctuation      -> True
	 Char.OpenPunctuation      -> True
	 Char.ClosePunctuation     -> True
	 Char.InitialQuote         -> True
	 Char.FinalQuote           -> True
	 Char.OtherPunctuation     -> True
	 
	 Char.MathSymbol           -> True
	 Char.CurrencySymbol       -> True
	 Char.ModifierSymbol       -> True
	 Char.OtherSymbol          -> True
	 
	 Char.Space                -> False
	 Char.LineSeparator        -> False
	 Char.ParagraphSeparator   -> False
	 Char.Control              -> False
	 Char.Format               -> False
	 Char.Surrogate            -> False
	 Char.PrivateUse           -> False
	 Char.NotAssigned          -> False
read_char :: Stream s m Char => ParsecT s u m Char
read_char = R.satisfy is_char

is_char_active :: Char -> Bool
is_char_active c =
	case c of
	 '/' -> True
	 '\\' -> True
	 '!' -> True
	 '?' -> True
	 '\'' -> True
	 '"' -> True
	 '&' -> True
	 '|' -> True
	 '-' -> True
	 '+' -> True
	 '.' -> True
	 ':' -> True
	 '=' -> True
	 '<' -> True
	 '>' -> True
	 '@' -> True
	 '#' -> True
	 '(' -> True
	 ')' -> True
	 '[' -> True
	 ']' -> True
	 '{' -> True
	 '}' -> True
	 '~' -> True
	 '*' -> True
	 '^' -> True
	 ';' -> True
	 ',' -> True
	 _  -> False
read_char_active :: Stream s m Char => ParsecT s u m Char
read_char_active = R.satisfy is_char_active

is_char_passive :: Char -> Bool
is_char_passive c = is_char c && not (is_char_active c)
read_char_passive :: Stream s m Char => ParsecT s u m Char
read_char_passive = R.satisfy is_char_passive

read_word :: Stream s m Char => ParsecT s u m Text
read_word = fromString <$> R.many read_char_passive

read_words :: Stream s m Char => ParsecT s u m [Text]
read_words = R.many_separated read_word read_space

read_name :: Stream s m Char => ParsecT s u m Text
read_name = fromString <$> R.many1 read_char_passive

read_tabulation :: Stream s m Char => ParsecT s u m Char
read_tabulation = R.char '\t'

read_hspace :: Stream s m Char => ParsecT s u m Char
read_hspace = R.char ' '

read_hspaces :: Stream s m Char => ParsecT s u m ()
read_hspaces = void $ R.many read_hspace

read_hspaces1 :: Stream s m Char => ParsecT s u m ()
read_hspaces1 = void $ R.many1 read_hspace

read_eol :: Stream s m Char => ParsecT s u m ()
read_eol = ((R.<|>) (void $ R.char '\n') (void $ R.try $ R.string "\r\n")) <?> "eol"

read_line :: Stream s m Char => ParsecT s u m Text
read_line = fromString <$>
	R.manyTill read_char (R.lookAhead read_eol <|> R.eof)
	-- R.many (R.notFollowedBy eol >> char)

-- * Read 'Account'

read_account :: Stream s m Char => ParsecT s u m Account
read_account = do
	Account.from_List <$> do
	R.many1 (R.char read_account_section_sep >> read_account_section)

read_account_section :: Stream s m Char => ParsecT s u m Text
read_account_section = read_name

read_account_section_sep :: Char
read_account_section_sep = '/'

read_comment_prefix :: Char
read_comment_prefix = ';'

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

-- ** Read 'Account_Tag'
read_account_tag_prefix :: Char
read_account_tag_prefix = '.'
read_account_tag_sep :: Char
read_account_tag_sep = ':'
read_account_tag_value_prefix :: Char
read_account_tag_value_prefix = '='

read_account_tag :: Stream s m Char => ParsecT s u m Account_Tag
read_account_tag = (do
	_ <- R.char read_account_tag_prefix
	p <- read_name
	Account.tag
	 <$> (:|) p <$>
		R.many (R.char read_account_tag_sep >> read_name)
	 <*> (fromString <$>
		R.option ""
		 (read_hspaces >> R.char read_transaction_tag_value_prefix >> read_hspaces >>
			(List.concat <$> R.many (R.choice
			 [ R.string [read_account_tag_prefix   , read_account_tag_prefix]    >> return [read_account_tag_prefix]
			 , R.string [read_account_anchor_prefix, read_account_anchor_prefix] >> return [read_account_anchor_prefix]
			 , (\s c -> mappend s [c])
				 <$> R.many read_space
				 <*> R.satisfy (\c ->
					    c /= read_account_tag_prefix
					 && c /= read_account_anchor_prefix
					 && is_char c)
			 ]))))
	) <?> "account_tag"

-- ** Read 'Account_Anchor'
read_account_anchor_prefix :: Char
read_account_anchor_prefix = '~'
read_account_anchor_sep :: Char
read_account_anchor_sep = ':'

read_account_anchor :: Stream s m Char => ParsecT s u m Account_Anchor
read_account_anchor = (do
	_ <- R.char read_account_anchor_prefix
	p <- read_name
	ps <- R.many (R.char read_account_anchor_sep >> read_name)
	return $ Account.anchor (p:|ps)
	) <?> "account_anchor"

-- ** Read 'Account' 'Comment'
read_account_comment :: Stream s m Char => ParsecT s u m Comment
read_account_comment = read_comment

-- * 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
		 }
		)) <?> "amount"

-- | 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 <- R.char read_date_ymd_sep
	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: "-".
read_date_ymd_sep :: Char
read_date_ymd_sep = '-'

-- | 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_prefix
	fromString <$> do
	R.manyTill R.anyChar (R.lookAhead (R.try read_eol <|> 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
		 (read_eol >> read_hspaces)
	<|> return []
	) <?> "comments"

-- * 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
read_posting = (do
	posting_sourcepos <- R.getPosition
	(  posting_account
	 , posting_account_anchor ) <-
		R.choice_try
		 [ (,Nothing) <$> read_account
		 , do
			anchor <- read_account_anchor
			ctx <- R.getState
			let anchors = Chart.chart_anchors $
				journal_chart $ read_context_journal ctx
			case Map.lookup anchor anchors of
			 Just (a:|as) -> do
				sa <- R.option Nothing $ Just <$> read_account
				return $ ( a:|mappend as (maybe [] NonEmpty.toList sa)
				         , Just (anchor, sa) )
			 Nothing -> R.fail_with "account anchor"
				 (Read_Error_account_anchor_unknown posting_sourcepos anchor)
		 ] <?> "posting_account"
	posting_amounts <-
		R.option mempty $ R.try $ do
			(style, amt) <- read_hspaces1 >> read_amount
			ctx <- flip liftM R.getState $ \ctx ->
				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 mappend
						 (amount_unit amt)
						 style styles
					 }
				 }
			R.setState ctx
			return $
				let unit =
					case amount_unit amt of
					 u | u == Unit.unit_empty ->
						maybe u id $ read_context_unit ctx
					 u -> u in
				Map.singleton unit $
				amount_quantity amt
	(  posting_tags
	 , posting_anchors
	 , posting_comments ) <- read_posting_attributes
	return $ Posting
	 { posting_account
	 , posting_account_anchor
	 , posting_amounts
	 , posting_anchors = Posting_Anchors posting_anchors
	 , posting_tags = Posting_Tags posting_tags
	 , posting_comments
	 , posting_dates = []
	 , posting_sourcepos
	 }
	) <?> "posting"

read_posting_attributes
 :: Stream s (R.Error_State Read_Error m) Char
 => ParsecT s (Read_Context c j)
            (R.Error_State Read_Error m)
            (Tags, Anchors, [Comment])
read_posting_attributes =
	R.option mempty $ R.try $ do
		_ <- R.many (R.try (read_hspaces >> read_eol))
		R.choice_try
		 [ read_hspaces1 >> read_posting_anchor >>= \(Posting_Anchor p) -> do
			(tags, Anchors anchors, cmts) <- read_posting_attributes
			return (tags, Anchors (Map.insert p () anchors), cmts)
		 , read_hspaces1 >> read_posting_tag >>= \(Posting_Tag (p, v)) -> do
			(Tags tags, anchors, cmts) <- read_posting_attributes
			return (Tags (Map.insertWith mappend p [v] tags), anchors, cmts)
		 , read_hspaces >> read_comment >>= \c -> do
			(tags, anchors, cmts) <- read_posting_attributes
			return (tags, anchors, c:cmts)
		 ]

read_amount_sep :: Char
read_amount_sep = '+'

read_posting_comment :: Stream s m Char => ParsecT s u m Comment
read_posting_comment = read_comment

-- ** Read 'Posting_Tag'
read_posting_tag :: Stream s m Char => ParsecT s u m Posting_Tag
read_posting_tag =
	(liftM (\(Transaction_Tag t) -> Posting_Tag t)
	 read_transaction_tag) <?> "posting_tag"

-- ** Read 'Posting_Anchor'
read_posting_anchor :: Stream s m Char => ParsecT s u m Posting_Anchor
read_posting_anchor = (do
	_ <- R.char read_transaction_anchor_prefix
	Posting.anchor <$>
		NonEmpty.fromList <$>
		R.many1 (R.char read_transaction_anchor_sep >> read_name)
	) <?> "posting_anchor"

-- * 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
	transaction_sourcepos <- R.getPosition
	ctx <- R.getState
	date_ <- read_date Read_Error_date (Just $ read_context_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			_ <- read_hspaces
			_ <- R.char read_transaction_date_sep
			_ <- read_hspaces
			R.many_separated
			 (read_date Read_Error_date (Just $ read_context_year ctx)) $
				R.try $
					read_hspaces
					>> R.char read_transaction_date_sep
					>> read_hspaces
	let transaction_dates = (date_, dates_)
	read_hspaces1
	transaction_wording <- read_transaction_wording
	(  transaction_tags
	 , transaction_anchors
	 , transaction_comments
	 ) <- read_transaction_attributes
	transaction_postings_unchecked <-
		postings_by_account <$> read_postings
	let transaction_unchecked =
		Transaction
		 { transaction_anchors = Transaction_Anchors transaction_anchors
		 , transaction_tags = Transaction_Tags transaction_tags
		 , transaction_comments
		 , transaction_dates
		 , transaction_wording
		 , transaction_postings = transaction_postings_unchecked
		 , transaction_sourcepos
		 }
	let styles = journal_amount_styles $ read_context_journal ctx
	transaction_postings <-
		case Balance.infer_equilibrium transaction_postings_unchecked of
		 (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
			Read_Error_transaction_not_equilibrated styles transaction_unchecked ko
		 (_bal, Right ok) -> return ok
	return $
		transaction_unchecked
		 { transaction_postings
		 }
	) <?> "transaction"

read_transaction_attributes
 :: Stream s (R.Error_State Read_Error m) Char
 => ParsecT s (Read_Context c j)
            (R.Error_State Read_Error m)
            (Tags, Anchors, [Comment])
read_transaction_attributes =
	R.option mempty $ R.try $ do
		_ <- R.many (R.try (read_hspaces >> read_eol))
		R.choice_try
		 [ read_hspaces1 >> read_transaction_anchor >>= \(Transaction_Anchor p) -> do
			(tags, Anchors anchors, cmts) <- read_transaction_attributes
			return (tags, Anchors (Map.insert p () anchors), cmts)
		 , read_hspaces1 >> read_transaction_tag >>= \(Transaction_Tag (p, v)) -> do
			(Tags tags, anchors, cmts) <- read_transaction_attributes
			return (Tags (Map.insertWith mappend p [v] tags), anchors, cmts)
		 , read_hspaces >> read_comment >>= \c -> do
			(tags, anchors, cmts) <- read_transaction_attributes
			return (tags, anchors, c:cmts)
		 ]

read_postings ::
 (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]
read_postings = R.many $ R.try (read_hspaces >> read_eol >> read_hspaces1 >> read_posting)

read_transaction_date_sep :: Char
read_transaction_date_sep = '='

read_transaction_wording
 :: Stream s m Char
 => ParsecT s u m Wording
read_transaction_wording =
	fromString . List.concat <$> (do
	R.many1 $ R.try $ do
		s <- R.many read_hspace
		c <- R.satisfy $ \c ->
			c /= read_transaction_tag_prefix &&
			c /= read_transaction_anchor_prefix &&
			c /= read_comment_prefix &&
			is_char c
		cs <- R.many (R.satisfy is_char)
		return $ mappend s (c:cs)
	 ) <?> "wording"

-- ** Read 'Transaction_Anchor'

read_transaction_anchor_prefix :: Char
read_transaction_anchor_prefix = '@'
read_transaction_anchor_sep :: Char
read_transaction_anchor_sep = ':'

read_transaction_anchor :: Stream s m Char => ParsecT s u m Transaction_Anchor
read_transaction_anchor = (do
	_ <- R.char read_transaction_anchor_prefix
	p <- read_name
	Transaction.anchor <$>
		(:|) p <$>
		R.many (R.char read_transaction_anchor_sep >> read_name)
	) <?> "transaction_anchor"

-- ** Read 'Transaction_Tag'

read_transaction_tag_prefix :: Char
read_transaction_tag_prefix = '#'
read_transaction_tag_sep :: Char
read_transaction_tag_sep = ':'
read_transaction_tag_value_prefix :: Char
read_transaction_tag_value_prefix = '='

read_transaction_tag :: Stream s m Char => ParsecT s u m Transaction_Tag
read_transaction_tag = (do
	_ <- R.char read_transaction_tag_prefix
	p <- read_name
	Transaction.tag
	 <$>
		(:|) p <$>
		R.many (R.char read_transaction_tag_sep >> read_name)
	 <*> (R.option "" $ R.try $ do
				read_hspaces
				_ <- R.char read_transaction_tag_value_prefix
				read_hspaces
				read_transaction_tag_value)
	) <?> "transaction_tag"
	where

read_transaction_tag_value
 :: Stream s m Char
 => ParsecT s u m Tag.Value
read_transaction_tag_value =
	fromString . List.concat <$> do
	R.many1 $ R.try $ do
		s <- R.many read_hspace
		c <- R.satisfy $ \c ->
			c /= read_transaction_tag_prefix &&
			c /= read_transaction_anchor_prefix &&
			c /= read_comment_prefix &&
			is_char c
		cs <- R.many (R.satisfy is_char)
		return $ mappend s (c:cs)

-- ** Read 'Transaction' 'Comment'
read_transaction_comment :: Stream s m Char => ParsecT s u m Comment
read_transaction_comment = read_comment

-- * 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 read_eol <|> 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_eol
	( chart_tags
	 , chart_anchors
	 , _chart_comments ) <-
		fields acct mempty mempty mempty
	let chart_accounts =
		TreeMap.singleton acct $
		Account_Tags chart_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_tags
					 , Chart.chart_anchors
					 }
			 }
		 }
	) <?> "chart"
	where
		fields
		 acct
		 tags@(Tags tagm)
		 anchors
		 cmts =
			R.choice_try
			 [ read_hspaces1 >> read_account_comment >>= \c ->
				fields acct tags anchors (c:cmts)
			 , read_hspaces1 >> read_account_tag >>= \(Account_Tag (p, v)) ->
				fields acct (Tags $ Map.insertWith mappend p [v] tagm) anchors cmts
			 , read_hspaces1 >> read_account_anchor >>= \anchor ->
				case Map.insertLookupWithKey (\_k n _o -> n) anchor acct anchors of
				 (Nothing, m) -> fields acct tags m cmts
				 (Just _, _) -> do
					sourcepos <- R.getPosition
					R.fail_with "account anchor not unique"
					 (Read_Error_account_anchor_not_unique sourcepos anchor)
			 , read_hspaces >> read_eol >>
				fields acct tags anchors cmts
			 , return (tags, anchors, cmts)
			 ]

-- * 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 >> read_eol)
			_ <- join r
			R.skipMany (read_hspaces >> read_eol)
			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_prefix)
			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 >> R.char read_date_ymd_sep)
			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