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

import           Control.Exception (assert)
import           Data.Data
import qualified Data.Foldable
import           Data.Foldable (Foldable)
import           Data.Functor.Compose (Compose(..))
import           Data.Maybe (fromMaybe)
import qualified Data.Sequence
import           Data.Sequence (Seq, (><), (|>), ViewR(..))
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 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)

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

-- * 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

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

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

-- | Return the given 'GL'
--   updated by the given 'Posting'.
general_ledger
 :: Transaction transaction
 => transaction
 -> GL transaction
 -> GL transaction
general_ledger 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)

-- * 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 = fromMaybe (assert False undefined) . TreeMap.node_value in
	TreeMap.map_by_depth_first
	 (\descendants value ->
		let nodes = TreeMap.nodes descendants in
		let exclusive = 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