{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Command.Stats where

import           Control.Applicative (Const(..))
import           Control.Arrow ((+++))
import           Control.Monad (Monad(..), liftM, mapM)
import           Control.Monad.IO.Class (liftIO)
import           Data.Bool (Bool(..))
import           Data.Either (Either(..), partitionEithers)
import           Data.Foldable (Foldable(..))
import           Data.Function (($), (.), on)
import           Data.Functor ((<$>))
import           Data.List ((++))
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..), (<>))
import           Data.Text (Text)
import           Data.String (String)
import           Prelude (Bounded(..), Num(..), flip, unlines)
import           System.Console.GetOpt
                 ( ArgDescr(..)
                 , OptDescr(..)
                 , usageInfo )
import           System.Environment as Env (getProgName)
import           System.Exit (exitSuccess)
import qualified System.IO as IO
import           System.IO (FilePath, IO)

import qualified Hcompta.Unit as Unit
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.JCC ()
import           Hcompta.CLI.Format.Ledger ()
import           Hcompta.CLI.Format (Format(..), Formats)
import qualified Hcompta.CLI.Format as Format
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
import qualified Hcompta.Posting as Posting
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
import qualified Hcompta.Filter.Amount as Filter.Amount
import qualified Hcompta.Format.JCC as JCC
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Lib.Interval as Interval
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Stats as Stats

data Context
 =   Context
 { ctx_input              :: [FilePath]
 , ctx_input_format       :: Formats
 , ctx_filter_transaction :: forall t.
                             ( Filter.Transaction t
                             , Filter.Amount_Quantity
                               (Posting.Posting_Amount
                               (Filter.Transaction_Posting t))
                               ~ Filter.Amount.Quantity
                             ) => Journal_Filter t
 , ctx_output_format      :: Maybe Formats
 }

