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

import           Prelude (Int, Integer, Num(..), fromIntegral)
import           Control.Applicative (Applicative(..))
import           Control.Arrow ((***), first)
import           Data.Bool
import           Data.Char (Char)
import qualified Data.Char as Char
import           Data.Decimal
import           Data.Either (Either(..), either)
import           Data.Eq (Eq(..))
import qualified Control.Exception.Safe as Exn
import qualified System.FilePath.Posix as FilePath
import           Data.Function (($), (.), id, const, flip)
import           Data.Functor ((<$>))
import           System.IO (IO, FilePath)
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           Control.Monad (Monad(..), forM, guard, join, void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (ExceptT(..), throwE)
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..))
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import           Data.String (String, fromString)
import           Data.Text (Text)
import qualified Data.Text as 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           Data.Time.LocalTime (TimeZone(..))
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
                  , tab
                  )
import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
import qualified Text.Parsec.Error.Custom as R
import qualified Text.Parsec.Pos as R
import           Text.Regex.TDFA (Regex)
import qualified Text.Regex.TDFA.Replace.Text as Regex
import           Text.Show (Show)

import qualified Hcompta as H
import           Hcompta.Lib.Consable (Consable(..))
import qualified Data.TreeMap.Strict as TreeMap

import           Hcompta.Ledger.Account
import           Hcompta.Ledger.Amount
import           Hcompta.Ledger.Chart
import           Hcompta.Ledger.Posting
import           Hcompta.Ledger.Transaction
import           Hcompta.Ledger.Journal
import qualified Hcompta.Ledger.Lib.Parsec as R
import qualified Hcompta.Ledger.Lib.FilePath as FilePath

-- * Type 'Context_Read'

data Context_Read c j
 =   Context_Read
 {   context_read_account_prefix :: !(Maybe Account)
 ,   context_read_aliases_exact  :: !(Map Account Account)
 ,   context_read_aliases_joker  :: ![(Account_Joker, Account)]
 ,   context_read_aliases_regex  :: ![(Regex, Account)]
 ,   context_read_cons           :: Charted Transaction -> c
 ,   context_read_date           :: !H.Date
 ,   context_read_journal        :: !(Journal j)
 ,   context_read_unit           :: !(Maybe Unit)
 ,   context_read_year           :: !H.Year
 }

context_read
 :: Consable c j
 => (Charted Transaction -> c)
 -> Journal j
 -> Context_Read c j
context_read context_read_cons context_read_journal =
	Context_Read
	 { context_read_account_prefix = Nothing
	 , context_read_aliases_exact  = mempty
	 , context_read_aliases_joker  = []
	 , context_read_aliases_regex  = []
	 , context_read_cons
	 , context_read_date           = H.date_epoch
	 , context_read_journal
	 , context_read_unit           = Nothing
	 , context_read_year           = H.date_year H.date_epoch
	 }

-- * Type 'Error_Read'

data Error_Read
 =   Error_Read_date Error_Read_Date
 |   Error_Read_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , H.Balance_by_Unit_Sum Account_Section
          (H.Polarized Quantity)
       )]
 |   Error_Read_virtual_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , H.Balance_by_Unit_Sum Account_Section
          (H.Polarized Quantity)
       )]
 |   Error_Read_reading_file FilePath Exn.IOException
 |   Error_Read_including_file FilePath [R.Error Error_Read]
 deriving (Eq, Show)

-- * Read common patterns

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

-- * Read 'Account'

read_account :: Stream s m Char => ParsecT s u m Account
read_account = do
	R.notFollowedBy $ R.spaceHorizontal
	(H.account_from_List <$>) $
		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 =
	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_prefix -> R.parserZero
			 _ | c == read_account_section_sep -> R.parserZero
			 _ | c /= '\t' && R.isSpaceHorizontal c -> do
				_ <- R.notFollowedBy $ R.spaceHorizontal
				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_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.spaceHorizontal
	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.isSpaceHorizontal)
	Regex.of_StringM re

