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