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

-- import           Control.Applicative ((<$>), (<*>), (<*))
import qualified Control.Exception as Exception
import           Control.Arrow ((***), first)
import           Control.Monad (guard, join, liftM, forM, void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (ExceptT(..), throwE)
import qualified Data.Char
import qualified Data.Either
import qualified Data.List
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as Data.Map
import           Data.Maybe (fromMaybe)
import           Data.String (fromString)
import qualified Data.Time.Calendar  as Time
import qualified Data.Time.Clock     as Time
import qualified Data.Time.LocalTime as Time
import           Data.Typeable ()
import qualified Text.Parsec as R hiding
                  ( char
                  , anyChar
                  , crlf
                  , newline
                  , noneOf
                  , oneOf
                  , satisfy
                  , space
                  , spaces
                  , string
                  )
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import qualified Text.Parsec.Pos as R
import qualified Data.Text.IO as Text.IO (readFile)
import qualified Data.Text as Text
import qualified System.FilePath.Posix as Path

import qualified Hcompta.Balance as Balance
import qualified Hcompta.Account as Account
import           Hcompta.Account (Account)
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Amount.Style as Style
import qualified Hcompta.Amount.Read as Amount.Read
import qualified Hcompta.Amount.Unit as Unit
import qualified Hcompta.Date as Date
import           Hcompta.Date (Date)
import qualified Hcompta.Date.Read as Date.Read
import qualified Hcompta.Format.Ledger as Ledger
import           Hcompta.Format.Ledger
                  ( Comment
                  , Journal(..)
                  , Posting(..), Posting_Type(..)
                  , Tag, Tag_Name, Tag_Value, Tag_by_Name
                  , Transaction(..)
                  )
import           Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Regex as Regex
import           Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path

data Context f ts t
 =   Context
 { context_account_prefix :: !(Maybe Account)
 , context_aliases_exact :: !(Data.Map.Map Account Account)
 , context_aliases_joker :: ![(Account.Joker, Account)]
 , context_aliases_regex :: ![(Regex, Account)]
 , context_date :: !Date
 , context_filter :: !f
 , context_journal :: !(Journal (ts t))
 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
 , context_year :: !Date.Year
 } deriving (Show)

context
 :: (Show f, Consable f ts t)
 => f -> Journal (ts t) -> Context f ts t
context flt context_journal =
	Context
	 { context_account_prefix = Nothing
	 , context_aliases_exact = Data.Map.empty
	 , context_aliases_joker = []
	 , context_aliases_regex = []
	 , context_date = Date.nil
	 , context_filter = flt
	 , context_journal
	 , context_unit_and_style = Nothing
	 , context_year = Date.year Date.nil
	 }

data Error
 =   Error_date Date.Read.Error
 |   Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 |   Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 |   Error_reading_file FilePath Exception.IOException
 |   Error_including_file FilePath [R.Error Error]
 deriving (Show)

-- * Read 'Account'

account_name_sep :: Char
account_name_sep = ':'

-- | Read an 'Account'.
account :: Stream s m Char => ParsecT s u m Account
account = do
	R.notFollowedBy $ R.space_horizontal
	Account.from_List <$> do
	R.many1_separated account_name $ R.char account_name_sep

-- | Read an Account.'Account.Name'.
account_name :: Stream s m Char => ParsecT s u m Account.Name
account_name = do
	fromString <$> do
	R.many1 $ R.try account_name_char
	where
		account_name_char :: Stream s m Char => ParsecT s u m Char
		account_name_char = do
			c <- R.anyChar
			case c of
			 _ | c == comment_begin -> R.parserZero
			 _ | c == account_name_sep -> R.parserZero
			 _ | R.is_space_horizontal c -> do
				_ <- R.notFollowedBy $ R.space_horizontal
				return c <* (R.lookAhead $ R.try $
				 ( R.try (R.char account_name_sep)
				 <|> account_name_char
				 ))
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> R.parserZero

-- | Read an Account.'Account.Joker_Name'.
account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
account_joker_name = do
	n <- R.option Nothing $ (Just <$> account_name)
	case n of
	 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
	 Just n' -> return $ Account.Joker_Name n'

-- | Read an Account.'Account.Joker'.
account_joker :: Stream s m Char => ParsecT s u m Account.Joker
account_joker = do
	R.notFollowedBy $ R.space_horizontal
	R.many1_separated account_joker_name $ R.char account_name_sep

-- | Read a 'Regex'.
account_regex :: Stream s m Char => ParsecT s u m Regex
account_regex = do
	re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
	Regex.of_StringM re

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

-- * Directives

directive_alias
 :: (Consable f ts t, Stream s m Char)
 => ParsecT s (Context f ts t) m ()
directive_alias = do
	_ <- R.string "alias"
	R.skipMany1 $ R.space_horizontal
	pattern <- account_pattern
	R.skipMany $ R.space_horizontal
	_ <- R.char '='
	R.skipMany $ R.space_horizontal
	repl <- account
	R.skipMany $ R.space_horizontal
	case pattern of
	 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
		Data.Map.insert acct repl $ context_aliases_exact ctx}
	 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
		(jokr, repl):context_aliases_joker ctx}
	 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
		(regx, repl):context_aliases_regex ctx}
	return ()

