{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.LCC.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, flip)
import           System.IO (IO, FilePath)
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), fromMaybe, maybe)
import           Data.NonNull (NonNull)
import qualified Data.NonNull as NonNull
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           Data.Semigroup (Semigroup(..))
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.LCC.Lib.FilePath as FilePath
import qualified Hcompta.LCC.Lib.Parsec as R
import           Hcompta.Lib.Consable (Consable(..))

import Hcompta.LCC.Account
import Hcompta.LCC.Name
import Hcompta.LCC.Tag
import Hcompta.LCC.Anchor
import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
import Hcompta.LCC.Posting
import Hcompta.LCC.Transaction
import Hcompta.LCC.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           :: !Date
 ,   context_read_journal        :: !(Journal j)
 ,   context_read_unit           :: !(Maybe Unit)
 ,   context_read_year           :: !(H.Date_Year Date)
 }

context_read
 :: (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::Date)
	 }

-- * Type 'Error_Read'
data Error_Read
 =   Error_Read_account_anchor_unknown R.SourcePos Account_Anchor
 |   Error_Read_account_anchor_not_unique R.SourcePos Account_Anchor
 |   Error_Read_date Error_Read_Date
 |   Error_Read_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , H.SumByUnit (NonEmpty Account_Section) (H.Polarized Quantity)
       )]
 |   Error_Read_virtual_transaction_not_equilibrated
      Amount_Styles
      Transaction
      [( Unit
       , H.SumByUnit (NonEmpty 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 = (== ' ')
read_space :: Stream s m Char => ParsecT s u m Char
read_space = R.satisfy is_space
read_spaces :: Stream s m Char => ParsecT s u m [Char]
read_spaces = R.many read_space
read_spaces1 :: Stream s m Char => ParsecT s u m (NonNull [Char])
read_spaces1 = NonNull.impureNonNull <$> R.many1 read_space

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

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 Char.generalCategory c of
	 Char.UppercaseLetter      -> False
	 Char.LowercaseLetter      -> False
	 Char.TitlecaseLetter      -> False
	 Char.ModifierLetter       -> False
	 Char.OtherLetter          -> False
	 
	 Char.NonSpacingMark       -> False
	 Char.SpacingCombiningMark -> False
	 Char.EnclosingMark        -> False
	 
	 Char.DecimalNumber        -> False
	 Char.LetterNumber         -> False
	 Char.OtherNumber          -> False
	 
	 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
	{-
	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
	 _  ->
		case Char.generalCategory c of
		 Char.CurrencySymbol -> 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 =
	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 -> False
	 Char.DashPunctuation      -> False
	 Char.OpenPunctuation      -> False
	 Char.ClosePunctuation     -> False
	 Char.InitialQuote         -> False
	 Char.FinalQuote           -> False
	 Char.OtherPunctuation     -> False
	 
	 Char.MathSymbol           -> False
	 Char.CurrencySymbol       -> False
	 Char.ModifierSymbol       -> False
	 Char.OtherSymbol          -> False
	 
	 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_passive :: Stream s m Char => ParsecT s u m Char
read_char_passive = R.satisfy is_char_passive

is_char_attribut :: Char -> Bool
is_char_attribut c =
	case c of
	 '/' -> True
	 '#' -> True
	 ':' -> True
	 '@' -> True
	 '~' -> True
	 '=' -> True
	 _ -> False

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

read_name :: Stream s m Char => ParsecT s u m Name
read_name =
	Name . fromString
	 <$> R.many1 (R.satisfy $ \c ->
		Char.isLetter c ||
		Char.isMark   c ||
		Char.isNumber c)

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

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_words :: Stream s m Char => ParsecT s u m Text
read_words =
	(fromString . List.concat <$>) $
	R.many $ R.try $
		(<>)
		 <$> read_spaces
		 <*> R.many1 read_char
	--R.manyTill (R.satisfy $ \c -> is_char c || is_uspace c)
	-- (R.lookAhead read_eol <|> R.eof)
	-- R.many (R.notFollowedBy eol >> char)

-- * Read 'Account'
char_account_sep :: Char
char_account_sep = '/'

read_account :: Stream s m Char => ParsecT s u m Account
read_account =
	(Account . NonNull.impureNonNull <$>) $
	R.many1 $ do
		void $ R.char char_account_sep
		read_account_section

read_account_section :: Stream s m Char => ParsecT s u m Name
read_account_section =
	Name . fromString
	 <$> R.many1 (R.satisfy $ \c ->
		not (is_char_attribut c) &&
		is_char c)

{-
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 char_account_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 char_account_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_Tag'
char_account_tag_prefix :: Char
char_account_tag_prefix = '#'

read_account_tag :: Stream s m Char => ParsecT s u m Account_Tag
read_account_tag =
	(<?> "account_tag") $ Account_Tag
	 <$> read_tag char_account_tag_prefix

-- ** Read 'Account_Anchor'
char_account_anchor_prefix :: Char
char_account_anchor_prefix = '~'
char_account_anchor_sep :: Char
char_account_anchor_sep = ':'

read_account_anchor :: Stream s m Char => ParsecT s u m Account_Anchor
read_account_anchor =
	(<?> "account_anchor") $ Account_Anchor
	 <$> read_anchor char_account_anchor_prefix

-- * 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
		 }
	 )

-- ** 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\""

-- | 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) 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 char_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 char_date_hour_sep
			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: "-".
char_date_ymd_sep :: Char
char_date_ymd_sep = '-'

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

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'
char_comment_prefix :: Char
char_comment_prefix = ';'

read_comment :: Stream s m Char => ParsecT s u m Comment
read_comment = (<?> "comment") $ do
	void $ R.char char_comment_prefix
	void $ read_spaces
	Comment <$> read_words

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_spaces)
	 <|> return []
	 )