read_account_pattern
 :: Stream s m Char
 => ParsecT s u m Account_Pattern
read_account_pattern =
	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 = (<?> "unit") $
	quoted <|> unquoted
	where
		unquoted :: Stream s m Char => ParsecT s u m Unit
		unquoted =
			(fromString <$>) $
			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 <$>) $
			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.spaceHorizontal
			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
		 ) <- (<?> "quantity") $
			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 ",._")
			 ]
		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 $
		 ( 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 (H.unit_empty, Nothing, Nothing) $ R.try $ do
				s <- R.many R.spaceHorizontal
				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'

data Error_Read_Date
 =   Error_Read_Date_year_or_day_is_missing
 |   Error_Read_Date_invalid_date (Integer, Int, Int)
 |   Error_Read_Date_invalid_time_of_day (Int, Int, Integer)
 deriving (Eq, Show)

-- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
read_date
 :: (Stream s (R.State_Error e m) Char, Monad m)
 => (Error_Read_Date -> e) -> Maybe Integer
 -> ParsecT s u (R.State_Error e m) H.Date
read_date err def_year = (<?> "date") $ 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.parserFailWith "date" $
			err Error_Read_Date_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.parserFailWith "date" $
		err $ Error_Read_Date_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.parserFailWith "date" $
		err $ Error_Read_Date_invalid_time_of_day (hour, minu, sec)
	 Just tod -> return tod
	return $ Time.localTimeToUTC tz (Time.LocalTime day tod)

-- | 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 =
	-- DOC: http://www.timeanddate.com/time/zones/
	-- TODO: only a few time zones are suported below.
	-- TODO: check the timeZoneSummerOnly values
	R.choice
	 [ R.char '_' >>
		R.choice
		 [ R.char 'A' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
			 , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
			 , return (TimeZone ((-1) * 60) False "A")
			 ]
		 , R.char 'B' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
			 , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
			 ]
		 , R.char 'C' >> R.choice
			 [ R.char 'E' >> R.choice
				 [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
				 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
				 ]
			 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
			 , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
			 ]
		 , R.char 'E' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
			 , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
			 ]
		 , R.string "GMT" >> return (TimeZone 0 False "GMT")
		 , R.char 'H' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
			 , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
			 ]
		 , R.char 'M' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
			 , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
			 , return (TimeZone ((-12) * 60) False "M")
			 ]
		 , R.char 'N' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
			 , return (TimeZone (1 * 60) False "N")
			 ]
		 , R.char 'P' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
			 , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
			 ]
		 , R.char 'Y' >> R.choice
			 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
			 , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
			 , return (TimeZone (12 * 60) False "Y")
			 ]
		 , R.char 'Z' >> return (TimeZone 0 False "Z")
		 ]
	 , read_time_zone_digits
	 ]

read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
read_time_zone_digits = do
	sign_ <- read_sign
	hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
	minute <-
		R.option 0 $ do
			void $ R.char ':'
			R.integer_of_digits 10 <$> R.count 2 R.digit
	let tz = TimeZone
		 { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
		 , timeZoneSummerOnly = False
		 , timeZoneName       = Time.timeZoneOffsetString tz
		 }
	return tz

-- * Read 'Comment'

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

-- ** Read 'Comment's

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

-- * 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 H.Tag
read_tag = (<?> "tag") $
	(,)
	 <$> read_tag_path
	 <*> read_tag_value

read_tag_path :: Stream s m Char => ParsecT s u m H.Tag_Path
read_tag_path =
	(NonEmpty.fromList <$>) $
	R.many1 $ R.try read_tag_path_section

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

read_tag_value :: Stream s m Char => ParsecT s u m H.Tag_Value
read_tag_value =
	(fromString <$>) $
	R.manyTill R.anyChar $
		R.lookAhead $
			R.try (R.char read_tag_sep
			 >> R.many R.spaceHorizontal
			 >> void read_tag_path_section)
			<|> R.try (void (R.try R.newline))
			<|> R.eof