context :: Context
context =
	Context
	 { ctx_input = []
	 , ctx_input_format       = mempty
	 , ctx_filter_transaction = Filter.Simplified $ Right True
	 , ctx_output_format      = Nothing
	 }

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_Stats
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" stats ["++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 Context
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 "if" ["input-format"]
	 (OptArg (\arg ctx -> do
		ctx_input_format <- case arg of
		 Nothing       -> return $ Format_JCC ()
		 Just "jcc"    -> return $ Format_JCC ()
		 Just "ledger" -> return $ Format_Ledger ()
		 Just _        -> Write.fatal c $
			W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
		return $ ctx{ctx_input_format})
	  "[jcc|ledger]")
	  "input format"
	, Option "of" ["output-format"]
	 (OptArg (\arg ctx -> do
		ctx_output_format <- case arg of
		 Nothing       -> return $ Just $ Format_JCC ()
		 Just "jcc"    -> return $ Just $ Format_JCC ()
		 Just "ledger" -> return $ Just $ Format_Ledger ()
		 Just _        -> Write.fatal c $
			W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
		return $ ctx{ctx_output_format})
	  "[jcc|ledger]")
	  "input format"
	, Option "t" ["filter-transaction"]
	 (ReqArg (\s ctx -> do
		filter <-
			R.runParserT_with_Error
			 Filter.Read.filter_transaction
			 Filter.Read.context "" s
		case filter of
		 Left ko -> Write.fatal c ko
		 Right flt ->
			return $
				ctx{ctx_filter_transaction =
					Filter.and (ctx_filter_transaction ctx) $
					(Filter.simplify $
						Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
				 }) $
		C.translate c Lang.Type_Filter_Transaction) $
		C.translate c Lang.Help_Option_Filter_Transaction
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <- Args.parse c usage options (context, args)
	input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
	read_journals <- mapM (liftIO . journal_read ctx) input_paths
	case partitionEithers read_journals of
	 (errs@(_:_), _journals) -> Write.fatals c errs
	 ([], (journals::[Forall_Stats])) -> do
		with_color <- Write.with_color c IO.stdout
		W.displayIO IO.stdout $
			W.renderPretty with_color 1.0 maxBound $
			stats_write c ctx $
			(Const::x -> Const x ()) $
			mconcat $ Format.journal_flatten <$>
				case ctx_output_format ctx of
				 Nothing -> journals
				 Just f -> Format.journal_empty f:journals

-- * Type 'Format_Journal'

type Format_Journal
 = Format
   (   JCC.Journal Stats_JCC)
   (Ledger.Journal Stats_Ledger)

type Stats_JCC    = Stats.Stats (   JCC.Charted    JCC.Transaction)
type Stats_Ledger = Stats.Stats (Ledger.Charted Ledger.Transaction)

-- * Class 'Stats'

class Stats j m where
	stats_write :: C.Context -> Context -> j m -> W.Doc
instance
 ( Stats.Transaction t
 , t ~ (Format.Journal_Charted j) (Format.Journal_Transaction j)
 , Stats.Posting_Unit (Stats.Transaction_Posting t) ~ Format.Journal_Unit j
 , Unit.Unit (Format.Journal_Unit j)
 , Format.Journal_Content j
 , Format.Journal_Files j
 ) => Stats j (Stats.Stats t) where
	stats_write c _ctx j =
		let stats = Format.journal_content j in
		render
		[ (Lang.Header_Accounts,) . W.toDoc () $
			Map.size $ Stats.stats_accounts stats
		, (Lang.Header_Accounts_Depth,) $
			let depth = Stats.stats_accounts_depths stats in
			W.toDoc () (Interval.limit $ Interval.low  depth) <>
			(W.bold $ W.dullyellow "..") <>
			W.toDoc () (Interval.limit $ Interval.high depth)
		, (Lang.Header_Transactions,) . W.toDoc () $
			Stats.stats_transactions stats
		, (Lang.Header_Transactions_Date,) $
			case Stats.stats_transactions_span stats of
			 Nothing -> W.empty
			 Just date ->
				W.toDoc () (Interval.limit $ Interval.low date) <>
				(W.bold $ W.dullyellow "..") <>
				W.toDoc () (Interval.limit $ Interval.high date)
		, (Lang.Header_Units,) . W.toDoc () $
			Map.size $ Map.delete Unit.unit_empty $
			Stats.stats_units stats
		, (Lang.Header_Journals,) . W.toDoc () $
			List.length $ Format.journal_files j
		, (Lang.Header_Tags,) . W.toDoc () $
			W.toDoc () (foldr (flip $ foldr (+)) 0 $
				Stats.stats_tags stats)
		, (Lang.Header_Tags_Distinct,) . W.toDoc () $
			Map.size $ Stats.stats_tags stats
		]
		where
			render :: Lang.Translate h [Text] => [(h, W.Doc)] -> W.Doc
			render =
				foldMap $ \(h, x) ->
					W.hcat
					 [ W.bold $ flip foldMap
						 (C.translate c h::[Text]) $ \s ->
							W.dullblack (W.toDoc () s) <> W.dullyellow ":"
					 , W.toDoc () x
					 , W.line ]

instance Format.Journal (JCC.Journal Stats_JCC) where
	type Journal_Format   (JCC.Journal Stats_JCC) = Format_Journal
	journal_format = Format_JCC

instance Format.Journal (Ledger.Journal Stats_Ledger) where
	type Journal_Format   (Ledger.Journal Stats_Ledger) = Format_Journal
	journal_format = Format_Ledger

-- * Type 'Forall_Stats'

data Forall_Stats
 = forall j m. ( Stats j m
               , Format.Journal (j m)
               , Format.Journal_Content j
               , Format.Journal_Files j
               , Format.Journal_Read j
               , Format.Journal_Monoid (j m)
               , Format.Journal_Format (j m) ~ Format_Journal )
 => Forall_Stats (j m)

instance Format.Journal Forall_Stats where
	type Journal_Format   Forall_Stats = Format_Journal
	journal_format  (Forall_Stats j) = Format.journal_format j
instance Format.Journal_Empty Forall_Stats where
	journal_empty f =
		case f of
		 Format_JCC    () -> Forall_Stats (mempty::JCC.Journal    Stats_JCC)
		 Format_Ledger () -> Forall_Stats (mempty::Ledger.Journal Stats_Ledger)

instance Format.Journal_Monoid Forall_Stats where
	journal_flatten (Forall_Stats j) = Forall_Stats $ Format.journal_flatten j
	journal_fold f  (Forall_Stats j) = Format.journal_fold (f . Forall_Stats) j
instance Stats (Const Forall_Stats) () where
	stats_write c ctx (Const (Forall_Stats j)) = stats_write c ctx j
instance Monoid Forall_Stats where
	mempty = Forall_Stats (mempty::JCC.Journal Stats_JCC)
	mappend x y =
		case (mappend `on` Format.journal_format) x y of
		 Format_JCC    j -> Forall_Stats j
		 Format_Ledger j -> Forall_Stats j
	mconcat js =
		case js of
		 [] -> mempty
		 j:jn -> foldl' mappend j jn

type Journal_Filter transaction
 = Filter.Simplified
   (Filter.Filter_Bool
   (Filter.Filter_Transaction transaction))
type Journal_Read_Cons txn
 = txn -> Filter.Filtered (Journal_Filter txn) txn

journal_read
 :: Context -> FilePath
 -> IO (Either (Format.Message W.Doc) Forall_Stats)
journal_read ctx =
	case ctx_input_format ctx of
	 Format_JCC () ->
		let wrap (j::JCC.Journal Stats_JCC) = Forall_Stats j in
		let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
			 = Filter.Filtered (ctx_filter_transaction ctx) in
		liftM ((+++) Format.Message wrap) .
		Format.journal_read cons
	 Format_Ledger () ->
		let wrap (j::Ledger.Journal Stats_Ledger) = Forall_Stats j in
		let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
			 = Filter.Filtered (ctx_filter_transaction ctx) in
		liftM ((+++) Format.Message wrap) .
		Format.journal_read cons