-- | 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 qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import qualified Data.MonoTraversable as MT
import           Data.Ord (Ord(..))
import           Data.Semigroup (Semigroup(..))
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.Amount
import           Hcompta.Date
import qualified Hcompta.Lib.Strict as Strict
import           Hcompta.Posting
import           Hcompta.Quantity
import           Hcompta.Has

-- * Type 'GL'
newtype GL_ tran date acct_sect post amt
 =      GL (TreeMap acct_sect
                    (Map date (Seq (GL_Line tran post amt))))
 deriving (Data, Eq, NFData, Show, Typeable)
type GL tran
 = GL_ tran
 (Date :@ tran)
 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
 (MT.Element (Postings :@ tran))
 (Amount :@ (MT.Element (Postings :@ tran)))

gl_empty :: GL tran
gl_empty = GL TreeMap.empty

-- * Type 'GL_Account'
-- | 'GL' operations works on this type of 'Account'.
type GL_Account = TreeMap.Path

-- | 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 ::
 ( post ~ MT.Element (Postings :@ tran)
 , acct_sect ~ MT.Element (Account :@ post)
 , GetI Postings tran
 , GetI Date tran
 , GetI Amount post
 , Get (GL_Account acct_sect) post
 , MT.MonoFoldable (Postings :@ tran)
 , Addable (Amount :@ post)
 , Ord acct_sect
 , Ord (Date :@ tran)
 ) => tran -> GL tran -> GL tran
gl_cons tran (GL !gl) =
	GL $
	MT.ofoldl'
	 (flip $ \post ->
		let first_line =
			GL_Line
			 { gl_line_transaction = tran
			 , gl_line_posting     = post
			 , gl_line_sum         = getI @Amount post
			 } in
		let single =
			Map.singleton (getI @Date tran) $
			Seq.singleton first_line in
		TreeMap.insert
		 (\_new old ->
			let (nlt, leq, neq, ngt) =
				case Map.splitLookup (getI @Date tran) 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 $ getI @Amount post}
						 _ -> 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 $ getI @Amount post} in
						(olt, line, oeq |> line, ogt)
					 _ -> (olt, first_line, Seq.singleton first_line, ogt)
			in
			Map.union nlt $
			Map.insert (getI @Date tran) neq $
			Map.map
			 (fmap (\l -> l{gl_line_sum =
				quantity_add (gl_line_sum leq) $ gl_line_sum l}))
			 ngt
		 )
		 (get post)
		 single
	 )
	 gl
	 (getI @Postings tran)

gl_union ::
 ( post ~ MT.Element (Postings :@ tran)
 , Ord (MT.Element (Account :@ post))
 , Ord (Date :@ tran)
 ) => GL tran -> GL tran -> GL tran
gl_union (GL x) (GL y) =
	GL $ TreeMap.union (Map.unionWith (flip (<>))) x y

-- ** Type 'GL_Line'
data GL_Line tran post amt
 =   GL_Line
 {   gl_line_transaction :: tran
 ,   gl_line_posting     :: post
 ,   gl_line_sum         :: amt
 }
 deriving (Data, Eq, Show, Typeable)
instance -- NFData
 ( NFData tran
 , NFData post
 , NFData amt
 ) => NFData (GL_Line tran post amt) where
	rnf GL_Line{..} =
		rnf gl_line_transaction `seq`
		rnf gl_line_posting `seq`
		rnf gl_line_sum


-- * Type 'ExpandedGL'

-- | Descending propagation of 'Amount's accross 'Account's.
newtype ExpandedGL_ tran date acct_sect post amt
 =      ExpandedGL (TreeMap acct_sect (ExpandedGL_Line tran date post amt))
 deriving (Data, Eq, NFData, Show, Typeable)
type ExpandedGL  tran
 =   ExpandedGL_ tran
 (Date :@ tran)
 (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
 (MT.Element (Postings :@ tran))
 (Amount :@ (MT.Element (Postings :@ tran)))

-- ** Type 'ExpandedGL_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 ExpandedGL_Line tran date post amt
 = Strict.Clusive (Map date (Seq (GL_Line tran post amt)))

-- | 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'.
expanded_gl ::
 ( post ~ MT.Element (Postings :@ tran)
 , GetI Amount post
 , Addable (Amount :@ post)
 , MT.MonoFoldable (Postings :@ tran)
 , Ord (MT.Element (Account :@ post))
 , Ord (Date :@ tran)
 ) => GL tran -> ExpandedGL tran
expanded_gl (GL gl) =
	let from_value =
		Strict.fromMaybe (assert False undefined) .
		TreeMap.node_value in
	ExpandedGL $
	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 amt = getI @Amount $ gl_line_posting line in
				case may_sum of
				 Nothing -> (Just amt, line)
				 Just last_sum ->
					let new_sum = quantity_add last_sum amt in
					( Just new_sum
					, line{gl_line_sum=new_sum} )
			 ) Nothing $
			Compose $
			Map.foldr
			 (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
			 exclusive nodes
		 })
	 gl