{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.Format.Ledger.Read where

import           Control.Applicative ((<*), (<$>))
import           Control.Monad (guard)
-- import           Control.Monad.Error
import qualified Data.Char
import qualified Data.Decimal
import qualified Data.List
-- import           Data.List.Split (wordsBy)
import qualified Data.Map
import qualified Data.Time.Calendar  as Time
import qualified Data.Time.Clock     as Time
import           Data.Typeable ()
import qualified Text.Parsec as P
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))

import qualified Hcompta.Model.Account as Account
import           Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as Amount
import           Hcompta.Model.Amount (Amount)
import qualified Hcompta.Model.Amount.Conversion as Conversion
import qualified Hcompta.Model.Amount.Style as Style
import qualified Hcompta.Model.Amount.Unit as Unit
import           Hcompta.Model.Amount.Unit (Unit)
import qualified Hcompta.Model.Date as Date
import           Hcompta.Format.Ledger.Journal as Journal
import qualified Hcompta.Lib.Regex as Regex
import           Hcompta.Lib.Regex (Regex)

data Context
 =   Context
 { account_prefix :: !Account
 , context_aliases_exact :: !(Data.Map.Map Account Account)
 , context_aliases_joker :: ![(Account.Joker, Account)]
 , context_aliases_regex :: ![(Regex, Account)]
 , unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
 , journal :: !Journal
 , year :: !Date.Year
 } deriving (Show)

nil :: Context
nil =
	Context
	 { account_prefix = []
		, context_aliases_exact = Data.Map.empty
		, context_aliases_joker = []
		, context_aliases_regex = []
	 , unit_and_style = Nothing
	 , journal = Journal.nil
	 , year = (\(year, _ , _) -> year) $
		Time.toGregorian $ Time.utctDay $
		Journal.last_read_time Journal.nil
	 }

-- * Utilities

-- ** Combinators

-- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
choice_try :: Stream s m t => [ParsecT s st m a] -> ParsecT s st m a
choice_try = P.choice . Data.List.map P.try

-- ** Numbers

-- | Return the 'Integer' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
integer_of_digits
 :: Integer -- ^ Base.
 -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 -> Integer
integer_of_digits base =
	Data.List.foldl (\x d ->
		base*x + toInteger (Data.Char.digitToInt d)) 0

decimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
decimal = integer 10 P.digit
hexadecimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
octal :: Stream [Char] m Char => ParsecT [Char] st m Integer
octal = P.oneOf "oO" >> integer 8 P.octDigit

-- | Parse an 'Integer'.
integer :: Stream [Char] m Char
       => Integer -> ParsecT [Char] st m Char
       -> ParsecT [Char] st m Integer
integer base digit = do
	digits <- P.many1 digit
	let n = integer_of_digits base digits
	seq n (return n)

-- | Parse either '-' into 'negate', or '+' or '' into 'id'.
sign :: (Stream [Char] m Char, Num i) => ParsecT [Char] st m (i -> i)
sign =
	(P.char '-' >> return negate) <|>
	(P.char '+' >> return id) <|>
	return id

-- ** Whites

-- | Return 'True' if and only if the given 'Char' is an horizontal space.
is_space_horizontal :: Char -> Bool
is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c

space :: Stream [Char] m Char => ParsecT [Char] st m Char
space = P.satisfy is_space_horizontal

-- * Parsing 'Account'.

-- | Parse an 'Account'.
account :: Stream [Char] m Char => ParsecT [Char] st m Account
account = do
	P.notFollowedBy $ P.satisfy is_space_horizontal
	P.sepBy1 account_name account_name_separator

-- | Parse an Account.'Account.Name'.
account_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Name
account_name = do
	P.many1 $ do
		P.satisfy is_space_horizontal
			<* (P.lookAhead $ P.satisfy (not . Data.Char.isSpace))
		<|> (P.notFollowedBy account_name_separator >> P.anyChar)

-- | Parse the Account.'Account.Name' separator: ':'.
account_name_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
account_name_separator = P.char ':'

-- | Parse an Account.'Account.Joker_Name'.
account_joker_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Joker_Name
account_joker_name = do
	n <- P.option Nothing $ (Just <$> account_name)
	case n of
	 Nothing -> account_name_separator >> (return $ Account.Joker_Any)
	 Just n' -> return $ Account.Joker_Name n'

-- | Parse an Account.'Account.Joker'.
account_joker :: Stream [Char] m Char => ParsecT [Char] st m Account.Joker
account_joker = do
	P.notFollowedBy $ P.satisfy is_space_horizontal
	P.sepBy1 account_joker_name account_name_separator

-- | Parse a 'Regex'.
account_regex :: Stream [Char] m Char => ParsecT [Char] st m Regex
account_regex = do
	re <- P.many1 $ P.satisfy (not . is_space_horizontal)
	Regex.of_StringM re

