{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Ledger.Posting where

import           Control.DeepSeq (NFData(..))
import           Data.Bool
import           Data.Data (Data(..))
import           Data.Eq (Eq(..))
import           Data.Function ((.), flip)
import           Data.Functor (Functor(..), (<$>))
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..))
import           Data.Text (Text)
import           Data.Tuple (uncurry)
import           Data.Typeable (Typeable)
import           Prelude (seq)
import           Text.Parsec.Pos (SourcePos, initialPos)
import           Text.Show (Show)

import qualified Hcompta as H
import           Hcompta.Ledger.Account
import           Hcompta.Ledger.Amount
import           Hcompta.Ledger.Chart

-- * Type 'Posting'

data Posting
 =   Posting
 { posting_account   :: Account
 , posting_amounts   :: Map Unit Quantity
 , posting_comments  :: [Comment]
 , posting_dates     :: [H.Date]
 , posting_sourcepos :: SourcePos
 , posting_status    :: Bool
 , posting_tags      :: H.Posting_Tags
 } deriving (Data, Eq, Show, Typeable)
instance NFData Posting where
	rnf Posting{..} =
		rnf posting_account `seq`
		rnf posting_amounts `seq`
		rnf posting_comments `seq`
		rnf posting_dates `seq`
		-- rnf posting_sourcepos `seq`
		rnf posting_status `seq`
		rnf posting_tags

posting :: Account -> Posting
posting acct =
	Posting
	 { posting_account   = acct
	 , posting_amounts   = mempty
	 , posting_comments  = mempty
	 , posting_dates     = mempty
	 , posting_status    = False
	 , posting_sourcepos = initialPos ""
	 , posting_tags      = mempty
	 }

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

-- Posting
instance H.Posting Posting where
	type Posting_Account   Posting = Account
	type Posting_Amount    Posting = Amount
	type Posting_Amounts   Posting = [Amount]
	posting_account = posting_account
	posting_amounts = List.map (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 Posting_Amounts   (Charted Posting) = H.Posting_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

-- ** Type 'Comment'

type Comment = Text

-- ** Type 'Posting_Type'

data Posting_Type
 =   Posting_Type_Regular
 |   Posting_Type_Virtual
 |   Posting_Type_Virtual_Balanced
 deriving (Data, Eq, Show, Typeable)

data Posting_Typed posting
 =   Posting_Typed Posting_Type posting
 deriving (Data, Eq, Functor, Show, Typeable)

posting_type :: Posting -> Posting_Type
posting_type Posting{posting_tags=H.Posting_Tags (H.Tags attrs)} =
	case Map.lookup ("Virtual":|[]) attrs of
	 Nothing -> Posting_Type_Regular
	 Just l | "Balanced" `List.elem` l -> Posting_Type_Virtual_Balanced
	 Just _  -> Posting_Type_Virtual