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

import           Prelude (Int, Integer, Num(..), fromIntegral)
import           Control.Applicative ((<$>), (<*>), (<*))
import           Data.Bool
import           Data.Char (Char)
import qualified Data.Char as Char
import           Data.Decimal
import           Data.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)
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(..), 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 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.Show (Show)
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           Data.Time.LocalTime (TimeZone(..))
import qualified Data.Time.LocalTime as Time
import qualified Data.TreeMap.Strict as TreeMap
import           Data.Typeable ()

import qualified Hcompta as H
import qualified Hcompta.JCC.Lib.FilePath as FilePath
import qualified Hcompta.JCC.Lib.Parsec as R
import           Hcompta.Lib.Consable (Consable(..))

import Hcompta.JCC.Account
import Hcompta.JCC.Amount
import Hcompta.JCC.Chart
import Hcompta.JCC.Posting
import Hcompta.JCC.Transaction
import Hcompta.JCC.Journal

-- * 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_account_anchor_unknown R.SourcePos H.Account_Anchor
 |   Error_Read_account_anchor_not_unique R.SourcePos H.Account_Anchor
 |   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 (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 = (<?> "eol") $
	(<|>)
	 (void $ R.char '\n')
	 (void $ R.try $ R.string "\r\n")

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 =
	(H.account_from_List <$>) $
	R.many1 $ do
		void $ 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.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.is_space_horizontal)
	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 '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 H.Account_Tag
read_account_tag = (<?> "account_tag") $ do
	void $ R.char read_account_tag_prefix
	p <- read_name
	H.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)
			 ]))))

-- ** 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 H.Account_Anchor
read_account_anchor = (<?> "account_anchor") $ do
	void $ R.char read_account_anchor_prefix
	p <- read_name
	ps <- R.many (R.char read_account_anchor_sep >> read_name)
	return $ H.account_anchor (p:|ps)

-- ** 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 = (<?> "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 = (<?> "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 $
		 ( 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 (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
		void $ 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
			void $ 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
				void $ 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
	void $ R.char read_comment_prefix
	(fromString <$>) $
		R.manyTill R.anyChar (R.lookAhead (R.try read_eol <|> R.eof))

-- ** Read 'Comment's

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

-- * 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
read_posting = (<?> "posting") $ do
	posting_sourcepos <- R.getPosition
	(  posting_account
	 , posting_account_anchor ) <-
		(<?> "posting_account") $
		R.choice_try
		 [ (,Nothing) <$> read_account
		 , do
			anchor <- read_account_anchor
			ctx <- R.getState
			let anchors = chart_anchors $
				journal_chart $ context_read_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.parserFailWith "account anchor" $
				Error_Read_account_anchor_unknown posting_sourcepos anchor
		 ]
	posting_amounts <-
		R.option mempty $ R.try $ do
			(style, amt) <- read_hspaces1 >> read_amount
			ctx <- (<$> R.getState) $ \ctx ->
				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 mappend
						 (amount_unit amt)
						 style styles
					 }
				 }
			R.setState ctx
			return $
				let unit =
					case amount_unit amt of
					 u | u == H.unit_empty ->
						fromMaybe u $ context_read_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 = H.Posting_Anchors posting_anchors
	 , posting_tags = H.Posting_Tags posting_tags
	 , posting_comments
	 , posting_dates = []
	 , posting_sourcepos
	 }

read_posting_attributes
 :: Stream s (R.State_Error Error_Read m) Char
 => ParsecT s (Context_Read c j)
            (R.State_Error Error_Read m)
            (H.Tags, H.Anchors, [Comment])
