{-# 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

-- import           Control.Applicative (Const(..))
import           Control.DeepSeq (NFData(..))
import           Control.Exception (assert)
import           Data.Bool
import           Data.Data
import           Data.Eq (Eq(..))
import qualified Data.Foldable
import           Data.Foldable (Foldable(..))
import           Data.Functor (Functor(..))
import           Data.Functor.Compose (Compose(..))
import           Data.List (filter)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..))
import qualified Data.Sequence
import           Data.Sequence (Seq, (><), (|>), ViewR(..))
import qualified Data.Strict.Maybe as Strict
import qualified Data.Traversable
import           Data.Tuple (fst, snd)
import           Data.Typeable ()
import           Prelude (($), (.), flip, seq, undefined)
import           Text.Show (Show(..))

import           Hcompta.Quantity (Addable(..))
import           Hcompta.Account (Account(..))
import           Hcompta.Date (Date)
import qualified Hcompta.Lib.TreeMap as TreeMap
import           Hcompta.Lib.TreeMap (TreeMap)

-- * Requirements' interface

-- ** Class 'Posting'

class
 ( Account (Posting_Account   p)
 , Addable (Posting_Quantity  p)
 , Data    (Posting_Quantity  p)
 , NFData  (Posting_Quantity  p)
 , Show    (Posting_Quantity  p)
 ) =>  Posting           p where
	type Posting_Account   p
	type Posting_Quantity  p
	posting_account  :: p -> Posting_Account  p
	posting_quantity :: p -> Posting_Quantity p

instance
 ( Account account
 , Addable quantity
 , NFData  quantity )
 => Posting (account, quantity)
 where
	type Posting_Account   (account, quantity) = account
	type Posting_Quantity  (account, quantity) = quantity
	posting_account  (x, _) = x
	posting_quantity (_, x) = x

-- ** Class 'Transaction'

class
 ( Data     (Transaction_Posting  t)
 , Posting  (Transaction_Posting  t)
 , NFData   (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
 , account ~ Posting_Account 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 $
		Map.mapMaybe
		 (\p -> case filter f p of
			 [] -> Nothing
			 ps -> Just ps)
-}

instance
 ( Posting posting
 , Data    posting
 , Eq      posting
 , NFData  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_Section (Posting_Account (Transaction_Posting transaction)))
                (Map Date
                     (Seq (GL_Line transaction))))
deriving instance ( Transaction transaction
                  , Data        transaction
                  ) => Data (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 t
 , NFData t
 ) => NFData (GL t) where
	rnf (GL t) = rnf t

data
 Transaction transaction
 => GL_Line  transaction
 =  GL_Line
 {  gl_line_transaction :: transaction
 ,  gl_line_posting     :: Transaction_Posting transaction
 ,  gl_line_sum         :: Posting_Quantity (Transaction_Posting transaction)
 }
deriving instance ( Transaction transaction
                  , Data        transaction
                  , Typeable    transaction
                  , Typeable1 GL_Line
                  ) => Data (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
instance
 ( Transaction t
 , NFData t
 ) => NFData (GL_Line t) where
	rnf (GL_Line x y z) = rnf x `seq` rnf y `seq` rnf z

-- ** 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_quantity p
			 } in
		let single =
			Map.singleton (transaction_date t) $
			Data.Sequence.singleton first_line in
		TreeMap.insert
		 (\_new old ->
			let (nlt, leq, neq, ngt) =
				case Map.splitLookup (transaction_date t) old of
				 (olt, Nothing, ogt) | Map.null olt ->
					(olt, first_line, Data.Sequence.singleton first_line, ogt)
				 (olt, Nothing, ogt) ->
					let line =
						case Data.Sequence.viewr $ snd $ Map.findMax olt of
						 (_:>GL_Line{gl_line_sum = s}) ->
							first_line{gl_line_sum = quantity_add s $ posting_quantity 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 = quantity_add s $ posting_quantity p} in
						(olt, line, oeq |> line, ogt)
					 _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
			in
			Map.union nlt $
			Map.insert (transaction_date t) neq $
			Map.map
			 (fmap (\l -> l{gl_line_sum =
				quantity_add (gl_line_sum leq) $ gl_line_sum l}))
			 ngt
		 )
		 (account_path $ 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
	 (Map.unionWith mappend)
	 gl0 gl1

-- * Type 'Expanded'

-- | Descending propagation of 'Amount's accross 'Account's.
type Expanded transaction
 = TreeMap (Account_Section (Posting_Account (Transaction_Posting transaction)))
           (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))) -- ^ 'quantity_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
                  , 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
	 (\(TreeMap.TreeMap nodes) value ->
		let exclusive = Strict.fromMaybe Map.empty value in
		GL_Line_Expanded
		 { exclusive
		 , inclusive =
			getCompose $
			snd $
			Data.Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
			 (\msum line ->
				let qty = posting_quantity $ gl_line_posting line in
				case msum of
				 Nothing -> (Just qty, line)
				 Just last_sum ->
					let new_sum = quantity_add last_sum qty in
					( Just new_sum
					, line{gl_line_sum=new_sum} )
			 ) Nothing $
			Compose $
			Map.foldr
			 (Map.unionWith (flip (><)) . inclusive . from_value)
			 exclusive nodes
		 })
	 gl