-- | Parse an Account.'Account.Filter'.
account_pattern :: Stream [Char] m Char => ParsecT [Char] st m Account.Pattern
account_pattern = do
	choice_try
	 [ Account.Pattern_Exact <$> (P.char '=' >> account)
	 , Account.Pattern_Joker <$> (P.char '*' >> account_joker)
	 , Account.Pattern_Regex <$> (P.option '~' (P.char '~') >> account_regex)
	 ]

-- * Parsing 'Amount'.

-- | Parse an 'Amount'.
amount :: Stream [Char] m Char => ParsecT [Char] st m Amount
amount = do
	left_signing <- sign
	left_unit <-
		P.option Nothing $ do
			u <- unit
			s <- P.many $ P.satisfy is_space_horizontal
			return $ Just $ (u, not $ null s)
	(quantity_, style) <- do
		signing <- sign
		Quantity
		 { integral
		 , fractional
		 , fractioning
		 , grouping_integral
		 , grouping_fractional
		 } <-
			choice_try
			 [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '.' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 ] <?> "quantity"
		let int = Data.List.concat integral
		let frac_flat = Data.List.concat fractional
		let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
		let place = length frac
		guard (place <= 255)
		let mantissa = integer_of_digits 10 $ int ++ frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral place)
			 (signing mantissa)
		 , Style.nil
			 { Style.fractioning = fractioning
			 , Style.grouping_integral = grouping_integral
			 , Style.grouping_fractional = grouping_fractional
			 , Style.precision = fromIntegral $ length frac_flat
			 }
		 )
	(unit_, side, spaced) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Style.Side_Left, Just s)
		 Nothing ->
			P.option (Unit.nil, Nothing, Nothing) $ do
				s <- P.many $ P.satisfy is_space_horizontal
				u <- unit
				return $ (u, Just Style.Side_Right, Just $ not $ null s)
	return $
		Amount.Amount
		 { Amount.conversion = Conversion.nil -- TODO
		 , Amount.quantity = left_signing $ quantity_
		 , Amount.style = style
			 { Style.unit_side = side
			 , Style.unit_spaced = spaced
			 }
		 , Amount.unit = unit_
		 }

data Quantity
 =   Quantity
 { integral :: [String]
 , fractional :: [String]
 , fractioning :: Maybe Style.Fractioning
 , grouping_integral :: Maybe Style.Grouping
 , grouping_fractional :: Maybe Style.Grouping
 }

-- | Parse a 'Quantity'.
quantity
 :: Stream [Char] m Char
 => Char -- ^ Integral grouping separator.
 -> Char -- ^ Fractioning separator.
 -> Char -- ^ Fractional grouping separator.
 -> ParsecT [Char] st m Quantity
quantity int_group_sep frac_sep frac_group_sep = do
	(integral, grouping_integral) <- do
		h <- P.many P.digit
		case h of
		 [] -> return ([], Nothing)
		 _ -> do
			t <- P.many $ P.char int_group_sep >> P.many1 P.digit
			let digits = h:t
			return (digits, grouping_of_digits int_group_sep digits)
	(fractional, fractioning, grouping_fractional) <-
		(case integral of
		 [] -> id
		 _ -> P.option ([], Nothing, Nothing)) $ do
			fractioning <- P.char frac_sep
			h <- P.many P.digit
			t <- P.many $ P.char frac_group_sep >> P.many1 P.digit
			let digits = h:t
			return (digits, Just fractioning
			 , grouping_of_digits frac_group_sep $ reverse digits)
	return $
		Quantity
		 { integral
		 , fractional
		 , fractioning
		 , grouping_integral
		 , grouping_fractional
		 }
	where
		grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
		grouping_of_digits group_sep digits =
			case digits of
			 [] -> Nothing
			 [_] -> Nothing
			 _ -> Just $
				Style.Grouping group_sep $
				canonicalize_grouping $
				map length $ digits
		canonicalize_grouping :: [Int] -> [Int]
		canonicalize_grouping groups =
			Data.List.foldl -- NOTE: remove duplicates at begining 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 begining.
			 l0:l1:t -> if l0 > l1 then groups else l1:t
			 _ -> groups

-- | Parse an 'Unit'.
unit :: Stream [Char] m Char => ParsecT [Char] st m Unit
unit =
	(quoted <|> unquoted) <?> "unit"
	where
		unquoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
		unquoted =
			P.many1 $
				P.satisfy $ \c ->
					case Data.Char.generalCategory c of
					 Data.Char.CurrencySymbol  -> True
					 Data.Char.LowercaseLetter -> True
					 Data.Char.ModifierLetter  -> True
					 Data.Char.OtherLetter     -> True
					 Data.Char.TitlecaseLetter -> True
					 Data.Char.UppercaseLetter -> True
					 _ -> False
		quoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
		quoted =
			P.between (P.char '"') (P.char '"') $
				P.many1 $
					P.noneOf ";\n\""

