lcc/Hcompta/LCC/Transaction.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE RecordWildCards #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 module Hcompta.LCC.Transaction where
  10
  11 import Control.DeepSeq (NFData(..))
  12 import Data.Data (Data(..))
  13 import Data.Eq (Eq(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor.Compose (Compose(..))
  16 import Data.Map.Strict (Map)
  17 import Data.Monoid (Monoid(..))
  18 import Data.NonNull (NonNull)
  19 import Data.Ord (Ord(..))
  20 import Data.String (IsString)
  21 import Data.Text (Text)
  22 import Data.Typeable (Typeable)
  23 import Prelude (flip, seq)
  24 import Text.Show (Show)
  25 import qualified Data.List as List
  26 import qualified Data.Map.Strict as Map
  27 import qualified Data.MonoTraversable as MT
  28 import qualified Data.NonNull as NonNull
  29
  30 import qualified Hcompta as H
  31
  32 import Hcompta.LCC.Account
  33 import Hcompta.LCC.Tag
  34 import Hcompta.LCC.Posting
  35 -- import Hcompta.LCC.Chart
  36
  37 -- * Type 'Transaction'
  38 data Transaction
  39  =   Transaction
  40  {   transaction_comments  :: [Comment]
  41  ,   transaction_dates     :: NonNull [Date]
  42  ,   transaction_postings  :: Postings
  43  ,   transaction_sourcepos :: SourcePos
  44  ,   transaction_tags      :: Transaction_Tags
  45  ,   transaction_wording   :: Wording
  46  } deriving (Data, Eq, Ord, Show, Typeable)
  47 transaction_date :: Transaction -> Date
  48 transaction_date = NonNull.head . transaction_dates
  49 instance H.Transaction Transaction
  50 instance NFData Transaction where
  51         rnf Transaction{..} =
  52                 rnf transaction_comments `seq`
  53                 rnf transaction_dates `seq`
  54                 rnf transaction_postings `seq`
  55                 -- rnf transaction_sourcepos `seq`
  56                 rnf transaction_tags `seq`
  57                 rnf transaction_wording
  58 type instance MT.Element Transaction = Posting
  59 instance MT.MonoFunctor Transaction where
  60         omap f t = t{transaction_postings = f `MT.omap` transaction_postings t}
  61 instance MT.MonoFoldable Transaction where
  62         ofoldMap f   = MT.ofoldMap f   . transaction_postings
  63         ofoldr f a   = MT.ofoldr f a   . transaction_postings
  64         ofoldl' f a  = MT.ofoldl' f a  . transaction_postings
  65         ofoldr1Ex f  = MT.ofoldr1Ex f  . transaction_postings
  66         ofoldl1Ex' f = MT.ofoldl1Ex' f . transaction_postings
  67
  68 type instance H.Date H.:@ Transaction = Date
  69 instance H.GetI H.Date Transaction where
  70         getI_ _ = NonNull.head . transaction_dates
  71 instance H.SetI H.Date Transaction where
  72         setI_ _ d t = t{transaction_dates =
  73                 NonNull.ncons d $ NonNull.tail $ transaction_dates t}
  74
  75 type instance H.Postings H.:@ Transaction = Postings
  76 instance H.GetI H.Postings Transaction where
  77         getI_ _ = transaction_postings
  78 instance H.SetI H.Postings Transaction where
  79         setI_ _ transaction_postings t = t{transaction_postings}
  80
  81 transaction :: Transaction
  82 transaction =
  83         Transaction
  84          { transaction_comments  = []
  85          , transaction_dates     = NonNull.ncons H.date_epoch []
  86          , transaction_postings  = mempty
  87          , transaction_sourcepos = initialPos ""
  88          , transaction_tags      = mempty
  89          , transaction_wording   = ""
  90          }
  91
  92 {-
  93 -- ** Type 'Transaction_Anchor'
  94 newtype Transaction_Anchor = Transaction_Anchor Anchor
  95  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  96 -- ** Type 'Transaction_Anchors'
  97 newtype Transaction_Anchors = Transaction_Anchors Anchors
  98  deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
  99 type instance MT.Element Transaction_Anchors = Transaction_Anchor
 100 -}
 101
 102 -- ** Type 'Transaction_Tag'
 103 newtype Transaction_Tag = Transaction_Tag Tag
 104  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 105 -- ** Type 'Transaction_Tags'
 106 newtype Transaction_Tags = Transaction_Tags Tags
 107  deriving (Data, Eq, Monoid, NFData, Ord, Show, Typeable)
 108 type instance MT.Element Transaction_Tags = Transaction_Tag
 109
 110 -- ** Type 'Transactions'
 111 newtype Transactions = Transactions (Map Account [Transaction])
 112  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 113
 114 type instance MT.Element Transactions = Transaction
 115 instance H.Transactions Transactions
 116
 117 -- ** Type 'Wording'
 118 newtype Wording = Wording Text
 119  deriving (Data, Eq, IsString, NFData, Ord, Show, Typeable)
 120
 121
 122
 123
 124
 125
 126
 127 {-
 128
 129 -- Transaction
 130 instance H.Transaction      Transaction where
 131         type Transaction_Posting  Transaction = Posting
 132         type Transaction_Postings Transaction = Compose (Map Account) [] Posting
 133         transaction_date        = fst . transaction_dates
 134         transaction_description = transaction_wording
 135         transaction_postings    = Compose . transaction_postings
 136         transaction_tags        = transaction_tags
 137 instance H.Transaction      (Charted Transaction) where
 138         type Transaction_Posting  (Charted Transaction) = H.Transaction_Posting  Transaction
 139         type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction
 140         transaction_date        = H.transaction_date . charted
 141         transaction_description = H.transaction_description . charted
 142         transaction_postings    = H.transaction_postings . charted
 143         transaction_tags        = H.transaction_tags . charted
 144
 145 -- Journal
 146 instance H.Journal_Transaction Transaction
 147 instance H.Journal_Transaction (Charted Transaction)
 148
 149 -- Stats
 150 instance H.Stats_Transaction Transaction where
 151         stats_transaction_postings_count = Map.size . transaction_postings
 152 instance H.Stats_Transaction (Charted Transaction) where
 153         stats_transaction_postings_count = H.stats_transaction_postings_count . charted
 154
 155 -- GL
 156 instance H.GL_Transaction  Transaction where
 157         type GL_Transaction_Line Transaction = Transaction
 158         gl_transaction_line = id
 159         {-
 160         gl_transaction_postings_filter f t =
 161                 t{ transaction_postings =
 162                         Map.mapMaybe
 163                          (\post -> case List.filter f post of
 164                                  [] -> Nothing
 165                                  posts -> Just posts)
 166                          (transaction_postings t)
 167                  }
 168         -}
 169 instance H.GL_Transaction  (Charted Transaction) where
 170         type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction
 171         gl_transaction_line = H.gl_transaction_line . charted
 172         {-
 173         gl_transaction_postings_filter f (Charted c t) =
 174                 Charted c
 175                  t{ transaction_postings =
 176                         Map.mapMaybe
 177                          (\post -> case List.filter f $ ({-Charted c <$>-} post) of
 178                                  [] -> Nothing
 179                                  posts -> Just $ {-charted <$>-} posts)
 180                          (transaction_postings t)
 181                  }
 182         -}
 183
 184 {-
 185 instance Filter.Transaction (Charted Transaction) where
 186         type Transaction_Posting  (Charted Transaction) = Charted Posting
 187         type Transaction_Postings (Charted Transaction) = Compose (Map Account) []
 188         transaction_date = fst . transaction_dates . Chart.charted
 189         transaction_wording = transaction_wording . Chart.charted
 190         transaction_postings (Chart.Charted c t)  =
 191                 fmap (Chart.Charted c) $
 192                 Compose $ transaction_postings t
 193         {-
 194         transaction_postings_virtual (Chart.Charted c t) =
 195                 fmap (Chart.Charted c) $
 196                 Compose
 197                  [ Compose $ transaction_virtual_postings t
 198                  , Compose $ transaction_balanced_virtual_postings t
 199                  ]
 200         -}
 201         transaction_tags = transaction_tags . Chart.charted
 202 -}
 203 -}
 204 -- | Return a 'Map' associating
 205 --   the given 'Transaction's with their respective 'Date'.
 206 transaction_by_date :: [Transaction] -> (Compose (Map Date) []) Transaction
 207 transaction_by_date =
 208         Compose .
 209         Map.fromListWith (flip mappend) .
 210         List.map (\t -> (NonNull.head $ transaction_dates t, [t]))