read_posting_attributes =
	R.option mempty $ R.try $ do
		void $ R.many (R.try (read_hspaces >> read_eol))
		R.choice_try
		 [ read_hspaces1 >> read_posting_anchor >>= \(H.Posting_Anchor p) -> do
			(tags, H.Anchors anchors, cmts) <- read_posting_attributes
			return (tags, H.Anchors (Map.insert p () anchors), cmts)
		 , read_hspaces1 >> read_posting_tag >>= \(H.Posting_Tag (p, v)) -> do
			(H.Tags tags, anchors, cmts) <- read_posting_attributes
			return (H.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 H.Posting_Tag
read_posting_tag = (<?> "posting_tag") $
	(<$> read_transaction_tag) $ \(H.Transaction_Tag t) ->
		H.Posting_Tag t

-- ** Read 'Posting_Anchor'

read_posting_anchor :: Stream s m Char => ParsecT s u m H.Posting_Anchor
read_posting_anchor = (<?> "posting_anchor") $ do
	void $ R.char read_transaction_anchor_prefix
	H.posting_anchor .
	 NonEmpty.fromList <$>
		R.many1 (R.char read_transaction_anchor_sep >> read_name)

-- * 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
	transaction_sourcepos <- R.getPosition
	ctx <- R.getState
	date_ <- read_date Error_Read_date (Just $ context_read_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			void read_hspaces
			void $ R.char read_transaction_date_sep
			void read_hspaces
			R.many_separated
			 (read_date Error_Read_date (Just $ context_read_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 = H.Transaction_Anchors transaction_anchors
		 , transaction_tags = H.Transaction_Tags transaction_tags
		 , transaction_comments
		 , transaction_dates
		 , transaction_wording
		 , transaction_postings = transaction_postings_unchecked
		 , transaction_sourcepos
		 }
	let styles = journal_amount_styles $ context_read_journal ctx
	transaction_postings <-
		case H.balance_infer_equilibrium transaction_postings_unchecked of
		 (_, Left ko) -> R.parserFailWith "transaction infer_equilibrium" $
			Error_Read_transaction_not_equilibrated styles transaction_unchecked ko
		 (_bal, Right ok) -> return ok
	return
		transaction_unchecked
		 { transaction_postings
		 }

read_transaction_attributes
 :: Stream s (R.State_Error Error_Read m) Char
 => ParsecT s (Context_Read c j)
            (R.State_Error Error_Read m)
            (H.Tags, H.Anchors, [Comment])
read_transaction_attributes =
	R.option mempty $ R.try $ do
		void $ R.many (R.try (read_hspaces >> read_eol))
		R.choice_try
		 [ read_hspaces1 >> read_transaction_anchor >>= \(H.Transaction_Anchor p) -> do
			(tags, H.Anchors anchors, cmts) <- read_transaction_attributes
			return (tags, H.Anchors (Map.insert p () anchors), cmts)
		 , read_hspaces1 >> read_transaction_tag >>= \(H.Transaction_Tag (p, v)) -> do
			(H.Tags tags, anchors, cmts) <- read_transaction_attributes
			return (H.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.State_Error Error_Read m) Char)
 => ParsecT s (Context_Read c j) (R.State_Error Error_Read 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 =
	(<?> "wording") $
	read_transaction_tag_value

-- ** 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 H.Transaction_Anchor
read_transaction_anchor = (<?> "transaction_anchor") $ do
	void $ R.char read_transaction_anchor_prefix
	p <- read_name
	H.transaction_anchor . (:|) p
	 <$> R.many (R.char read_transaction_anchor_sep >> read_name)

-- ** 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 H.Transaction_Tag
read_transaction_tag = (<?> "transaction_tag") $ do
	void $ R.char read_transaction_tag_prefix
	p <- read_name
	H.transaction_tag . (:|) p
	 <$> R.many (R.char read_transaction_tag_sep >> read_name)
	 <*> R.option "" (R.try $ do
		read_hspaces
		void $ R.char read_transaction_tag_value_prefix
		read_hspaces
		read_transaction_tag_value)

read_transaction_tag_value
 :: Stream s m Char
 => ParsecT s u m H.Tag_Value
read_transaction_tag_value =
	(fromString . List.concat <$>) $
	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 (Context_Read c j) m ()
read_directive_alias = do
	void $ R.string "alias"
	R.skipMany1 R.spaceHorizontal
	pat <- read_account_pattern
	read_hspaces
	void $ 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 read_eol <|> 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
	void read_eol
	( chart_tags
	 , chart_anchors
	 , _chart_comments ) <-
		fields acct mempty mempty mempty
	let chart_accounts =
		TreeMap.singleton acct $
		H.Account_Tags chart_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
					 , chart_anchors
					 }
			 }
		 }
	where
		fields
		 acct
		 tags@(H.Tags tagm)
		 anchors
		 cmts =
			R.choice_try
			 [ read_hspaces1 >> read_account_comment >>= \c ->
				fields acct tags anchors (c:cmts)
			 , read_hspaces1 >> read_account_tag >>= \(H.Account_Tag (p, v)) ->
				fields acct (H.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.parserFailWith "account anchor not unique"
					 (Error_Read_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.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 >> read_eol)
			void $ 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 ~ Context_Read c j
		 , m ~ R.State_Error Error_Read IO
		 )
		 => ParsecT s u m (ParsecT s u m ())
		jump_comment = do
			void R.spaces
			void $ 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 = (<?> "directive") $ do
			let choice s = R.string s >> R.skipMany1 R.spaceHorizontal
			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
			void $ 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