-- ** Read 'Tag's

read_tags
 :: Stream s m Char
 => ParsecT s u m (Map H.Tag_Path [H.Tag_Value])
read_tags =
	(Map.fromListWith (flip mappend) .
	List.map (\(p, v) -> (p, [v])) <$>) $
		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 =
	R.many $ R.try $ do
		R.skipMany $
			R.satisfy (\c -> c /= read_tag_value_sep && not (Char.isSpace c))
		R.spaceHorizontal

-- * Read 'Posting'

read_posting ::
 ( Consable c j
 , Monad m
 , Stream s (R.State_Error Error_Read m) Char
 ) => ParsecT s (Context_Read c j)
                (R.State_Error Error_Read m)
                (Posting_Typed Posting)
read_posting = (<?> "posting") $ do
	posting_sourcepos <- R.getPosition
	R.skipMany1 $ R.spaceHorizontal
	posting_status <- read_status
	read_hspaces
	acct <- read_account
	let Posting_Typed type_ posting_account = read_posting_type acct
	posting_amounts <- (<?> "amounts") $
		R.choice_try
		 [ do
			(void R.tab <|> void (R.count 2 R.spaceHorizontal))
			read_hspaces
			amts <-
				R.many_separated read_amount $ do
					read_hspaces
					_ <- R.char read_amount_sep
					read_hspaces
			ctx <- (<$> R.getState) $ \ctx ->
				ctx
				 { context_read_journal=
					let jnl = context_read_journal ctx in
					jnl
					 { journal_amount_styles =
						List.foldl'
						 (\(Amount_Styles styles) (style, amt) ->
							Amount_Styles $
							Map.insertWith (flip mappend) -- NOTE: prefer first style
							 (H.amount_unit amt)
							 style styles)
						 (journal_amount_styles jnl)
						 amts
					 }
				 }
			R.setState ctx
			return $
				Map.fromListWith H.quantity_add $
				List.map
				 (\(_sty, amt) ->
					let unit = H.amount_unit amt in
					( if unit == H.unit_empty
						then fromMaybe unit $ context_read_unit ctx
						else unit
					, H.amount_quantity amt
					)
				 )
				 amts
		 , return mempty
		 ]
	read_hspaces
	-- TODO: balance assertion
	-- TODO: conversion
	posting_comments <- read_comments
	let posting_tags@(H.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
			dates_ <- forM (dates `mappend` fromMaybe [] date2s) $ \s ->
				R.runParserTWithErrorPropagation "tag date" id
				 (read_date Error_Read_date (Just $ context_read_year ctx) <* R.eof) ()
				 (Text.unpack s) s
			case (dates, date2s) of
			 -- NOTE: put hledger's date2 at least in second position
			 ([], Just (_:_)) ->
				return $ context_read_date ctx:dates_
			 _ -> return $ dates_
	return $ Posting_Typed type_ Posting
	 { posting_account
	 , posting_amounts
	 , posting_comments
	 , posting_dates
	 , posting_sourcepos
	 , posting_status
	 , posting_tags = H.Posting_Tags posting_tags
	 }

read_amount_sep :: Char
read_amount_sep = '+'

tags_of_comments :: [Comment] -> H.Tags
tags_of_comments =
	H.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 = (<?> "status") $
	R.try $ do
		read_hspaces
		_ <- (R.char '*' <|> R.char '!')
		return True
	<|> return False

-- | 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) $
		case acct of
		 name:|[] ->
			case Text.stripPrefix virtual_begin name of
			 Just name' -> do
				name'' <- Text.strip <$> Text.stripSuffix virtual_end name'
				guard $ not $ Text.null name''
				Just $ Posting_Typed Posting_Type_Virtual $ name'':|[]
			 Nothing -> do
				name' <- 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 Text.stripStart <$>
				Text.stripPrefix virtual_begin first_name of
			 Just first_name' -> do
				last_name' <- 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' <- Text.stripStart <$>
					Text.stripPrefix virtual_balanced_begin first_name
				last_name'  <- 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.State_Error Error_Read m) Char
 ) => ParsecT s (Context_Read c j)
              (R.State_Error Error_Read m)
              Transaction
