{-# 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: not needed so far.
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
	transaction_postings_filter f =
		fmap $
		Data.Map.mapMaybe
		 (\p -> case filter f p of
			 [] -> Nothing
			 ps -> Just ps)
-}
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

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 mempty

-- | Return the given 'GL'
--   updated by the given 'Transaction'.
--
-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
--       the given 'GL' is matched strictly.
cons
 :: Transaction transaction
 => transaction
 -> GL transaction
 -> GL transaction
cons t (GL !gl) =
	GL $
	Data.Foldable.foldl'
	 (flip $ \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 (flip (><)) . inclusive . from_value)
			 exclusive nodes
		 })
	 gl