-- | General Ledger
module Hcompta.GL where

import Control.DeepSeq (NFData(..))
import Control.Exception (assert)
import Data.Bool
import Data.Data
import Data.Eq (Eq(..))
import Data.Function (($), (.), flip)
import Data.Functor (Functor(..))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Sequence (Seq, (><), (|>), ViewR(..))
import Data.TreeMap.Strict (TreeMap(..))
import Data.Tuple (snd)
import Data.Typeable ()
import Prelude (seq, undefined)
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.Traversable as Traversable
import qualified Data.TreeMap.Strict as TM

import Hcompta.Data
import Hcompta.Quantity
import qualified Hcompta.Lib.Strict as Strict

-- * Type 'GL'
newtype GL txn date post name amt
 =      GL (TreeMap name
                    (Map date (Seq (LineGL txn post amt))))
 deriving (Data, Eq, NFData, Show, Typeable)

instance Zeroable (GL txn date post name amt) where
	zero = GL zero
instance (Ord name, Ord date) => Addable (GL txn date post name amt) where
	GL x + GL y = GL $ TM.union (Map.unionWith (flip (+))) x y
-- | NOTE: to reduce memory consumption when applying '(+=)' iteratively,
--   the given 'GL' is matched strictly.
instance ( post ~ MT.Element posts
         , MT.MonoFoldable posts
         , Get posts txn
         , Get date txn
         , Get amt post
         , Get (TM.Path name) post
         , Addable amt
         , Ord name
         , Ord date
         ) =>
         Sumable (GL txn date post name amt) (txn, posts) where
	GL !gl += (txn, posts) = GL $
		MT.ofoldl'
		 (flip $ \post ->
			let first_line =
				LineGL
				 { lineGL_transaction = txn
				 , lineGL_posting     = post
				 , lineGL_sum         = get @amt post
				 } in
			let single =
				Map.singleton (get @date txn) $
				Seq.singleton first_line in
			TM.insert
			 (\_new old ->
				let (nlt, leq, neq, ngt) =
					case Map.splitLookup (get @date txn) 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
							 (_:>LineGL{lineGL_sum = s}) ->
								first_line{lineGL_sum = s + get @amt post}
							 _ -> first_line
						in (olt, line, Seq.singleton line, ogt)
					 (olt, Just oeq, ogt) ->
						case Seq.viewr oeq of
						 (_:>LineGL{lineGL_sum = s}) ->
							let line = first_line{lineGL_sum = s + get @amt post} in
							(olt, line, oeq |> line, ogt)
						 _ -> (olt, first_line, Seq.singleton first_line, ogt)
				in
				Map.union nlt $
				Map.insert (get @date txn) neq $
				Map.map
				 (fmap (\l -> l{lineGL_sum =
					lineGL_sum leq + lineGL_sum l}))
				 ngt
			 )
			 (get post)
			 single
		 )
		 gl
		 posts

-- ** Type 'LineGL'
data LineGL txn post amt
 =   LineGL
 {   lineGL_transaction :: txn
 ,   lineGL_posting     :: post
 ,   lineGL_sum         :: amt
 } deriving (Data, Eq, Show, Typeable)
instance (NFData txn, NFData post, NFData amt) => NFData (LineGL txn post amt) where
	rnf LineGL{..} =
		rnf lineGL_transaction `seq`
		rnf lineGL_posting `seq`
		rnf lineGL_sum

-- * Type 'ExpandedGL'
-- | Descending propagation of amounts accross accounts.
newtype ExpandedGL txn date post name amt
 =      ExpandedGL (TreeMap name (LineExpandedGL txn date post amt))
 deriving (Data, Eq, NFData, Show, Typeable)

-- ** Type 'LineExpandedGL'
-- |
-- * 'Strict.exclusive': contains the original 'LineGL's.
-- * 'Strict.inclusive': contains ('+') folded
--   over 'Strict.exclusive' and 'Strict.inclusive'
--   of 'TM.node_descendants'.
type LineExpandedGL txn date post amt
 = Strict.Clusive (Map date (Seq (LineGL txn post amt)))

-- | Return the given 'GL' with:
--
-- * all missing parent accounts inserted;
-- * and every mapped 'LineGL' added with any 'LineGL'
--   of the accounts for which it is parent.
expandedGL ::
 forall txn date post name amt.
 ( Get amt post
 , Addable amt
 , Ord name
 , Ord date
 ) =>
 GL txn date post name amt ->
 ExpandedGL txn date post name amt
expandedGL (GL gl) =
	let from_value =
		Strict.fromMaybe (assert False undefined) .
		TM.node_value in
	ExpandedGL $
	TM.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 'lineGL_sum's
			 (\may_sum line ->
				let amt = get @amt $ lineGL_posting line in
				case may_sum of
				 Nothing -> (Just amt, line)
				 Just last_sum ->
					let new_sum = last_sum + amt in
					( Just new_sum
					, line{lineGL_sum=new_sum} )
			 ) Nothing $
			Compose $
			Map.foldr
			 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
			 exclusive nodes
		 })
	 gl