-- * Directives
-- ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate

directive_alias :: Stream [Char] m Char => ParsecT [Char] Context m ()
directive_alias = do
	_ <- P.string "alias"
	_ <- P.many1 $ P.satisfy is_space_horizontal
	pattern <- account_pattern
	_ <- P.many $ P.satisfy is_space_horizontal
	_ <- P.char '='
	_ <- P.many $ P.satisfy is_space_horizontal
	repl <- account
	_ <- P.many $ P.satisfy is_space_horizontal
	case pattern of
	 Account.Pattern_Exact acct -> P.modifyState $ \ctx -> ctx{context_aliases_exact=
		Data.Map.insert acct repl $ context_aliases_exact ctx}
	 Account.Pattern_Joker jokr -> P.modifyState $ \ctx -> ctx{context_aliases_joker=
		(jokr, repl):context_aliases_joker ctx}
	 Account.Pattern_Regex regx -> P.modifyState $ \ctx -> ctx{context_aliases_regex=
		(regx, repl):context_aliases_regex ctx}
	return ()

-- | Parse the year, month and day separator: '/' or '-'.
date_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
date_separator = P.satisfy (\c -> c == '/' || c == '-')

-- | Parse the hour, minute and second separator: ':'.
hour_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
hour_separator = P.char ':'
{-
-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed.
-- The year may be omitted if a default year has already been set.
date :: Stream [Char] m t => ParsecT [Char] Context m Date
date = do
	n0 <- P.many1 P.digit
	date_sep <- date_separator
	n1 <- P.count 2 P.digit <|> P.count 1 P.digit
	n2 <- P.option Nothing $ (P.char date_sep >> (Just <$> (P.count 2 P.digit <|> P.count 1 P.digit)))
	(y, m, d) <-
		case n2 of
		 Nothing -> do
			y <- liftM context_year getState
			return (y, n0, n1)
		 Just d -> return (n0, n1, d)
	year  <- integer_of_digits 10 y
	month <- integer_of_digits 10 m
	day   <- integer_of_digits 10 d
	guard $ month >= 1 && month <= 12
	guard $ day   >= 1 && day   <= 31
	
	P.many1 $ P.satisfy is_space_horizontal
	
	h <- P.count 2 P.digit <|> P.count 1 P.digit
	hour_sep <- hour_separator
	mi <- P.count 2 P.digit <|> P.count 1 P.digit
	s <- P.option Nothing $ (P.char hour_sep >> (Just <$> (P.count 2 P.digit <|> P.count 1 P.digit)))
	hour  <- integer_of_digits 10 y
	min <- integer_of_digits 10 m
	sec   <- integer_of_digits 10 d
	guard $ hour  >= 0 && hour <= 23
	guard $ min   >= 0 && min <= 59
	guard $ sec   >= 0 && day   <= 60 -- NOTE: allow lapse
	
	-- XXX reported error position is not too good
	-- pos <- getPosition
	datestr <- many1 $ choice_try [digit, datesepchar]
	let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
	when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
	let dateparts = wordsBy (`elem` datesepchars) datestr
	currentyear <- getYear
	[y, m, d] <-
		case (dateparts,currentyear) of
		 ([m,d],Just y)  -> return [show y,m,d]
		 ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
		 ([y,m,d],_)     -> return [y,m,d]
		 _               -> fail $ "bad date: " ++ datestr
	let maybedate = fromGregorianValid (read y) (read m) (read d)
	case maybedate of
	 Nothing   -> fail $ "bad date: " ++ datestr
	 Just date -> return date
	<?> "full or partial date"

-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.
-- Any timezone will be ignored; the time is treated as local time.
-- Fewer digits are allowed, except in the timezone.
-- The year may be omitted if a default year has already been set.
parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
parseDateTime = do
	day <- parseDate
	many1 spacenonewline
	h <- many1 digit
	let h' = read h
	guard $ h' >= 0 && h' <= 23
	char ':'
	m <- many1 digit
	let m' = read m
	guard $ m' >= 0 && m' <= 59
	s <- optionMaybe $ char ':' >> many1 digit
	let s' = case s of Just sstr -> read sstr
	                   Nothing   -> 0
	guard $ s' >= 0 && s' <= 59
	{- tz <- -}
	optionMaybe $ do
		plusminus <- oneOf "-+"
		d1 <- digit
		d2 <- digit
		d3 <- digit
		d4 <- digit
		return $ plusminus:d1:d2:d3:d4:""
	-- ltz <- liftIO $ getCurrentTimeZone
	-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
	-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
	return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')

-- | Parse a 'Posting'.
posting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
posting = do
	_ <- P.many1 $ P.satisfy is_space_horizontal
	-- status <- parseStatus -- TODO
	_ <- P.many $ P.satisfy is_space_horizontal
	account <- modifiedaccountname
	let (ptype, account') = (accountNamePostingType account, unbracket account)
	amount <- spaceandamountormissing
	massertion <- partialbalanceassertion
	_ <- fixedlotprice
	many spacenonewline
	ctx <- getState
	comment <- try followingcommentp <|> (newline >> return "")
	let tags = tagsInComment comment
	coa <- getCoA
	date <-
		case dateValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	date2 <-
		case date2ValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	return posting
	 { Posting.date=date
	 , Posting.date2=date2
	 , Posting.status=status
	 , Posting.account=account'
	 , Posting.amount=amount
	 , Posting.comment=comment
	 , Posting.type=ptype
	 , Posting.tags=tags
	 , Posting.coa=pcoa
	 , Posting.balanceassertion=massertion
	 }
-}
{-
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
account_with_context :: Stream [Char] m Char => ParsecT [Char] Context m Account
account_with_context = do
	acct <- account
	prefix <- liftM context_account_prefix P.getState
	aliases <- getAccountAliases
	return $ accountNameApplyAliases aliases $ Account.(++) prefix acct


-}
{-

account :: Stream [Char] m Char => ParsecT [Char] st m Account
account = do
	P.notFollowedBy $ P.satisfy is_space
		single_space = try (P.satisfy is_space <* P.notFollowedBy $ P.satisfy is_space)
	a <- P.many1 (not_spaces <|> single_space)
	let a' = striptrailingspace a
	when (accountNameFromComponents (accountNameComponents a') /= a')
	     (fail $ "account name seems ill-formed: "++a')
	return a'
	where
		single_space = try (P.satisfy is_space <* P.notFollowedBy $ P.satisfy is_space)
		striptrailingspace s = if last s == ' ' then init s else s

parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
parsePosting = do
	many1 spacenonewline
	status <- parseStatus
	many spacenonewline
	account <- modifiedaccountname
	let (ptype, account') = (accountNamePostingType account, unbracket account)
	amount <- spaceandamountormissing
	massertion <- partialbalanceassertion
	_ <- fixedlotprice
	many spacenonewline
	ctx <- getState
	comment <- try followingcommentp <|> (newline >> return "")
	let tags = tagsInComment comment
	coa <- getCoA
	pcoa <-
		if isZeroMixedAmount amount
		then do
			let coa_ = coaAdd coa (accountNameComponents account) tags
			setCoA coa_
			return coa_
		else return coa
	date <-
		case dateValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	date2 <-
		case date2ValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	return posting
	 { Posting.date=date
	 , Posting.date2=date2
	 , Posting.status=status
	 , Posting.account=account'
	 , Posting.amount=amount
	 , Posting.comment=comment
	 , Posting.type=ptype
	 , Posting.tags=tags
	 , Posting.coa=pcoa
	 , Posting.balanceassertion=massertion
	 }
-}

{-
reader :: Reader
reader = Reader format detect parse

format :: String
format = "ledger"

detect :: FilePath -> String -> Bool
detect file s
	| file /= "-"  = takeExtension file `elem` ['.':format, ".j"]  -- from a file: yes if the extension is .journal or .j
	-- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
	| otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s

parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
parse _ = parseJournal journal

parseJournal
 :: ParsecT [Char] Context (ErrorT String IO) Context
 -> Bool -> FilePath -> String -> ErrorT String IO Journal
parseJournal parser filePath fileData = do
	currentUTC <- liftIO Time.getCurrentTime
	currentTimeZone <- liftIO Time.getCurrentTimeZone
	let currentLocalTime = Time.utcToLocalTime currentTimeZone currentUTC
	let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
	parserResult <- runParserT parser
	 contextNull{context_year=Just currentLocalYear}
	 filePath fileData
	case parserResult of
	 Left error -> throwError $ show error
	 Right context -> do
		let journal = context_journal context
		journalBalanceTransactions $
		journal
		 { journal_unit_styles=
		 , journal_file=filePath
		 , journal_includes=reverse $ journal_includes journal
		 -- , journal_historical_prices=reverse $ journal_historical_prices journal
		 , journal_last_read_time=currentUTC
		 , journal_transactions=reverse $ journal_transactions journal
		 -- , journal_transaction_modifiers=reverse $ journal_transaction_modifiers journal
		 -- , journal_transaction_periodics=reverse $ journal_transaction_periodics journal
		 }

-- | Fill in any missing amounts and check that all journal transactions
-- balance, or return an error message. This is done after parsing all
-- amounts and working out the canonical commodities, since balancing
-- depends on display precision. Reports only the first error encountered.
journalBalanceTransactions :: Journal -> Either String Journal
journalBalanceTransactions journal =
	let transactions = journal_transactions journal
	let unit_and_style = journal_unit_styles journal
	case sequence $ map balance transactions of
	 Right ts' -> Right journal{journal_transactions=map txnTieKnot ts'}
	 Left e    -> Left e
	where balance = balanceTransaction (Just unit_and_style)

-- | Convert all the journal's posting amounts (not price amounts) to
-- their canonical display settings. Ie, all amounts in a given
-- unit will use (a) the display settings of the first, and (b)
-- the greatest precision, of the posting amounts in that unit.
journalCanonicaliseAmounts :: Journal -> Journal
journalCanonicaliseAmounts j@Journal{journal_transactions=ts} =
	j''
	where
		j'' = j'{journal_transactions=map fixtransaction ts}
		j' = j{context_unit_and_style = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j}
		fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
		fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
		fixmixedamount (Mixed as) = Mixed $ map fixamount as
		fixamount a@Amount{aunit=c} = a{astyle=journalCommodityStyle j' c}

-- | Given a list of amounts in parse order, build a map from commodities
-- to canonical display styles for amounts in that unit.
canonicalStyles :: [Amount] -> M.Map Amount.Unit Amount.Style
canonicalStyles amts =
	M.fromList commstyles
	where
		samecomm = \a1 a2 -> aunit a1 == aunit a2
		commamts = [(aunit $ head as, as) | as <- groupBy samecomm $ sortBy (comparing aunit) amts]
		commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]

-- | Get all this journal's component amounts, roughly in the order parsed.
journalAmounts :: Journal -> [Amount]
journalAmounts =
	concatMap flatten . journalMixedAmounts
	where flatten (Mixed as) = as

amountStyleFromCommodity :: Context -> Amount.Unit -> Amount.Style
amountStyleFromCommodity context unit =
	Data.Map.findWithDefault
	 (context_unit_and_style context)
	 unit $
	journal_unit_styles $
	context_journal context




setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] Context m ()
setYear y = modifyState (\ctx -> ctx{context_year=Just y})

getYear :: Stream [Char] m Char => ParsecT s Context m (Maybe Integer)
getYear = liftM context_year getState

setCoA :: Stream [Char] m Char => CoA -> ParsecT [Char] Context m ()
setCoA coa = modifyState (\ctx -> ctx{ctxCoA=coa})

getCoA :: Stream [Char] m Char => ParsecT [Char] Context m CoA
getCoA = liftM ctxCoA getState

setDefaultCommodityAndStyle :: Stream [Char] m Char => (Amount.Unit,Amount.Style) -> ParsecT [Char] Context m ()
setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{context_unit_and_style=Just cs})

getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe (Amount.Unit,Amount.Style))
getDefaultCommodityAndStyle = context_unit_and_style `fmap` getState

pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] Context m ()
pushParentAccount parent = modifyState addParentAccount
    where addParentAccount ctx0 = ctx0 { context_account_prefix = parent : context_account_prefix ctx0 }

popParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m ()
popParentAccount = do
	ctx0 <- getState
	case context_account_prefix ctx0 of
	 [] -> unexpected "End of account block with no beginning"
	 (_:rest) -> setState $ ctx0 { context_account_prefix = rest }

getParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m String
getParentAccount = liftM (concatAccountNames . reverse . context_account_prefix) getState

addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] Context m ()
addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=a:context_aliases})

getAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m [AccountAlias]
getAccountAliases = liftM context_aliases getState

clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m ()
clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=[]})

-- parsers

parseJournal :: ParsecT [Char] Context (ErrorT String IO) (JournalUpdate, Context)
parseJournal = do
	journalUpdates <- many journalItem
	eof
	finalContext <- getState
	return $ (combineJournalUpdates journalUpdates, finalContext)
		where
			-- As all journal line types can be distinguished by the first
			-- character, excepting transactions versus empty (blank or
			-- comment-only) lines, can use choice w/o try
			journalItem =
				choice
				 [ directive
				 , liftM (return . addTransaction) parseTransaction
				 , liftM (return . addModifierTransaction) parseTransactionModifier
				 , liftM (return . addPeriodicTransaction) periodictransaction
				 , liftM (return . addHistoricalPrice) historicalpricedirective
				 , emptyorcommentlinep >> return (return id)
				 , multilinecommentp >> return (return id)
				 ] <?> "journal transaction or directive"

