{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.CLI.Command.Tags where

import           Control.DeepSeq (NFData(..))
import           Control.Monad (Monad(..), forM_, liftM, mapM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import           Data.Bool
import           Data.Either (Either(..), partitionEithers)
import           Data.Foldable (Foldable(..))
import           Data.Functor ((<$>))
import           Data.Functor.Compose (Compose(..))
import           Data.List ((++))
import qualified Data.List (filter)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Data.Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..), (<>))
import           Data.String (String)
import           Prelude (($), (.), FilePath, Integer, IO, Num(..), flip, id, unlines)
import           Text.Show (Show(..))
import           System.Console.GetOpt
                 ( ArgDescr(..)
                 , OptDescr(..)
                 , usageInfo )
import           System.Environment as Env (getProgName)
import           System.Exit (exitSuccess)
import qualified System.IO as IO

import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Env as CLI.Env
import           Hcompta.CLI.Format.Ledger ()
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import           Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Tag as Tag
import           Hcompta.Transaction (Transaction_Tags(..))

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 , ctx_filter_transaction :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Transaction
                             (Ledger.Chart_With Ledger.Transaction)))
 , ctx_filter_tag         :: Filter.Simplified
                             Filter.Filter_Tags
 , ctx_tree               :: Bool
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_input = []
	 , ctx_filter_transaction = mempty
	 , ctx_filter_tag = mempty
	 , ctx_tree = False
	 }

usage :: C.Context -> IO String
usage c = do
	bin <- Env.getProgName
	return $ unlines $
		[ C.translate c Lang.Section_Description
		, "  "++C.translate c Lang.Help_Command_Tags
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" tags ["++C.translate c Lang.Type_Option++"] [...]"++
		                  " ["++C.translate c Lang.Type_File_Journal++"] [...]"
		, ""
		, usageInfo (C.translate c Lang.Section_Options) (options c)
		]

options :: C.Context -> Args.Options Ctx
options c =
	[ Option "h" ["help"]
	 (NoArg (\_ctx -> do
		usage c >>= IO.hPutStr IO.stderr
		exitSuccess)) $
		C.translate c Lang.Help_Option_Help
	, Option "i" ["input"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_input=s:ctx_input ctx}) $
		C.translate c Lang.Type_File_Journal) $
		C.translate c Lang.Help_Option_Input
	, Option "t" ["transaction-filter"]
	 (ReqArg (\s ctx -> do
		ctx_filter_transaction <-
			liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
			liftIO $ Filter.Read.read Filter.Read.filter_transaction s
			>>= \f -> case f of
			 Left  ko -> Write.fatal c $ ko
			 Right ok -> do
				Write.debug c $ "filter: transaction: " ++ show ok
				return ok
		return $ ctx{ctx_filter_transaction}) $
		C.translate c Lang.Type_Filter_Transaction) $
		C.translate c Lang.Help_Option_Filter_Transaction
	, Option "T" ["tag-filter"]
	 (ReqArg (\s ctx -> do
		ctx_filter_tag <-
			liftM ((ctx_filter_tag ctx <>) . Filter.simplify) $
			liftIO $ Filter.Read.read Filter.Read.filter_tag s
			>>= \f -> case f of
			 Left  ko -> Write.fatal c $ ko
			 Right ok -> do
				Write.debug c $ "filter: tag: " ++ show ok
				return ok
		return $ ctx{ctx_filter_tag}) $
		C.translate c Lang.Type_Filter_Tag) $
		C.translate c Lang.Help_Option_Filter_Tag
	, Option "" ["tree"]
	 (OptArg (\arg ctx -> do
		ctx_tree <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c Lang.Error_Option_Tags_Tree
		return $ ctx{ctx_tree})
	  "[no|yes]") $
		C.translate c Lang.Help_Option_Tags_Tree
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <- Args.parse c usage options (nil, args)
	read_journals <-
		liftM Data.Either.partitionEithers $ do
		CLI.Env.paths c $ ctx_input ctx ++ inputs
		>>= do
			mapM $ \path -> do
				liftIO $ runExceptT $ Ledger.Read.file
				 (Ledger.Read.context
					 ( ctx_filter_transaction ctx
					 , ctx_filter_tag ctx
					 ) Ledger.journal)
				 path
				>>= \x -> case x of
				 Left  ko -> return $ Left (path, ko)
				 Right ok -> return $ Right ok
	case read_journals of
	 (errs@(_:_), _journals) ->
		forM_ errs $ \(_path, err) -> do
			Write.fatal c $ err
	 ([], journals) -> do
		let files = ledger_tags ctx journals
		Write.write c Write.style [(Write.Mode_Append, "-")] $ do
		doc_tags c ctx files

