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