parseDirective :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirective = do
	optional $ char '!'
	choice'
	 [ parseDirectiveInclude
	 , parseDirectiveAlias
	 , parseDirectiveEndAlias
	 , parseDirectiveAccount
	 , parseDirectiveEnd
	 , parseDirectiveTag
	 , parseDirectiveEndTag
	 , parseDirectiveYear
	 , parseDirectiveCommodity
	 , parseDirectiveCommodityConversion
	 , parseDirectiveIgnoredPriceCommodity
	 ]
	<?> "directive"

parseDirectiveInclude :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveInclude = do
	string "include"
	many1 spacenonewline
	filename <- restofline
	outerState <- getState
	outerPos <- getPosition
	let curdir = takeDirectory (sourceName outerPos)
	let (u::ErrorT String IO (Journal -> Journal, Context)) = do
		filepath <- expandPath curdir filename
		txt <- readFileOrError outerPos filepath
		let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
		r <- runParserT parseJournal outerState filepath txt
		case r of
		 Right (ju, ctx) -> do
			u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)
			                           , ju
			                           ] `catchError` (throwError . (inIncluded ++))
			return (u, ctx)
		 Left err -> throwError $ inIncluded ++ show err
		where readFileOrError pos fp =
			ErrorT $ liftM Right (readFile' fp) `Exn.catch`
			  \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::Exn.IOException))
	r <- liftIO $ runErrorT u
	case r of
	 Left err -> return $ throwError err
	 Right (ju, ctx) -> do
		setCoA (ctxCoA ctx)
		return $ ErrorT $ return $ Right ju

journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{journal_files=fs} = j{journal_files=fs++[f]}
 -- NOTE: first encountered file to left, to avoid a reverse

parseDirectiveAccount :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveAccount = do
  string "account"
  many1 spacenonewline
  parent <- parseAccountName
  newline
  pushParentAccount parent
  -- return $ return id
  return $ ErrorT $ return $ Right id

parseDirectiveEnd :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveEnd = do
  string "end"
  popParentAccount
  -- return (return id)
  return $ ErrorT $ return $ Right id

parseDirectiveAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveAlias = do
  string "alias"
  many1 spacenonewline
  orig <- many1 $ noneOf "="
  char '='
  alias <- restofline
  addAccountAlias (accountNameWithoutPostingType $ strip orig
                  ,accountNameWithoutPostingType $ strip alias)
  return $ return id

parseDirectiveEndAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveEndAlias = do
  string "end aliases"
  clearAccountAliases
  return (return id)

parseDirectiveTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveTag = do
  string "tag" <?> "tag directive"
  many1 spacenonewline
  _ <- many1 nonspace
  restofline
  return $ return id

parseDirectiveEndTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveEndTag = do
	(string "end tag" <|> string "pop") <?> "end tag or pop directive"
	restofline
	return $ return id

parseDirectiveYear :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveYear = do
	char 'Y' <?> "default year"
	many spacenonewline
	y <- many1 digit
	let y' = read y
	failIfInvalidYear y
	setYear y'
	return $ return id

parseDirectiveCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveCommodity = do
	char 'D' <?> "default unit"
	many1 spacenonewline
	Amount{..} <- getDefaultCommodityAndStyle >>= parseAmount
	setDefaultCommodityAndStyle (aunit, astyle)
	restofline
	return $ return id

parseDirectiveHistoricalPrice :: ParsecT [Char] Context (ErrorT String IO) HistoricalPrice
parseDirectiveHistoricalPrice = do
	char 'P' <?> "historical price"
	many spacenonewline
	date <- try (do {LocalTime d _ <- parseDateTime; return d}) <|> parseDate -- a time is ignored
	many1 spacenonewline
	symbol <- parseCommodity
	many spacenonewline
	price <- getDefaultCommodityAndStyle >>= parseAmount
	restofline
	return $ HistoricalPrice date symbol price

parseDirectiveIgnoredPriceCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveIgnoredPriceCommodity = do
	char 'N' <?> "ignored-price unit"
	many1 spacenonewline
	parseCommodity
	restofline
	return $ return id

parseDirectiveCommodityConversion :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
parseDirectiveCommodityConversion = do
	char 'C' <?> "unit conversion"
	many1 spacenonewline
	default_cs <- getDefaultCommodityAndStyle
	parseAmount default_cs
	many spacenonewline
	char '='
	many spacenonewline
	parseAmount default_cs
	restofline
	return $ return id

parseTransactionModifier :: ParsecT [Char] Context (ErrorT String IO) ModifierTransaction
parseTransactionModifier = do
	char '=' <?> "modifier transaction"
	many spacenonewline
	valueexpr <- restofline
	parsePostings <- parsePostings
	return $ ModifierTransaction valueexpr parsePostings