-- * Read 'Comment'

comment_begin :: Char
comment_begin = ';'

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

comments :: Stream s m Char => ParsecT s u m [Comment]
comments = (do
	R.try $ do
		_ <- R.spaces
		R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
	<|> return []
	) <?> "comments"

-- * Read 'Tag'

tag_value_sep :: Char
tag_value_sep = ':'

tag_sep :: Char
tag_sep = ','

-- | Read a 'Tag'.
tag :: Stream s m Char => ParsecT s u m Tag
tag = (do
	n <- tag_name
	_ <- R.char tag_value_sep
	v <- tag_value
	return (n, v)
	) <?> "tag"

tag_name :: Stream s m Char => ParsecT s u m Tag_Name
tag_name = do
	fromString <$> do
	R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))

tag_value :: Stream s m Char => ParsecT s u m Tag_Value
tag_value = do
	fromString <$> do
	R.manyTill R.anyChar $ do
		R.lookAhead $ do
			R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> void (R.char tag_value_sep))
			<|> R.try R.new_line
			<|> R.eof

tags :: Stream s m Char => ParsecT s u m Tag_by_Name
tags = do
	Ledger.tag_by_Name <$> do
		R.many_separated tag $ do
			_ <- R.char tag_sep
			R.skipMany $ R.space_horizontal
			return ()

not_tag :: Stream s m Char => ParsecT s u m ()
not_tag = do
	R.skipMany $ R.try $ do
		R.skipMany $ R.satisfy
		 (\c -> c /= tag_value_sep
			 && not (Data.Char.isSpace c))
		R.space_horizontal

-- * Read 'Posting'

posting
 :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s (Context f ts t) (R.Error_State Error m) (Posting, Posting_Type)
posting = (do
	ctx <- R.getState
	sourcepos <- R.getPosition
	R.skipMany1 $ R.space_horizontal
	status_ <- status
	R.skipMany $ R.space_horizontal
	acct <- account
	let (type_, account_) = posting_type acct
	amounts_ <-
		R.choice_try
		 [ do
			_ <- R.count 2 R.space_horizontal
			R.skipMany $ R.space_horizontal
			maybe id (\(u, s) ->
				if u == Unit.nil then id
				else
					Data.Map.adjust (\a ->
						a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
						 , Amount.unit  = u })
					 Unit.nil)
			 (context_unit_and_style ctx) .
			 Amount.from_List <$> do
				R.many_separated Amount.Read.amount $ do
					R.skipMany $ R.space_horizontal
					_ <- R.char amount_sep
					R.skipMany $ R.space_horizontal
					return ()
		 , return Data.Map.empty
		 ] <?> "amounts"
	R.skipMany $ R.space_horizontal
	-- TODO: balance assertion
	-- TODO: conversion
	comments_ <- comments
	let tags_ = tags_of_comments comments_
	dates_ <-
		case Data.Map.lookup "date" tags_ of
		 Nothing -> return []
		 Just dates -> do
			let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
			do
			forM (dates ++ fromMaybe [] date2s) $ \s ->
				R.runParserT_with_Error_fail "tag date" id
				 (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
				 (Text.unpack s) s
			>>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
			 ([], Just (_:_)) ->
				return $ context_date ctx:dates_
			 _ -> return $ dates_
	return (Posting
	 { posting_account=account_
	 , posting_amounts=amounts_
	 , posting_comments=comments_
	 , posting_dates=dates_
	 , posting_sourcepos=sourcepos
	 , posting_status=status_
	 , posting_tags=tags_
	 }, type_)
	) <?> "posting"

amount_sep :: Char
amount_sep = '+'

tags_of_comments :: [Comment] -> Tag_by_Name
tags_of_comments =
	Data.Map.unionsWith (++)
	. Data.List.map
	 ( Data.Either.either (const Data.Map.empty) id
	 . R.runParser (not_tag >> tags <* R.eof) () "" )

status :: Stream s m Char => ParsecT s u m Ledger.Status
status = (do
	( R.try $ do
		R.skipMany $ R.space_horizontal
		_ <- (R.char '*' <|> R.char '!')
		return True )
	<|> return False
	) <?> "status"

