ledger/Hcompta/Ledger/Posting.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Hcompta.Ledger.Posting where
   9
  10 import           Control.DeepSeq (NFData(..))
  11 import           Data.Bool
  12 import           Data.Data (Data(..))
  13 import           Data.Eq (Eq(..))
  14 import           Data.Function ((.), flip)
  15 import           Data.Functor (Functor(..), (<$>))
  16 import qualified Data.List as List
  17 import           Data.List.NonEmpty (NonEmpty(..))
  18 import           Data.Map.Strict (Map)
  19 import qualified Data.Map.Strict as Map
  20 import           Data.Maybe (Maybe(..))
  21 import           Data.Monoid (Monoid(..))
  22 import           Data.Text (Text)
  23 import           Data.Tuple (uncurry)
  24 import           Data.Typeable (Typeable)
  25 import           Prelude (seq)
  26 import           Text.Parsec.Pos (SourcePos, initialPos)
  27 import           Text.Show (Show)
  28
  29 import qualified Hcompta as H
  30 import           Hcompta.Ledger.Account
  31 import           Hcompta.Ledger.Amount
  32 import           Hcompta.Ledger.Chart
  33
  34 -- * Type 'Posting'
  35
  36 data Posting
  37  =   Posting
  38  { posting_account   :: Account
  39  , posting_amounts   :: Map Unit Quantity
  40  , posting_comments  :: [Comment]
  41  , posting_dates     :: [H.Date]
  42  , posting_sourcepos :: SourcePos
  43  , posting_status    :: Bool
  44  , posting_tags      :: H.Posting_Tags
  45  } deriving (Data, Eq, Show, Typeable)
  46 instance NFData Posting where
  47         rnf Posting{..} =
  48                 rnf posting_account `seq`
  49                 rnf posting_amounts `seq`
  50                 rnf posting_comments `seq`
  51                 rnf posting_dates `seq`
  52                 -- rnf posting_sourcepos `seq`
  53                 rnf posting_status `seq`
  54                 rnf posting_tags
  55
  56 posting :: Account -> Posting
  57 posting acct =
  58         Posting
  59          { posting_account   = acct
  60          , posting_amounts   = mempty
  61          , posting_comments  = mempty
  62          , posting_dates     = mempty
  63          , posting_status    = False
  64          , posting_sourcepos = initialPos ""
  65          , posting_tags      = mempty
  66          }
  67
  68 postings_by_account :: [Posting] -> Map Account [Posting]
  69 postings_by_account =
  70         Map.fromListWith (flip mappend) .
  71         List.map (\p -> (posting_account p, [p]))
  72
  73 -- Posting
  74 instance H.Posting Posting where
  75         type Posting_Account   Posting = Account
  76         type Posting_Amount    Posting = Amount
  77         type Posting_Amounts   Posting = [Amount]
  78         posting_account = posting_account
  79         posting_amounts = List.map (uncurry Amount) . Map.toList . posting_amounts
  80 instance H.Posting (Charted Posting) where
  81         type Posting_Account   (Charted Posting) = Charted Account
  82         type Posting_Amount    (Charted Posting) = H.Posting_Amount  Posting
  83         type Posting_Amounts   (Charted Posting) = H.Posting_Amounts Posting
  84         posting_account = (H.posting_account <$>)
  85         posting_amounts = H.posting_amounts . charted
  86
  87 -- Balance
  88 instance H.Balance_Posting Posting where
  89         type Balance_Posting_Quantity Posting = H.Polarized Quantity
  90         balance_posting_amounts = (H.polarize <$>) . posting_amounts
  91         balance_posting_amounts_set amounts p =
  92                 p { posting_amounts = H.depolarize <$> amounts }
  93 instance H.Balance_Posting (Charted Posting) where
  94         type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
  95         balance_posting_amounts = H.balance_posting_amounts . charted
  96         balance_posting_amounts_set amounts (Charted c p) =
  97                 Charted c p{ posting_amounts = H.depolarize <$> amounts }
  98
  99 -- GL
 100 instance H.GL_Posting Posting where
 101         type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
 102         gl_posting_quantity = (H.polarize <$>) . posting_amounts
 103 instance H.GL_Posting (Charted Posting) where
 104         type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
 105         gl_posting_quantity = H.gl_posting_quantity . charted
 106
 107 -- ** Type 'Comment'
 108
 109 type Comment = Text
 110
 111 -- ** Type 'Posting_Type'
 112
 113 data Posting_Type
 114  =   Posting_Type_Regular
 115  |   Posting_Type_Virtual
 116  |   Posting_Type_Virtual_Balanced
 117  deriving (Data, Eq, Show, Typeable)
 118
 119 data Posting_Typed posting
 120  =   Posting_Typed Posting_Type posting
 121  deriving (Data, Eq, Functor, Show, Typeable)
 122
 123 posting_type :: Posting -> Posting_Type
 124 posting_type Posting{posting_tags=H.Posting_Tags (H.Tags attrs)} =
 125         case Map.lookup ("Virtual":|[]) attrs of
 126          Nothing -> Posting_Type_Regular
 127          Just l | "Balanced" `List.elem` l -> Posting_Type_Virtual_Balanced
 128          Just _  -> Posting_Type_Virtual