{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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           Data.Foldable (Foldable(..))
-- import qualified Data.Foldable as Foldable
import           Data.Function (($), (.), flip, id)
import           Data.Functor (Functor(..))
import           Data.Functor.Compose (Compose(..))
-- import qualified Data.List as List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..))
import qualified Data.MonoTraversable as MT
import           Data.Sequence (Seq, (><), (|>), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.Traversable as Traversable
import           Data.TreeMap.Strict (TreeMap(..))
import qualified Data.TreeMap.Strict as TreeMap
import           Data.Tuple (snd)
import           Data.Typeable ()
import           Prelude (seq, undefined)
import           Text.Show (Show(..))

import           Hcompta.Account
import           Hcompta.Date
import qualified Hcompta.Lib.Strict as Strict
import           Hcompta.Posting
import           Hcompta.Quantity
import           Hcompta.Transaction

-- * Class 'GL_Posting'

class
 ( Posting p
 , Addable (GL_Posting_Quantity p)
 , Data    (GL_Posting_Quantity p)
 , NFData  (GL_Posting_Quantity p)
 , Show    (GL_Posting_Quantity p)
 ) => GL_Posting p where
	type GL_Posting_Quantity p
	gl_posting_quantity :: p -> GL_Posting_Quantity p

{-
instance
 ( Account account
 , Amount quantity
 , Posting (account, quantity)
 , Addable quantity
 , NFData  quantity
 ) => GL_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 'GL_Transaction'

class
 ( Transaction t
 , GL_Posting      (Transaction_Posting  t)
 , Data            (Transaction_Posting  t)
 , NFData          (Transaction_Posting  t)
 , Show            (Transaction_Posting  t)
 , MT.Element      (Transaction_Postings t) ~ Transaction_Posting t
 , MT.MonoFoldable (Transaction_Postings t)
 , Data   (GL_Transaction_Line t)
 , Show   (GL_Transaction_Line t)
 , NFData (GL_Transaction_Line t)
 ) => GL_Transaction t where
	type GL_Transaction_Line t
	gl_transaction_line :: t -> GL_Transaction_Line t
	-- gl_transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t

{- NOTE: not needed so far.
instance
 ( GL_Posting posting
 , Data    posting
 , Eq      posting
 , Show    posting
 , account ~ Posting_Account posting
 ) => GL_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
	gl_transaction_postings_filter f =
		fmap $
		Map.mapMaybe
		 (\p -> case filter f p of
			 [] -> Nothing
			 ps -> Just ps)
-}

instance
 ( GL_Posting posting
 , Data       posting
 , NFData     posting
 , Show       posting
 ) => GL_Transaction (Date, [posting])
 where
	type GL_Transaction_Line (Date, [posting]) = (Date, [posting])
	gl_transaction_line            = id
	-- gl_transaction_postings_filter = fmap . List.filter

-- * Type 'GL'

newtype GL_Transaction t
 =>     GL             t
 =      GL (TreeMap (Account_Section (Posting_Account (Transaction_Posting t)))
                    (Map Date (Seq (GL_Line t))))
deriving instance -- Data
 ( GL_Transaction t
 , Data t
 ) => Data (GL t)
instance -- Monoid
 GL_Transaction t
 => Monoid (GL t) where
	mempty  = gl_empty
	mappend = gl_union
instance -- NFData
 ( GL_Transaction t
 , NFData t
 ) => NFData (GL t) where
	rnf (GL t) = rnf t
deriving instance -- Show
 ( GL_Transaction t
 , Show t
 ) => Show (GL t)
deriving instance -- Typeable
 Typeable1 GL
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- ** Type 'GL_Line'

data GL_Line transaction
 =   GL_Line
 {   gl_line_transaction :: GL_Transaction_Line transaction
 ,   gl_line_posting     :: Transaction_Posting transaction
 ,   gl_line_sum         :: GL_Posting_Quantity (Transaction_Posting transaction)
 }
deriving instance -- Data
 ( GL_Transaction t
 , Data t
 , Typeable t
 , Typeable1 GL_Line
 ) => Data (GL_Line t)
instance -- NFData
 ( GL_Transaction t
 , NFData t
 ) => NFData (GL_Line t) where
	rnf GL_Line{..} =
		rnf gl_line_transaction `seq`
		rnf gl_line_posting `seq`
		rnf gl_line_sum
deriving instance -- Show
 ( GL_Transaction t
 ) => Show (GL_Line t)
deriving instance -- Typeable
 Typeable1 GL_Line
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- ** Constructors

gl_empty
 :: GL_Transaction transaction
 => GL transaction
gl_empty = GL mempty

-- | Return the given 'GL'
--   updated by the given 'GL_Transaction'.
--
-- NOTE: to reduce memory consumption when applying 'gl_cons' iteratively,
--       the given 'GL' is matched strictly.
gl_cons
 :: GL_Transaction transaction
 => transaction
 -> GL transaction
 -> GL transaction
gl_cons t (GL !gl) =
	GL $
	MT.ofoldl'
	 (flip $ \p ->
		let first_line =
			GL_Line
			 { gl_line_transaction = gl_transaction_line t
			 , gl_line_posting     = p
			 , gl_line_sum         = gl_posting_quantity p
			 } in
		let single =
			Map.singleton (transaction_date t) $
			Seq.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, Seq.singleton first_line, ogt)
				 (olt, Nothing, ogt) ->
					let line =
						case Seq.viewr $ snd $ Map.findMax olt of
						 (_:>GL_Line{gl_line_sum = s}) ->
							first_line{gl_line_sum = quantity_add s $ gl_posting_quantity p}
						 _ -> first_line
					in (olt, line, Seq.singleton line, ogt)
				 (olt, Just oeq, ogt) ->
					case Seq.viewr oeq of
					 (_:>GL_Line{gl_line_sum = s}) ->
						let line = first_line{gl_line_sum = quantity_add s $ gl_posting_quantity p} in
						(olt, line, oeq |> line, ogt)
					 _ -> (olt, first_line, Seq.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)

gl_union
 :: GL_Transaction transaction
 => GL transaction
 -> GL transaction
 -> GL transaction
gl_union (GL x) (GL y) =
	GL $ TreeMap.union (Map.unionWith mappend) x y

-- * Type 'GL_Expanded'

-- | Descending propagation of 'Amount's accross 'Account's.
newtype GL_Transaction transaction
 =>     GL_Expanded    transaction
 =      GL_Expanded (TreeMap (Account_Section (Posting_Account (Transaction_Posting transaction)))
                             (GL_Expanded_Line transaction))

-- ** Type 'GL_Expanded_Line'

-- |
-- * 'Strict.exclusive': contains the original 'GL_Line's.
-- * 'Strict.inclusive': contains 'quantity_add' folded
--   over 'Strict.exclusive' and  'Strict.inclusive'
--   of 'TreeMap.node_descendants'
type GL_Expanded_Line transaction
 = Strict.Clusive (Map Date (Seq (GL_Line transaction)))

-- | Return the given 'GL' with:
--
-- * all missing 'Account.parent' 'Account's inserted;
-- * and every mapped 'GL_Line'
--   added with any 'GL_Line'
--   of the 'Account's for which it is 'Account.parent'.
gl_expanded
 :: GL_Transaction transaction
 => GL             transaction
 -> GL_Expanded    transaction
gl_expanded (GL gl) =
	let from_value =
		Strict.fromMaybe (assert False undefined) .
		TreeMap.node_value in
	GL_Expanded $
	TreeMap.map_by_depth_first
	 (\(TreeMap nodes) value ->
		let exclusive = Strict.fromMaybe Map.empty value in
		Strict.Clusive
		 { Strict.exclusive
		 , Strict.inclusive =
			getCompose $
			snd $
			Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
			 (\may_sum line ->
				let amts = gl_posting_quantity $ gl_line_posting line in
				case may_sum of
				 Nothing -> (Just amts, line)
				 Just last_sum ->
					let new_sum = quantity_add last_sum amts in
					( Just new_sum
					, line{gl_line_sum=new_sum} )
			 ) Nothing $
			Compose $
			Map.foldr
			 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
			 exclusive nodes
		 })
	 gl