-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
posting_type :: Account -> (Posting_Type, Account)
posting_type acct =
	fromMaybe (Posting_Type_Regular, acct) $ do
		case acct of
		 name:|[] ->
			case Text.stripPrefix virtual_begin name of
			 Just name' -> do
				name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
				guard $ not $ Text.null name''
				Just (Posting_Type_Virtual, name'':|[])
			 Nothing -> do
				name' <- liftM Text.strip $
					    Text.stripPrefix virtual_balanced_begin name
					>>= Text.stripSuffix virtual_balanced_end
				guard $ not $ Text.null name'
				Just (Posting_Type_Virtual_Balanced, name':|[])
		 first_name:|acct' -> do
				let rev_acct' = Data.List.reverse acct'
				let last_name = Data.List.head rev_acct'
				case liftM Text.stripStart $
					Text.stripPrefix virtual_begin first_name of
				 Just first_name' -> do
					last_name' <- liftM Text.stripEnd $
						Text.stripSuffix virtual_end last_name
					guard $ not $ Text.null first_name'
					guard $ not $ Text.null last_name'
					Just $
						( Posting_Type_Virtual
						, first_name':|
							Data.List.reverse (last_name':Data.List.tail rev_acct')
						)
				 Nothing -> do
					first_name' <- liftM Text.stripStart $
						Text.stripPrefix virtual_balanced_begin first_name
					last_name'  <- liftM Text.stripEnd $
						Text.stripSuffix virtual_balanced_end last_name
					guard $ not $ Text.null first_name'
					guard $ not $ Text.null last_name'
					Just $
						( Posting_Type_Virtual_Balanced
						, first_name':|
							Data.List.reverse (last_name':Data.List.tail rev_acct')
						)
	where
		virtual_begin          = Text.singleton posting_type_virtual_begin
		virtual_end            = Text.singleton posting_type_virtual_end
		virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
		virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end

posting_type_virtual_begin :: Char
posting_type_virtual_begin = '('
posting_type_virtual_balanced_begin :: Char
posting_type_virtual_balanced_begin = '['
posting_type_virtual_end :: Char
posting_type_virtual_end = ')'
posting_type_virtual_balanced_end :: Char
posting_type_virtual_balanced_end = ']'

-- * Read 'Transaction'

transaction
 :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
 => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
transaction = (do
	ctx <- R.getState
	transaction_sourcepos <- R.getPosition
	transaction_comments_before <-
		comments
		>>= \x -> case x of
		 [] -> return []
		 _  -> return x <* R.new_line
	date_ <- Date.Read.date Error_date (Just $ context_year ctx)
	dates_ <-
		R.option [] $ R.try $ do
			R.skipMany $ R.space_horizontal
			_ <- R.char date_sep
			R.skipMany $ R.space_horizontal
			R.many_separated
			 (Date.Read.date Error_date (Just $ context_year ctx)) $
				R.try $ do
					R.many $ R.space_horizontal
					>> R.char date_sep
					>> (R.many $ R.space_horizontal)
	let transaction_dates = (date_, dates_)
	R.skipMany $ R.space_horizontal
	transaction_status <- status
	transaction_code <- R.option "" $ R.try code
	R.skipMany $ R.space_horizontal
	transaction_description <- description
	R.skipMany $ R.space_horizontal
	transaction_comments_after <- comments
	let transaction_tags =
		Data.Map.unionWith (++)
		 (tags_of_comments transaction_comments_before)
		 (tags_of_comments transaction_comments_after)
	R.new_line
	(postings_unchecked, postings_not_regular) <-
		first (Ledger.posting_by_Account . Data.List.map fst) .
		Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
		R.many1_separated posting R.new_line
	let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
		join (***) (Ledger.posting_by_Account . Data.List.map fst) $
		Data.List.partition ((Posting_Type_Virtual ==) . snd)
		 postings_not_regular
	let tr_unchecked =
		Transaction
		 { transaction_code
		 , transaction_comments_before
		 , transaction_comments_after
		 , transaction_dates
		 , transaction_description
		 , transaction_postings=postings_unchecked
		 , transaction_virtual_postings
		 , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
		 , transaction_sourcepos
		 , transaction_status
		 , transaction_tags
		 }
	transaction_postings <-
		case Balance.infer_equilibrium postings_unchecked of
		 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
		                             (Error_transaction_not_equilibrated tr_unchecked ko)
		 (_bal, Right ok) -> return ok
	transaction_balanced_virtual_postings <-
		case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
		 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
		                             (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
		 (_bal, Right ok) -> return ok
	return $
		tr_unchecked
		 { transaction_postings
		 , transaction_balanced_virtual_postings
		 }
	) <?> "transaction"

date_sep :: Char
date_sep = '='

code :: (Consable f ts t, Stream s m Char)
 => ParsecT s (Context f ts t) m Ledger.Code
code = (do
	fromString <$> do
	R.skipMany $ R.space_horizontal
	R.between (R.char '(') (R.char ')') $
		R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
	) <?> "code"

description :: Stream s m Char => ParsecT s u m Ledger.Description
description = (do
	fromString <$> do
	R.many $ R.try description_char
	) <?> "description"
	where
		description_char :: Stream s m Char => ParsecT s u m Char
		description_char = do
			c <- R.anyChar
			case c of
			 _ | c == comment_begin -> R.parserZero
			 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
			 _ | not (Data.Char.isSpace c) -> return c
			 _ -> R.parserZero

-- * Read directives

default_year
 :: (Consable f ts t, Stream s m Char)
 => ParsecT s (Context f ts t) m ()
default_year = (do
	year <- R.integer_of_digits 10 <$> R.many1 R.digit
	R.skipMany R.space_horizontal >> R.new_line
	context_ <- R.getState
	R.setState context_{context_year=year}
	) <?> "default year"

default_unit_and_style
 :: (Consable f ts t, Stream s m Char)
 => ParsecT s (Context f ts t) m ()
default_unit_and_style = (do
	amount_ <- Amount.Read.amount
	R.skipMany R.space_horizontal >> R.new_line
	context_ <- R.getState
	R.setState context_{context_unit_and_style =
		Just $
		 ( Amount.unit  amount_
		 , Amount.style amount_ )}
	) <?> "default unit and style"

include ::
 ( Consable f ts Transaction
 , Show f
 , Show (ts Transaction)
 , Stream s (R.Error_State Error IO) Char
 )
 => ParsecT s (Context f ts Transaction) (R.Error_State Error IO) ()
include = (do
	sourcepos <- R.getPosition
	filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
	context_ <- R.getState
	let journal_ = context_journal context_
	let cwd = Path.takeDirectory (R.sourceName sourcepos)
	file_path <- liftIO $ Path.abs cwd filename
	content <- do
		join $ liftIO $ Exception.catch
		 (liftM return $ readFile file_path)
		 (return . R.fail_with "include reading" . Error_reading_file file_path)
	(journal_included, context_included) <- do
		liftIO $
			R.runParserT_with_Error (R.and_state $ journal_rec file_path)
			 context_{context_journal = Ledger.journal}
			 file_path content
		>>= \x -> case x of
		 Right ok -> return ok
		 Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
	R.setState $
		context_included{context_journal=
			journal_{journal_includes=
				journal_included{journal_file=file_path}
				: journal_includes journal_}}
	) <?> "include"

-- * Read 'Journal'

journal ::
 ( Consable f ts Transaction
 , Show f
 , Show (ts Transaction)
 , Stream s (R.Error_State Error IO) Char
 )
 => FilePath
 -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
journal file_ = (do
	currentLocalTime <- liftIO $
		Time.utcToLocalTime
		<$> Time.getCurrentTimeZone
		<*> Time.getCurrentTime
	let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
	ctx <- R.getState
	R.setState $ ctx{context_year=currentLocalYear}
	journal_rec file_
	) <?> "journal"

journal_rec ::
 ( Consable f ts Transaction
 , Show f
 , Show (ts Transaction)
 , Stream s (R.Error_State Error IO) Char
 )
 => FilePath
 -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
journal_rec file_ = do
	last_read_time <- liftIO Date.now
	R.skipMany $ do
		R.choice_try
		 [ R.skipMany1 R.space
		 , (do (R.choice_try
			 [ R.string "Y"        >> return default_year
			 , R.string "D"        >> return default_unit_and_style
			 , R.string "!include" >> return include
			 ] <?> "directive")
				>>= \r -> R.skipMany1 R.space_horizontal >> r)
		 , ((do
				t <- transaction
				ctx <- R.getState
				let j = context_journal ctx
				R.setState $
					ctx{context_journal=
						j{journal_transactions=
							mcons (context_filter ctx) t $
								journal_transactions j}}
				R.new_line <|> R.eof))
		 , R.try (void $ comment)
		 ]
	R.eof
	journal_ <- context_journal <$> R.getState
	return $
		journal_
		 { journal_file = file_
		 , journal_last_read_time = last_read_time
		 , journal_includes = reverse $ journal_includes journal_
		 }

-- ** Read 'Journal' from a file

file
 ::
 ( Consable f ts Transaction
 , Show f
 , Show (ts Transaction)
 )
 => Context f ts Transaction
 -> FilePath
 -> ExceptT [R.Error Error] IO (Journal (ts Transaction))
file ctx path = do
	ExceptT $
		Exception.catch
		 (liftM Right $ Text.IO.readFile path) $
		 \ko -> return $ Left $
			 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
	>>= liftIO . R.runParserT_with_Error (journal path) ctx path
	>>= \x -> case x of
	 Left  ko -> throwE $ ko
	 Right ok -> ExceptT $ return $ Right ok