{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
-- | General Ledger
module Hcompta.GL where -- General Ledger

import           Control.Applicative (Const(..))
import           Control.Exception (assert)
import           Data.Data
import qualified Data.Foldable
-- import           Data.Foldable (Foldable)
import           Data.Functor.Compose (Compose(..))
import qualified Data.Sequence
import           Data.Sequence (Seq, (><), (|>), ViewR(..))
import qualified Data.Strict.Maybe as Strict
import qualified Data.Traversable
import qualified Data.Map.Strict as Data.Map
import           Data.Map.Strict (Map)
import           Data.Typeable ()

import qualified Hcompta.Account as Account
import           Hcompta.Account (Account)
import           Hcompta.Date (Date)
import           Hcompta.Lib.Consable
import qualified Hcompta.Lib.TreeMap as TreeMap
import           Hcompta.Lib.TreeMap (TreeMap)

-- * Requirements' interface

-- ** Class 'Amount'
class
 ( Data (Amount_Unit a)
 , Data a
 , Eq a
 , Ord  (Amount_Unit a)
 , Show (Amount_Unit a)
 , Show a
 , Typeable (Amount_Unit a)
 ) => Amount a where
	type Amount_Unit a
	amount_add :: a -> a -> a

-- ** Class 'Posting'

-- | A 'posting' used to produce a 'GL'
--   must be an instance of this class.
class Amount (Posting_Amount p)
 => Posting p where
	type Posting_Amount p
	posting_account :: p -> Account
	posting_amount  :: p -> Posting_Amount p

instance (Amount amount)
 => Posting (Account, amount)
 where
	type Posting_Amount (Account, amount) = amount
	posting_account (x, _) = x
	posting_amount  (_, x) = x

-- ** Class 'Transaction'

class
 ( Posting  (Transaction_Posting t)
 , Data     (Transaction_Posting t)
 , Eq       (Transaction_Posting t)
 , Show     (Transaction_Posting t)
 , Foldable (Transaction_Postings t)
 ) => Transaction t where
	type Transaction_Posting t
	type Transaction_Postings t :: * -> *
	transaction_date     :: t -> Date
	transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
	transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t

{- NOTE: conflicting with the instance below.
instance
 ( Posting posting
 , Data    posting
 , Eq      posting
 , Show    posting
 ) => Transaction (Date, Map Account ([] posting))
 where
	type Transaction_Posting  (Date, Map Account ([] posting)) = posting
	type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
	transaction_date = fst
	transaction_postings = Compose . snd
-}

instance
 ( Posting posting
 , Data    posting
 , Eq      posting
 , Show    posting
 ) => Transaction (Date, [posting])
 where
	type Transaction_Posting  (Date, [posting]) = posting
	type Transaction_Postings (Date, [posting]) = []
	transaction_date     = fst
	transaction_postings = snd
	transaction_postings_filter = fmap . filter

-- * Type 'GL'

newtype Transaction transaction
 => GL transaction
 =  GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction))))
deriving instance ( Transaction transaction
                  , Data        transaction
                  , Typeable    transaction
                  , Typeable GL_Line
                  ) => Data (GL transaction)
deriving instance ( Transaction transaction
                  , Eq          transaction
                  ) => Eq (GL   transaction)
deriving instance ( Transaction transaction
                  , Show        transaction
                  ) => Show (GL transaction)
deriving instance Typeable1 GL
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
instance Transaction transaction
 => Monoid (GL transaction) where
	mempty  = empty
	mappend = union

instance Transaction transaction
 => Consable (Const (GL transaction)) transaction where
	mcons t (Const !gl) = Const $ cons t gl
instance
 ( Foldable foldable
 , Transaction transaction
 )
 => Consable (Const (GL transaction))
 (foldable transaction) where
	mcons ts (Const !gl) =
		Const $ Data.Foldable.foldr cons gl ts

data
 Transaction transaction
 => GL_Line  transaction
 =  GL_Line
 {  gl_line_transaction :: transaction
 ,  gl_line_posting     :: Transaction_Posting transaction
 ,  gl_line_sum         :: Posting_Amount (Transaction_Posting transaction)
 }
deriving instance ( Transaction transaction
                  , Data        transaction
                  , Typeable    transaction
                  , Typeable GL_Line
                  ) => Data (GL_Line transaction)
