{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Hcompta.LCC.Transaction where import Control.DeepSeq (NFData(..)) import Data.Data (Data(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor.Compose (Compose(..)) import Data.Map.Strict (Map) import Data.Monoid (Monoid(..)) import Data.NonNull (NonNull) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString) import Data.Text (Text) import Data.Typeable (Typeable) import Prelude (flip, 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.NonNull as NonNull import Language.Symantic.Grammar (Source(..)) import qualified Hcompta as H import Hcompta.LCC.Tag import Hcompta.LCC.Posting -- * Type 'Transaction' data Transaction src = Transaction { transaction_comments :: [Comment] , transaction_dates :: NonNull [Date] , transaction_postings :: Postings src , transaction_sourcepos :: src , transaction_tags :: Transaction_Tags , transaction_wording :: Wording } deriving (Data, Eq, Ord, Show, Typeable) transaction_date :: Transaction src -> Date transaction_date = NonNull.head . transaction_dates -- instance H.Transaction Transaction instance NFData src => NFData (Transaction src) where rnf Transaction{..} = rnf transaction_comments `seq` rnf transaction_dates `seq` rnf transaction_postings `seq` rnf transaction_sourcepos `seq` rnf transaction_tags `seq` rnf transaction_wording type instance MT.Element (Transaction src) = Posting src instance MT.MonoFunctor (Transaction src) where omap f t = t{transaction_postings = f `MT.omap` transaction_postings t} instance MT.MonoFoldable (Transaction src) where ofoldMap f = MT.ofoldMap f . transaction_postings ofoldr f a = MT.ofoldr f a . transaction_postings ofoldl' f a = MT.ofoldl' f a . transaction_postings ofoldr1Ex f = MT.ofoldr1Ex f . transaction_postings ofoldl1Ex' f = MT.ofoldl1Ex' f . transaction_postings -- type instance H.Postings H.:@ Transaction = Postings instance H.Get (Postings src) (Transaction src) where get = transaction_postings {- type instance H.Date H.:@ Transaction = Date instance H.GetI H.Date Transaction where getI = NonNull.head . transaction_dates instance H.SetI H.Date Transaction where setI d t = t{transaction_dates = NonNull.ncons d $ NonNull.tail $ transaction_dates t} type instance H.Postings H.:@ Transaction = Postings instance H.GetI H.Postings Transaction where getI = transaction_postings instance H.SetI H.Postings Transaction where setI transaction_postings t = t{transaction_postings} -} transaction :: Source src => Transaction src transaction = Transaction { transaction_comments = [] , transaction_dates = NonNull.ncons H.epoch [] , transaction_postings = mempty , transaction_sourcepos = noSource , transaction_tags = mempty , transaction_wording = "" } {- -- ** Type 'Transaction_Anchor' newtype Transaction_Anchor = Transaction_Anchor Anchor deriving (Data, Eq, NFData, Ord, Show, Typeable) -- ** Type 'Transaction_Anchors' newtype Transaction_Anchors = Transaction_Anchors Anchors deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable) type instance MT.Element Transaction_Anchors = Transaction_Anchor -} -- ** Type 'Transaction_Tag' newtype Transaction_Tag = Transaction_Tag Tag deriving (Data, Eq, NFData, Ord, Show, Typeable) -- ** Type 'Transaction_Tags' newtype Transaction_Tags = Transaction_Tags Tags deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable) type instance MT.Element Transaction_Tags = Transaction_Tag -- ** Type 'Transactions' newtype Transactions src = Transactions (Map Date [Transaction src]) deriving (Data, Eq, NFData, Ord, Show, Typeable) instance Semigroup (Transactions src) where Transactions x <> Transactions y = Transactions $ Map.unionWith (flip (<>)) x y instance Monoid (Transactions src) where mempty = Transactions mempty mappend = (<>) instance H.Zeroable (Transactions src) where zero = Transactions mempty type instance MT.Element (Transactions src) = Transaction src -- instance H.Transactions Transactions -- ** Type 'Wording' newtype Wording = Wording Text deriving (Data, Eq, IsString, NFData, Ord, Show, Typeable) {- -- Transaction instance H.Transaction Transaction where type Transaction_Posting Transaction = Posting type Transaction_Postings Transaction = Compose (Map Account) [] Posting transaction_date = fst . transaction_dates transaction_description = transaction_wording transaction_postings = Compose . transaction_postings transaction_tags = transaction_tags instance H.Transaction (Charted Transaction) where type Transaction_Posting (Charted Transaction) = H.Transaction_Posting Transaction type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction transaction_date = H.transaction_date . charted transaction_description = H.transaction_description . charted transaction_postings = H.transaction_postings . charted transaction_tags = H.transaction_tags . charted -- Journal instance H.Journal_Transaction Transaction instance H.Journal_Transaction (Charted Transaction) -- Stats instance H.Stats_Transaction Transaction where stats_transaction_postings_count = Map.size . transaction_postings instance H.Stats_Transaction (Charted Transaction) where stats_transaction_postings_count = H.stats_transaction_postings_count . charted -- GL instance H.GL_Transaction Transaction where type GL_Transaction_Line Transaction = Transaction gl_transaction_line = id {- gl_transaction_postings_filter f t = t{ transaction_postings = Map.mapMaybe (\post -> case List.filter f post of [] -> Nothing posts -> Just posts) (transaction_postings t) } -} instance H.GL_Transaction (Charted Transaction) where type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction gl_transaction_line = H.gl_transaction_line . charted {- gl_transaction_postings_filter f (Charted c t) = Charted c t{ transaction_postings = Map.mapMaybe (\post -> case List.filter f $ ({-Charted c <$>-} post) of [] -> Nothing posts -> Just $ {-charted <$>-} posts) (transaction_postings t) } -} {- instance Filter.Transaction (Charted Transaction) where type Transaction_Posting (Charted Transaction) = Charted Posting type Transaction_Postings (Charted Transaction) = Compose (Map Account) [] transaction_date = fst . transaction_dates . Chart.charted transaction_wording = transaction_wording . Chart.charted transaction_postings (Chart.Charted c t) = fmap (Chart.Charted c) $ Compose $ transaction_postings t {- transaction_postings_virtual (Chart.Charted c t) = fmap (Chart.Charted c) $ Compose [ Compose $ transaction_virtual_postings t , Compose $ transaction_balanced_virtual_postings t ] -} transaction_tags = transaction_tags . Chart.charted -} -} -- | Return a 'Map' associating -- the given 'Transaction's with their respective 'Date'. transaction_by_date :: [Transaction src] -> (Compose (Map Date) []) (Transaction src) transaction_by_date = Compose . Map.fromListWith (flip mappend) . List.map (\t -> (NonNull.head $ transaction_dates t, [t]))