read_transaction = (<?> "transaction") $ do
	ctx <- R.getState
	transaction_sourcepos <- R.getPosition
	transaction_comments_before <- do
		cmts <- read_comments
		case cmts of
		 [] -> return []
		 _  -> return cmts <* R.newline
	date_ <- read_date Error_Read_date (Just $ context_read_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			read_hspaces
			_ <- R.char read_transaction_date_sep
			read_hspaces
			R.many_separated
			 (read_date Error_Read_date (Just $ context_read_year ctx)) $
				R.try $ do
					void $ R.many $ R.spaceHorizontal
					void $ R.char read_transaction_date_sep
					R.many $ R.spaceHorizontal
	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 =
		H.Transaction_Tags $
		mappend
		 (tags_of_comments transaction_comments_before)
		 (tags_of_comments transaction_comments_after)
	R.newline
	(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.newline
	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 $ context_read_journal ctx
	transaction_postings <-
		case H.balance_infer_equilibrium postings_unchecked of
		 (_, Left ko) -> R.parserFailWith "transaction: balance_infer_equilibrium" $
			Error_Read_transaction_not_equilibrated styles tr_unchecked ko
		 (_bal, Right ok) -> return ok
	transaction_balanced_virtual_postings <-
		case H.balance_infer_equilibrium balanced_virtual_postings_unchecked of
		 (_, Left ko) -> R.parserFailWith "transaction: balance_infer_equilibrium" $
			Error_Read_virtual_transaction_not_equilibrated styles tr_unchecked ko
		 (_bal, Right ok) -> return ok
	return $
		tr_unchecked
		 { transaction_postings =
			Map.unionsWith mappend
			 [ transaction_postings
			 , (set_virtual_tag <$>) <$> transaction_virtual_postings
			 , (set_virtual_tag <$>) <$> transaction_balanced_virtual_postings
			 ]
		 }
	where
		set_virtual_tag :: Posting -> Posting
		set_virtual_tag
		 p@Posting{posting_tags=H.Posting_Tags (H.Tags attrs)} =
			p{posting_tags = H.Posting_Tags $ H.Tags $ Map.insert ("Virtual":|[]) [] attrs}

read_transaction_date_sep :: Char
read_transaction_date_sep = '='

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

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

-- * Read directives

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

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

read_default_unit_and_style
 :: ( Consable c j
    , Stream s m Char )
 => ParsecT s (Context_Read c j) m ()
read_default_unit_and_style = (<?> "default_unit_and_style") $ do
	(sty, amt) <- read_amount
	read_hspaces
	ctx <- R.getState
	let unit = H.amount_unit amt
	R.setState ctx
	 { context_read_journal =
		let jnl = context_read_journal ctx in
		jnl
		 { journal_amount_styles =
			let Amount_Styles styles =
				journal_amount_styles jnl in
			Amount_Styles $
			Map.insertWith const unit sty styles
		 }
	 , context_read_unit = Just unit
	 }

read_include ::
 ( Consable c j
 , Monoid j
 , Stream s (R.State_Error Error_Read IO) Char
 ) => ParsecT s (Context_Read c j) (R.State_Error Error_Read IO) ()
read_include = (<?> "include") $ do
	sourcepos <- R.getPosition
	filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.newline <|> R.eof))
	context_read_including <- R.getState
	let journal_including = context_read_journal context_read_including
	let cwd = FilePath.takeDirectory (R.sourceName sourcepos)
	journal_file <- liftIO $ FilePath.path_absolute cwd filename
	content <-
		join $ liftIO $ Exn.catch
		 (return <$> Text.IO.readFile journal_file)
		 (return . R.parserFailWith "include reading" . Error_Read_reading_file journal_file)
	(journal_included, context_read_included) <- do
		lr <- liftIO $
			R.runParserTWithError
			 (R.and_state $ read_journal_rec journal_file)
			 context_read_including
				 { context_read_journal =
					journal
					 { journal_chart         = journal_chart         journal_including
					 , journal_amount_styles = journal_amount_styles journal_including
					 }
				 }
			 journal_file content
		case lr of
		 Right ok -> return ok
		 Left  ko -> R.parserFailWith "include parsing" $
			Error_Read_including_file journal_file ko
	R.setState $
		context_read_included
		 { context_read_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
			 }
		 }