ledger_tags
 :: Ctx
 -> [ Ledger.Journal (Tags (Ledger.Chart_With Ledger.Transaction)) ]
 -> Tags (Ledger.Chart_With Ledger.Transaction)
ledger_tags _ctx =
	Data.Foldable.foldl'
	 (flip $ Ledger.Journal.fold
		 (\Ledger.Journal{Ledger.journal_sections=ts} ->
			mappend ts))
	 mempty

doc_tags
 :: C.Context
 -> Ctx
 -> Tags (Ledger.Chart_With Ledger.Transaction)
 -> W.Doc
doc_tags _context ctx =
	(case ctx_tree ctx of
	 True ->
		Data.Map.foldlWithKey
		 (\doc p vs ->
			doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
			" (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
			W.nest 2 (
				Data.Map.foldlWithKey
				 (\doc' v vn ->
					doc' <> W.line <> W.dullred (W.toDoc () v) <>
					" (" <> (W.toDoc () vn) <> ")"
				 )
				 W.empty vs
			 ) <> W.line
		 )
		 W.empty
	 False ->
		Data.Map.foldlWithKey
		 (\doc p vs ->
			doc <>
			Data.Map.foldlWithKey
			 (\doc' v _vn ->
				doc' <>
				foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
				W.dullred (W.toDoc () v) <> W.line
			 ) W.empty vs
		 )
		 W.empty
	 ) .
	tags

-- * Requirements' interface

-- ** Class 'Posting'

class Posting        p where
	posting_account :: p -> Ledger.Account

instance Posting Ledger.Posting where
	posting_account = Ledger.posting_account

-- ** Class 'Transaction'

class
 ( Posting  (Transaction_Posting  t)
 , Foldable (Transaction_Postings t)
 )
 =>    Transaction          t where
	type Transaction_Posting  t
	type Transaction_Postings t :: * -> *
	-- transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
	transaction_tags          :: t -> Transaction_Tags

instance Transaction        Ledger.Transaction where
	type Transaction_Posting  Ledger.Transaction = Ledger.Posting
	type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Ledger.Account) [])
	transaction_tags = Ledger.transaction_tags

instance Transaction        (Ledger.Chart_With Ledger.Transaction) where
	type Transaction_Posting  (Ledger.Chart_With Ledger.Transaction) = Transaction_Posting Ledger.Transaction
	type Transaction_Postings (Ledger.Chart_With Ledger.Transaction) = Transaction_Postings Ledger.Transaction
	transaction_tags = transaction_tags . Ledger.with_chart

-- * Type 'Tags'

data Transaction t => Tags t
 = Tags
 { tags :: Map Tag.Path (Map Tag.Value Integer)
 }
 deriving (Show)

instance Transaction t => Monoid (Tags t) where
	mempty = Tags mempty
	mappend t0 t1 =
		Tags
		 { tags = Data.Map.unionWith
			 (Data.Map.unionWith (+))
			 (tags t0)
			 (tags t1)
		 }
instance NFData t => NFData (Tags t) where
	rnf (Tags t) = rnf t

instance Transaction t
 => Consable (Filter.Simplified Filter.Filter_Tags)
             Tags
             t where
	mcons f t !ts =
		let Transaction_Tags (Tag.Tags ttags) = transaction_tags t in
		case Filter.simplified f of
		 Right False -> ts
		 Right True  -> ts{ tags = merge ttags (tags ts) }
		 Left fT ->
			ts{ tags = merge
			 (Data.Map.mapMaybeWithKey
				 (\p vs ->
					if Filter.test fT $
						Tag.Tags $
						Data.Map.singleton p vs
					then Just $ Data.List.filter
					 (\v -> Filter.test fT $
						Tag.Tags $
						Data.Map.singleton p [v]) vs
					else Nothing)
				 ttags)
			 (tags ts)
			 }
		where
			merge
			 :: Map Tag.Path [Tag.Value]
			 -> Map Tag.Path (Map Tag.Value Integer)
			 -> Map Tag.Path (Map Tag.Value Integer)
			merge =
				Data.Map.mergeWithKey
				 (\_k x1 x2 -> Just $
					Data.Map.unionWith (+) x2 $
					Data.Map.fromListWith (+) $ (, 1) <$> x1)
				 ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
				 id
instance
 ( Filter.Transaction t
 , Transaction        t
 ) => Consable
 ( Filter.Simplified
    (Filter.Filter_Bool
    (Filter.Filter_Transaction t))
 ,  Filter.Simplified Filter.Filter_Tags
 )
 Tags t where
	mcons (ft, fT) t !ts =
		if Filter.test ft t
		then mcons fT t ts
		else ts