-- * Read 'Tag'
char_tag_section_sep :: Char
char_tag_section_sep = ':'
char_tag_value_prefix :: Char
char_tag_value_prefix = '='

read_tag :: Stream s m Char => Char -> ParsecT s u m Tag
read_tag char_prefix = (<?> "tag") $ do
	void $ R.char char_prefix
	p <- read_tag_section
	(\ps -> Tag (Tag_Path $ p :| ps))
	 <$> R.many (R.char char_tag_section_sep >> read_tag_section)
	 <*> R.option (Tag_Value "") (R.try $ do
		void $ read_spaces
		void $ R.char char_tag_value_prefix
		void $ read_spaces
		read_tag_value)

read_tag_section :: Stream s m Char => ParsecT s u m Name
read_tag_section =
	Name . fromString
	 <$> R.many1 (R.satisfy $ \c ->
		not (is_char_attribut c) &&
		is_char c)

read_tag_value :: Stream s m Char => ParsecT s u m Tag_Value
read_tag_value = Tag_Value <$> read_words

-- * Read 'Anchor'
char_anchor_section_sep :: Char
char_anchor_section_sep = ':'

read_anchor :: Stream s m Char => Char -> ParsecT s u m Anchor
read_anchor char_prefix = (<?> "transaction_anchor") $ do
	void $ R.char char_prefix
	p <- read_anchor_section
	Anchor . NonNull.ncons p <$>
		R.many (R.char char_anchor_section_sep >> read_anchor_section)

read_anchor_section :: Stream s m Char => ParsecT s u m Name
read_anchor_section =
	Name . fromString
	 <$> R.many1 (R.satisfy $ \c ->
		not (is_char_attribut c) &&
		is_char c)