deriving instance ( Transaction transaction
                  , Eq          transaction
                  ) => Eq (GL_Line transaction)
deriving instance ( Transaction transaction
                  , Show        transaction
                  ) => Show (GL_Line transaction)
deriving instance Typeable1 GL_Line
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- ** Constructors

empty
 :: Transaction transaction
 => GL transaction
empty = GL TreeMap.empty

-- | Return the given 'GL'
--   updated by the given 'Transaction'.
cons
 :: Transaction transaction
 => transaction
 -> GL transaction
 -> GL transaction
cons t (GL gl) =
	GL $
	Data.Foldable.foldr
	 ((\p ->
		let first_line =
			GL_Line
			 { gl_line_transaction = t
			 , gl_line_posting     = p
			 , gl_line_sum         = posting_amount p
			 } in
		let single =
			Data.Map.singleton (transaction_date t) $
			Data.Sequence.singleton first_line in
		TreeMap.insert
		 (\_new old ->
			let (nlt, leq, neq, ngt) =
				case Data.Map.splitLookup (transaction_date t) old of
				 (olt, Nothing, ogt) | Data.Map.null olt ->
					(olt, first_line, Data.Sequence.singleton first_line, ogt)
				 (olt, Nothing, ogt) ->
					let line =
						case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of
						 (_:>GL_Line{gl_line_sum = s}) ->
							first_line{gl_line_sum = amount_add s $ posting_amount p}
						 _ -> first_line
					in (olt, line, Data.Sequence.singleton line, ogt)
				 (olt, Just oeq, ogt) ->
					case Data.Sequence.viewr oeq of
					 (_:>GL_Line{gl_line_sum = s}) ->
						let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in
						(olt, line, oeq |> line, ogt)
					 _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
			in
			Data.Map.union nlt $
			Data.Map.insert (transaction_date t) neq $
			Data.Map.map (fmap (\l -> l{gl_line_sum =
				amount_add (gl_line_sum leq) $
				gl_line_sum l})) ngt
		 )
		 (posting_account p)
		 single
	 ))
	 gl
	 (transaction_postings t)

union
 :: Transaction transaction
 => GL transaction
 -> GL transaction
 -> GL transaction
union (GL gl0) (GL gl1) =
	GL $
	TreeMap.union
	 (Data.Map.unionWith mappend)
	 gl0 gl1

-- * Type 'Expanded'

-- | Descending propagation of 'Amount's accross 'Account's.
type Expanded transaction
 = TreeMap Account.Name (GL_Line_Expanded transaction)
data Transaction     transaction
 => GL_Line_Expanded transaction
 =  GL_Line_Expanded
 { exclusive :: Map Date (Seq (GL_Line transaction))
 , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 }
deriving instance ( Transaction transaction
                  , Data        transaction
                  ) => Data (GL_Line_Expanded transaction)
deriving instance ( Transaction transaction
                  , Eq          transaction
                  ) => Eq (GL_Line_Expanded transaction)
deriving instance ( Transaction transaction
                  , Show        transaction
                  ) => Show (GL_Line_Expanded transaction)
deriving instance Typeable1 GL_Line_Expanded
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- | Return the given 'GL' with:
--
-- * all missing 'Account.ascending' 'Account's inserted,
--
-- * and every mapped 'GL_Line'
-- added with any 'GL_Line'
-- of the 'Account's for which it is 'Account.ascending'.
expanded
 :: Transaction transaction
 => GL          transaction
 -> Expanded    transaction
expanded (GL gl) =
	let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in
	TreeMap.map_by_depth_first
	 (\descendants value ->
		let nodes = TreeMap.nodes descendants in
		let exclusive = Strict.fromMaybe Data.Map.empty value in
		GL_Line_Expanded
		 { exclusive
		 , inclusive =
			getCompose $
			snd $
			Data.Traversable.mapAccumL
			 (\ms line ->
				let pamt = posting_amount $ gl_line_posting line in
				case ms of
				 Nothing -> (Just pamt, line)
				 Just s ->
					let ls = amount_add s pamt in
					( Just ls
					, line{gl_line_sum=ls} )
			 ) Nothing $
			Compose $
			Data.Map.foldr
			 (Data.Map.unionWith (><) . inclusive . from_value)
			 exclusive nodes
		 })
	 gl