-- * Read 'Chart'

read_chart ::
 ( Consable c j
 , Stream s (R.State_Error Error_Read IO) Char
 ) => ParsecT s (Context_Read c j) (R.State_Error Error_Read IO) ()
read_chart = (<?> "chart") $ do
	-- sourcepos <- R.getPosition
	acct <- read_account
	read_hspaces
	_ <- read_comments
	R.newline
	tags_ <- R.many_separated
	 (R.try (R.skipMany1 R.spaceHorizontal >> read_tag
	 <* read_hspaces <* read_comments))
	 R.newline
	R.skipMany R.space
	let chart_accounts =
		TreeMap.singleton acct $
		H.Account_Tags $
		H.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 = context_read_journal ctx
	R.setState $
		ctx{context_read_journal=
			j{journal_chart=
				mappend
				 (journal_chart j)
				 Chart
					 { chart_accounts
					 -- , chart_tags
					 }
			 }
		 }

-- * Read 'Journal'

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

read_journal_rec ::
 ( Consable c j
 , Monoid j
 , Stream s (R.State_Error Error_Read IO) Char
 )
 => FilePath
 -> ParsecT s (Context_Read c j)
              (R.State_Error Error_Read IO)
              (Journal j)
read_journal_rec journal_file = do
	last_read_time <- liftIO H.date_now
	loop $
		R.choice_try
		 [ jump_comment
		 , jump_directive
		 , jump_transaction
		 , jump_chart
		 ]
	journal_ <- context_read_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.newline)
			_ <- join r
			R.skipMany (read_hspaces >> R.newline)
			R.try (read_hspaces >> R.eof) <|> loop r
		jump_comment ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Context_Read c j
		 , m ~ R.State_Error Error_Read 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 = context_read_journal ctx in
					ctx{context_read_journal=
						j{journal_content=
							mcons (context_read_filter ctx) cmts $
								journal_content j}}
				-}
				return ()
		jump_directive ::
		 ( Consable c j
		 , Monoid j
		 , Stream s m Char
		 , u ~ Context_Read c j
		 , m ~ R.State_Error Error_Read IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_directive = do
			let choice s = R.string s >> R.skipMany1 R.spaceHorizontal
			(<?> "directive") $
				R.choice_try
				 [ choice "Y"        >> return read_default_year
				 , choice "D"        >> return read_default_unit_and_style
				 , choice "!include" >> return read_include
				 ]
		jump_transaction ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Context_Read c j
		 , m ~ R.State_Error Error_Read 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 = context_read_journal ctx in
					ctx{context_read_journal=
						j{journal_content=
							mcons
							 (context_read_cons ctx $
								Charted (journal_chart j) t)
							 (journal_content j)}}
		jump_chart ::
		 ( Consable c j
		 , Stream s m Char
		 , u ~ Context_Read c j
		 , m ~ R.State_Error Error_Read IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_chart =
			return read_chart

-- * Read

read_file
 :: (Consable c j, Monoid j)
 => Context_Read c j
 -> FilePath
 -> ExceptT [R.Error Error_Read] IO (Journal j)
read_file ctx path =
	ExceptT
	 (Exn.catch
		 (Right <$> Text.IO.readFile path) $
		 \ko -> return $ Left $
			 [R.Error_Custom (R.initialPos path) $
				Error_Read_reading_file path ko])
	>>= liftIO . R.runParserTWithError
	 (read_journal path) ctx path
	>>= \x -> case x of
	 Left  ko -> throwE $ ko
	 Right ok -> ExceptT $ return $ Right ok