{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.LCC.Posting where

import Control.DeepSeq (NFData(..))
import Data.Data (Data(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Typeable (Typeable)
import Prelude (seq)
import Text.Show (Show)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
import qualified Data.Strict as S
import qualified Data.Time.Clock as Time
import qualified Data.TreeMap.Strict as TreeMap

import Language.Symantic.Grammar (Source(..))
import qualified Hcompta as H

import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Tag

deriving instance (Data a, Data b) => Data (S.Pair a b)
instance (NFData a, NFData b) => NFData (S.Pair a b) where
	rnf (a S.:!: b)  = rnf a `seq` rnf b

-- * Type 'Date'
type Date = Time.UTCTime

-- * Type 'Posting'
data Posting src
 =   Posting
 {   posting_account     :: !Account
 ,   posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
 ,   posting_amounts     :: !Amounts
 ,   posting_comments    :: ![Comment]
 ,   posting_dates       :: ![Date]
 ,   posting_sourcepos   :: !src
 ,   posting_tags        :: !Posting_Tags
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData src => NFData (Posting src) where
	rnf Posting{..} =
		rnf posting_account `seq`
		rnf posting_account_ref `seq`
		rnf posting_amounts `seq`
		rnf posting_comments `seq`
		rnf posting_dates `seq`
		rnf posting_sourcepos `seq`
		rnf posting_tags
{-
type instance H.UnitFor     Posting = Unit
type instance H.QuantityFor Posting = H.Polarized Quantity
type instance H.AccountFor  Posting = Account
-}

instance H.Get (TreeMap.Path NameAccount) (Posting src) where
	get = H.to . posting_account
instance H.Get Account (Posting src) where
	get Posting{posting_account = acct} = acct
instance H.Get (Map Unit Quantity) (Posting src) where
	get Posting{posting_amounts = Amounts amts} = amts
instance H.Set (Map Unit Quantity) (Posting src) where
	set amts p = p{posting_amounts = Amounts amts}
instance H.Get (Map Unit (H.Polarized Quantity)) (Posting src) where
	get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
instance H.Set (Map Unit (H.Polarized Quantity)) (Posting src) where
	set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
-- instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
-- 	get = H.get . posting_amounts

{-
instance H.ConsBalByAccount Posting where
	consBalByAccount Posting
	 { posting_account = Account acct
	 , posting_amounts = Amounts amts
	 } = H.consBalByAccount (acct, H.polarize <$> amts)
instance H.ConsBalByUnit Posting where
	consBalByUnit Posting
	 { posting_account = Account acct
	 , posting_amounts = Amounts amts
	 } = H.consBalByUnit (acct, H.polarize <$> amts)
type instance H.AccountFor (Account, Amounts) = Account
-}

posting :: Source src => Account -> Posting src
posting acct =
	Posting
	 { posting_account     = acct
	 , posting_account_ref = S.Nothing
	 , posting_amounts     = H.zero
	 , posting_comments    = mempty
	 , posting_dates       = mempty
	 , posting_sourcepos   = noSource
	 , posting_tags        = mempty
	 }

postings_by_account :: [Posting src] -> Map Account [Posting src]
postings_by_account =
	Map.fromListWith (flip (<>)) .
	List.map (\p -> (posting_account p, [p]))

{-
instance H.Posting Posting

type instance H.Account H.:@ Posting = Account
instance H.GetI H.Account Posting where
	getI = posting_account
instance H.SetI H.Account Posting where
	setI posting_account p = p{posting_account}

type instance H.Amounts H.:@ Posting = Amounts
instance H.GetI H.Amounts Posting where
	getI = posting_amounts
instance H.SetI H.Amounts (Posting src) where
	setI posting_amounts p = p{posting_amounts}
-}

{-
-- * Type 'Posting_Anchor'
newtype Posting_Anchor = Posting_Anchor Anchor
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
-- * Type 'Posting_Anchors'
newtype Posting_Anchors = Posting_Anchors Anchors
 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
type instance MT.Element Posting_Anchors = Posting_Anchor
-}

-- * Type 'Posting_Tag'
newtype Posting_Tag = Posting_Tag Tag
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
-- * Type 'Posting_Tags'
newtype Posting_Tags = Posting_Tags Tags
 deriving (Data, Eq, Monoid, NFData, Ord, Semigroup, Show, Typeable)
type instance MT.Element Posting_Tags = Posting_Tag

-- ** Type 'Comment'
newtype Comment = Comment Text
 deriving (Data, Eq, NFData, Ord, Show, Typeable)

-- * Type 'Postings'
newtype Postings src = Postings (Map Account [Posting src])
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
unPostings :: Postings src -> Map Account [Posting src]
unPostings (Postings ps) = ps
-- type instance H.Postings H.:@ Postings = Postings
instance H.Get (Postings src) (Postings src) where
	get = id
-- instance H.Postings Postings
instance Semigroup (Postings src) where
	Postings x <> Postings y = Postings $ Map.unionWith (flip (<>)) x y
instance Monoid (Postings src) where
	mempty  = Postings mempty
	mappend = (<>)
type instance MT.Element (Postings src) = Posting src
instance MT.MonoFunctor (Postings src) where
	omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
instance MT.MonoFoldable (Postings src) where
	ofoldMap f   (Postings m) = MT.ofoldMap f   (Compose m)
	ofoldr f a   (Postings m) = MT.ofoldr f a   (Compose m)
	ofoldr1Ex f  (Postings m) = MT.ofoldr1Ex f  (Compose m)
	ofoldl1Ex' f (Postings m) = MT.ofoldl1Ex' f (Compose m)
	ofoldl' f a  (Postings m) = MT.ofoldl' f a  (Compose m)


{-
-- Posting
instance H.Posting Posting where
	type Posting_Account Posting = Account
	type Posting_Amount  Posting = Amount
	type Amounts Posting = [Amount]
	posting_account = posting_account
	posting_amounts = (uncurry Amount <$>) . Map.toList . posting_amounts
instance H.Posting (Charted Posting) where
	type Posting_Account (Charted Posting) = Charted Account
	type Posting_Amount  (Charted Posting) = H.Posting_Amount  Posting
	type Amounts (Charted Posting) = H.Amounts Posting
	posting_account = (H.posting_account <$>)
	posting_amounts = H.posting_amounts . charted

-- Balance
instance H.Balance_Posting Posting where
	type Balance_Posting_Quantity Posting = H.Polarized Quantity
	balance_posting_amounts = (H.polarize <$>) . posting_amounts
	balance_posting_amounts_set amounts p =
		p { posting_amounts = H.depolarize <$> amounts }
instance H.Balance_Posting (Charted Posting) where
	type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
	balance_posting_amounts = H.balance_posting_amounts . charted
	balance_posting_amounts_set amounts (Charted c p) =
		Charted c p{ posting_amounts = H.depolarize <$> amounts }

-- GL
instance H.GL_Posting Posting where
	type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
	gl_posting_quantity = (H.polarize <$>) . posting_amounts
instance H.GL_Posting (Charted Posting) where
	type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
	gl_posting_quantity = H.gl_posting_quantity . charted
-}