parseTransactionPeriodic :: ParsecT [Char] Context (ErrorT String IO) PeriodicTransaction
parseTransactionPeriodic = do
	char '~' <?> "periodic transaction"
	many spacenonewline
	periodexpr <- restofline
	parsePostings <- parsePostings
	return $ PeriodicTransaction periodexpr parsePostings

-- | Parse a (possibly unbalanced) transaction.
parseTransaction :: ParsecT [Char] Context (ErrorT String IO) Transaction
parseTransaction = do
	-- ptrace "transaction"
	sourcepos <- getPosition
	date <- parseDate <?> "transaction"
	edate <- optionMaybe (parseDate2 date) <?> "secondary date"
	lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
	status <- parseStatus <?> "cleared flag"
	code <- parseCode <?> "transaction code"
	description <- descriptionp >>= return . strip
	comment <- try followingcommentp <|> (newline >> return "")
	let tags = tagsInComment comment
	parsePostings <- parsePostings
	return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags parsePostings ""

descriptionp = many (noneOf ";\n")

-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
-- may be omitted if a default year has already been set.
parseDate :: Stream [Char] m t => ParsecT [Char] Context m Day
parseDate = do
	-- hacky: try to ensure precise errors for invalid dates
	-- XXX reported error position is not too good
	-- pos <- getPosition
	datestr <- many1 $ choice' [digit, datesepchar]
	let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
	when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
	let dateparts = wordsBy (`elem` datesepchars) datestr
	currentyear <- getYear
	[y, m, d] <-
		case (dateparts,currentyear) of
		 ([m,d],Just y)  -> return [show y,m,d]
		 ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
		 ([y,m,d],_)     -> return [y,m,d]
		 _               -> fail $ "bad date: " ++ datestr
	let maybedate = fromGregorianValid (read y) (read m) (read d)
	case maybedate of
	 Nothing   -> fail $ "bad date: " ++ datestr
	 Just date -> return date
	<?> "full or partial date"

-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.  Any
-- timezone will be ignored; the time is treated as local time.  Fewer
-- digits are allowed, except in the timezone. The year may be omitted if
-- a default year has already been set.
parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
parseDateTime = do
	day <- parseDate
	many1 spacenonewline
	h <- many1 digit
	let h' = read h
	guard $ h' >= 0 && h' <= 23
	char ':'
	m <- many1 digit
	let m' = read m
	guard $ m' >= 0 && m' <= 59
	s <- optionMaybe $ char ':' >> many1 digit
	let s' = case s of Just sstr -> read sstr
	                   Nothing   -> 0
	guard $ s' >= 0 && s' <= 59
	{- tz <- -}
	optionMaybe $ do
		plusminus <- oneOf "-+"
		d1 <- digit
		d2 <- digit
		d3 <- digit
		d4 <- digit
		return $ plusminus:d1:d2:d3:d4:""
	-- ltz <- liftIO $ getCurrentTimeZone
	-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
	-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
	return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')

parseDate2 :: Stream [Char] m Char => Day -> ParsecT [Char] Context m Day
parseDate2 primarydate = do
	char '='
	-- kludgy way to use primary date for default year
	let withDefaultYear d p = do
		y <- getYear
		let (y',_,_) = toGregorian d in setYear y'
		r <- p
		when (isJust y) $ setYear $ fromJust y
		return r
	edate <- withDefaultYear primarydate parseDate
	return edate

parseStatus :: Stream [Char] m Char => ParsecT [Char] Context m Bool
parseStatus = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False

parseCode :: Stream [Char] m Char => ParsecT [Char] Context m String
parseCode = try (do { many1 spacenonewline; char '(' <?> "parseCode"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""

-- Parse the following whitespace-beginning lines as parsePostings, posting tags, and/or comments.
parsePostings :: Stream [Char] m Char => ParsecT [Char] Context m [Posting]
parsePostings = many1 (try parsePosting) <?> "parsePostings"

parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
parsePosting = do
	many1 spacenonewline
	status <- parseStatus
	many spacenonewline
	account <- modifiedaccountname
	let (ptype, account') = (accountNamePostingType account, unbracket account)
	amount <- spaceandamountormissing
	massertion <- partialbalanceassertion
	_ <- fixedlotprice
	many spacenonewline
	ctx <- getState
	comment <- try followingcommentp <|> (newline >> return "")
	let tags = tagsInComment comment
	coa <- getCoA
	pcoa <-
		if isZeroMixedAmount amount
		then do
			let coa_ = coaAdd coa (accountNameComponents account) tags
			setCoA coa_
			return coa_
		else return coa
	date <-
		case dateValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	date2 <-
		case date2ValueFromTags tags of
		 Nothing -> return Nothing
		 Just v ->
			case runParser (parseDate <* eof) ctx "" v of
			 Right d -> return $ Just d
			 Left err -> parserFail $ show err
	return posting
	 { Posting.date=date
	 , Posting.date2=date2
	 , Posting.status=status
	 , Posting.account=account'
	 , Posting.amount=amount
	 , Posting.comment=comment
	 , Posting.type=ptype
	 , Posting.tags=tags
	 , Posting.coa=pcoa
	 , Posting.balanceassertion=massertion
	 }


-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] Context m AccountName
modifiedaccountname = do
  a <- parseAccountName
  prefix <- getParentAccount
  let prefixed = prefix `joinAccountNames` a
  aliases <- getAccountAliases
  return $ accountNameApplyAliases aliases prefixed

-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
--     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"

-- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special
-- "missing" marker amount.
spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] Context m MixedAmount
spaceandamountormissing = do
  default_cs <- getDefaultCommodityAndStyle
  try (do
        many1 spacenonewline
        (Mixed . (:[])) `fmap` parseAmount default_cs <|> return missingmixedamt
      ) <|> return missingmixedamt

partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] Context m (Maybe MixedAmount)
partialbalanceassertion = do
    default_cs <- getDefaultCommodityAndStyle
    try (do
          many spacenonewline
          char '='
          many spacenonewline
          a <- parseAmount default_cs -- XXX should restrict to a simple amount
          return $ Just $ Mixed [a])
         <|> return Nothing

-- balanceassertion :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe MixedAmount)
-- balanceassertion =
--     default_cs <- getDefaultCommodityAndStyle
--     try (do
--           many spacenonewline
--           string "=="
--           many spacenonewline
--           a <- parseAmount default_cs -- XXX should restrict to a simple amount
--           return $ Just $ Mixed [a])
--          <|> return Nothing

