{-# 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 Data.Word (Word)
import Prelude (seq)
import System.IO (FilePath)
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 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 'SourcePos'
data SourcePos
 =   SourcePos FilePath {-# UNPACK #-} !PosFile {-# UNPACK #-} !PosFile
 deriving (Data, Eq, Ord, Show, Typeable)

initialPos :: FilePath -> SourcePos
initialPos p = SourcePos p (PosFile 0) (PosFile 0)

-- ** Type 'PosFile'
newtype PosFile = PosFile (Word)
 deriving (Data, Eq, Ord, Show, Typeable)

-- ** Type 'SourceRange'
data SourceRange
 =   SourceRange SourcePos SourcePos
 deriving (Data, Eq, Ord, Show, Typeable)

-- * Type 'Posting'
data Posting
 =   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   :: !SourcePos -- TODO: introduce src
 ,   posting_tags        :: !Posting_Tags
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Posting 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
instance H.Get (TreeMap.Path Account_Section) Posting where
	get = H.get . posting_account
instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
	get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
instance H.Set (Map Unit (H.Polarized Quantity)) Posting 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

posting :: Account -> Posting
posting acct =
	Posting
	 { posting_account     = acct
	 , posting_account_ref = S.Nothing
	 , posting_amounts     = H.quantity_zero
	 , posting_comments    = mempty
	 , posting_dates       = mempty
	 , 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]))

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 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 = Postings (Map Account [Posting])
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
unPostings :: Postings -> Map Account [Posting]
unPostings (Postings ps) = ps
type instance H.Postings H.:@ Postings = Postings
instance H.Get Postings Postings where
	get = id
instance H.Postings Postings
instance Semigroup Postings where
	Postings x <> Postings y =
		Postings $ Map.unionWith (flip (<>)) x y
instance Monoid Postings where
	mempty  = Postings mempty
	mappend = (<>)
type instance MT.Element Postings = Posting
instance MT.MonoFunctor Postings where
	omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
instance MT.MonoFoldable Postings 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
-}