-- * Read 'Posting'
read_posting ::
 ( 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 pa -> do
				sa <- R.option Nothing $ Just <$> read_account
				return $ ( maybe pa (pa <>) 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_spaces1 >> 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 (flip 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
				Amounts $
				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_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)
            (Posting_Tags, Posting_Anchors, [Comment])
read_posting_attributes =
	R.option mempty $ R.try $ do
		void $ R.many $ R.try (read_spaces >> read_eol)
		R.choice_try
		 [ read_spaces1 >> read_posting_anchor >>= \(Posting_Anchor p) -> do
			(tags, Posting_Anchors (Anchors anchors), cmts) <- read_posting_attributes
			return (tags, Posting_Anchors (Anchors (Map.insert p () anchors)), cmts)
		 , read_spaces1 >> read_posting_tag >>= \(Posting_Tag (Tag (Tag_Path p) v)) -> do
			(Posting_Tags (Tags tags), anchors, cmts) <- read_posting_attributes
			return (Posting_Tags (Tags (TreeMap.insert mappend p [v] tags)), anchors, cmts)
		 , read_spaces >> read_comment >>= \c -> do
			(tags, anchors, cmts) <- read_posting_attributes
			return (tags, anchors, c:cmts)
		 ]

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

-- ** Read 'Posting_Tag'
char_posting_tag_prefix :: Char
char_posting_tag_prefix = '#'

read_posting_tag :: Stream s m Char => ParsecT s u m Posting_Tag
read_posting_tag =
	(<?> "posting_tag") $ Posting_Tag
	 <$> read_tag char_posting_tag_prefix

-- ** Read 'Posting_Anchor'
char_posting_anchor_prefix :: Char
char_posting_anchor_prefix = '@'

read_posting_anchor :: Stream s m Char => ParsecT s u m Posting_Anchor
read_posting_anchor =
	(<?> "posting_anchor") $ Posting_Anchor
	 <$> read_anchor char_posting_anchor_prefix

-- * Read 'Transaction'
read_transaction
 :: (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_spaces
			void $ R.char char_transaction_date_sep
			void read_spaces
			R.many_separated
			 (read_date Error_Read_date (Just $ context_read_year ctx)) $
				R.try $
					read_spaces
					>> R.char char_transaction_date_sep
					>> read_spaces
	let transaction_dates = NonNull.ncons date dates
	void $ read_spaces1
	transaction_wording <- read_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_tags
		 , transaction_comments
		 , transaction_dates
		 , transaction_wording
		 , transaction_postings = Postings transaction_postings_unchecked
		 , transaction_sourcepos
		 }
	let styles = journal_amount_styles $ context_read_journal ctx
	transaction_postings <-
		case H.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 $ Postings 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)
            (Transaction_Tags, Transaction_Anchors, [Comment])
read_transaction_attributes =
	R.option mempty $ R.try $ do
		void $ R.many (R.try (read_spaces >> read_eol))
		R.choice_try
		 [ read_spaces1 >> read_transaction_anchor >>= \(Transaction_Anchor p) -> do
			(tags, Transaction_Anchors (Anchors anchors), cmts) <- read_transaction_attributes
			return (tags, Transaction_Anchors (Anchors (Map.insert p () anchors)), cmts)
		 , read_spaces1 >> read_transaction_tag >>= \(Transaction_Tag (Tag (Tag_Path p) v)) -> do
			(Transaction_Tags (Tags tags), anchors, cmts) <- read_transaction_attributes
			return (Transaction_Tags (Tags (TreeMap.insert mappend p [v] tags)), anchors, cmts)
		 , read_spaces >> read_comment >>= \c -> do
			(tags, anchors, cmts) <- read_transaction_attributes
			return (tags, anchors, c:cmts)
		 ]

read_postings ::
 (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_spaces >> read_eol >> read_spaces1 >> read_posting)

char_transaction_date_sep :: Char
char_transaction_date_sep = '='

read_wording
 :: Stream s m Char
 => ParsecT s u m Wording
read_wording =
	(<?> "wording") $
	(Wording . fromString <$>) $
	R.many $ R.try $ R.satisfy $ \c ->
		c /= char_transaction_tag_prefix &&
		c /= char_transaction_anchor_prefix &&
		(is_space c || is_char c)

-- ** Read 'Transaction_Anchor'
char_transaction_anchor_prefix :: Char
char_transaction_anchor_prefix = '@'

read_transaction_anchor :: Stream s m Char => ParsecT s u m Transaction_Anchor
read_transaction_anchor =
	(<?> "transaction_anchor") $ Transaction_Anchor
	 <$> read_anchor char_transaction_anchor_prefix

-- ** Read 'Transaction_Tag'
char_transaction_tag_prefix :: Char
char_transaction_tag_prefix = '#'

read_transaction_tag :: Stream s m Char => ParsecT s u m Transaction_Tag
read_transaction_tag =
	(<?> "transaction_tag") $ Transaction_Tag
	 <$> read_tag char_transaction_tag_prefix

-- * 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_spaces
	void $ R.char '='
	read_spaces
	repl <- read_account
	read_spaces
	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 :: 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
	void $ read_spaces
	context_read_ <- R.getState
	R.setState context_read_{context_read_year=year}

read_default_unit_and_style :: 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
	void $ read_spaces
	ctx <- R.getState
	let unit = 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
 :: (Monad m, Stream s (R.State_Error Error_Read m) Char)
 => ParsecT s (Context_Read c j)
              (R.State_Error Error_Read m)
              ()
read_chart = (<?> "chart") $
	-- sourcepos <- R.getPosition
	void $ R.many $ do
		acct <- read_account
		void read_eol
		( chart_tags
		 , chart_anchors
		 , _chart_comments ) <-
			fields acct mempty mempty mempty
		let chart_accounts =
			TreeMap.singleton (H.get acct) $
			Account_Tags chart_tags
		ctx <- R.getState
		let jnl = context_read_journal ctx
		R.setState
			ctx{context_read_journal=
				jnl{journal_chart = journal_chart jnl `mappend`
					 Chart
						 { chart_accounts
						 , chart_anchors
						 }
				 }
			 }
	where
		fields acct tags@(Tags tagm) anchors cmts =
			R.choice_try
			 [ read_spaces1 >> read_comment >>= \c ->
				fields acct tags anchors (c:cmts)
			 , read_spaces1 >> read_account_tag >>= \(Account_Tag (Tag (Tag_Path p) v)) ->
				fields acct (Tags $ TreeMap.insert (flip mappend) p [v] tagm) anchors cmts
			 , read_spaces1 >> 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_spaces >> 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_spaces >> read_eol)
			void $ join r
			R.skipMany (read_spaces >> read_eol)
			R.try (read_spaces >> R.eof) <|> loop r
		jump_comment ::
		 ( 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 char_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 char_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 ::
		 ( 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