lib/Hcompta/Transaction.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TupleSections #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 module Hcompta.Transaction where
  12
  13 import           Control.DeepSeq (NFData)
  14 import           Data.Data
  15 import           Data.Eq (Eq)
  16 import           Data.Function (($), (.), const)
  17 import           Data.Monoid (Monoid(..))
  18 import           Data.Ord (Ord)
  19 import           Data.Text (Text)
  20 import           Data.Typeable ()
  21 import           Text.Show (Show)
  22 import           Data.Tuple (fst, snd)
  23
  24 import           Hcompta.Anchor
  25 import           Hcompta.Date (Date)
  26 import           Hcompta.Lib.Consable (Consable(..))
  27 import           Hcompta.Posting (Posting)
  28 import           Hcompta.Tag
  29
  30 -- * Class 'Transaction'
  31
  32 class
  33     Posting (Transaction_Posting t)
  34  => Transaction t where
  35         type Transaction_Posting  t
  36         type Transaction_Postings t
  37         transaction_date        :: t -> Date
  38         transaction_description :: t -> Description
  39         transaction_postings    :: t -> Transaction_Postings t
  40         transaction_tags        :: t -> Transaction_Tags
  41
  42 instance Posting posting => Transaction (Date, [posting]) where
  43         type Transaction_Posting  (Date, [posting]) = posting
  44         type Transaction_Postings (Date, [posting]) = [posting]
  45         transaction_date        = fst
  46         transaction_description = const mempty
  47         transaction_postings    = snd
  48         transaction_tags        = const mempty
  49
  50 -- ** Type 'Description'
  51
  52 type Description = Text
  53
  54 -- * Type 'Transaction_Anchor'
  55 newtype Transaction_Anchor
  56  =      Transaction_Anchor Anchor
  57  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  58 newtype Transaction_Anchors
  59  =      Transaction_Anchors Anchors
  60  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
  61
  62 instance Consable Anchor Transaction_Anchors where
  63         mcons a (Transaction_Anchors anchors) =
  64                 Transaction_Anchors $ mcons a anchors
  65
  66 transaction_anchor :: Anchor_Path -> Transaction_Anchor
  67 transaction_anchor = Transaction_Anchor . anchor
  68
  69 -- | Return the given 'Transaction_Anchors'
  70 -- with the given 'Transaction_Anchor' incorporated.
  71 transaction_anchor_cons :: Transaction_Anchor -> Transaction_Anchors -> Transaction_Anchors
  72 transaction_anchor_cons (Transaction_Anchor t) (Transaction_Anchors ts) =
  73         Transaction_Anchors $ anchor_cons t ts
  74
  75 -- * Type 'Transaction_Tag'
  76
  77 newtype Transaction_Tag
  78  =      Transaction_Tag Tag
  79  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  80 newtype Transaction_Tags
  81  =      Transaction_Tags Tags
  82  deriving (Data, Eq, Monoid, NFData, Show, Typeable)
  83
  84 instance Consable Tag Transaction_Tags where
  85         mcons t (Transaction_Tags tags) =
  86                 Transaction_Tags $ mcons t tags
  87
  88 transaction_tag :: Tag_Path -> Tag_Value -> Transaction_Tag
  89 transaction_tag p v = Transaction_Tag $ tag p v
  90
  91 -- | Return the given 'Transaction_Tags' with the given 'Transaction_Tag' incorporated.
  92 transaction_tag_cons :: Transaction_Tag -> Transaction_Tags -> Transaction_Tags
  93 transaction_tag_cons (Transaction_Tag t) (Transaction_Tags ts) =
  94         Transaction_Tags $ tag_cons t ts