-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotprice :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe Amount)
fixedlotprice = do
    default_cs <- getDefaultCommodityAndStyle
    try (do
          many spacenonewline
          char '{'
          many spacenonewline
          char '='
          many spacenonewline
          a <- parseAmount default_cs -- XXX should restrict to a simple amount
          many spacenonewline
          char '}'
          return $ Just a)
         <|> return Nothing

-- comment parsers

multilinecommentp :: Stream [Char] m Char => ParsecT [Char] Context m ()
multilinecommentp = do
  string "comment" >> newline
  go
  where
    go = try (string "end comment" >> newline >> return ())
         <|> (anyLine >> go)
    anyLine = anyChar `manyTill` newline

emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] Context m ()
emptyorcommentlinep = do
  many spacenonewline >> (parseComment <|> (many spacenonewline >> newline >> return ""))
  return ()

followingcommentp :: Stream [Char] m Char => ParsecT [Char] Context m String
followingcommentp =
  -- ptrace "followingcommentp"
  do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
     newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
     return $ unlines $ samelinecomment:newlinecomments

parseComment :: Stream [Char] m Char => ParsecT [Char] Context m String
parseComment = commentStartingWith commentchars

commentchars :: [Char]
commentchars = "#;*"

semicoloncomment :: Stream [Char] m Char => ParsecT [Char] Context m String
semicoloncomment = commentStartingWith ";"

commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] Context m String
commentStartingWith cs = do
  -- ptrace "commentStartingWith"
  oneOf cs
  many spacenonewline
  l <- anyChar `manyTill` eolof
  optional newline
  return l

tagsInComment :: String -> [Tag]
tagsInComment c = concatMap tagsInCommentLine $ lines c'
  where
    c' = ledgerDateSyntaxToTags c

tagsInCommentLine :: String -> [Tag]
tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
  where
    maybetag s = case runParser (parseTag <* eof) contextNull "" s of
                  Right t -> Just t
                  Left _ -> Nothing

parseTag = do
	-- ptrace "parseTag"
	n <- parseTagName
	v <- parseTagValue
	return (n,v)

parseTagName = do
	-- ptrace "parseTagName"
	n <- many1 $ noneOf ": \t"
	char ':'
	return n

parseTagValue = do
  -- ptrace "parseTagValue"
  v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
  return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v

ledgerDateSyntaxToTags :: String -> String
ledgerDateSyntaxToTags =
	regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
	where
		replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
		replace s = s
		
		replace' s | isdate s = datetag s
		replace' ('=':s) | isdate s = date2tag s
		replace' s | last s =='=' && isdate (init s) = datetag (init s)
		replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2
			where
				ds = splitAtElement '=' s
				d1 = headDef "" ds
				d2 = lastDef "" ds
		replace' s = s
		
		isdate = isJust . parsedateM
		datetag s = "date:"++s++", "
		date2tag s = "date2:"++s++", "

dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String
dateValueFromTags  ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
-}