lib/Hcompta/Chart.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
   7 module Hcompta.Chart where
   8
   9 import           Control.DeepSeq (NFData(..))
  10 import           Data.Data (Data)
  11 import           Data.Eq (Eq(..))
  12 import           Data.Function (on)
  13 import           Data.Functor (Functor(..))
  14 -- import           Data.List (concat)
  15 -- import           Data.List.NonEmpty (NonEmpty(..))
  16 import qualified Data.Map.Strict as Map
  17 import           Data.Map.Strict (Map)
  18 import           Data.Monoid (Monoid(..))
  19 import           Data.Ord (Ord(..))
  20 import           Data.Typeable
  21 import           Text.Show (Show(..))
  22 import           Prelude (($), (.), seq)
  23
  24 import qualified Hcompta.Account as Account
  25 import           Hcompta.Account (Account(..), Account_Anchor, Account_Tags(..))
  26 import           Hcompta.Lib.TreeMap (TreeMap)
  27 import qualified Hcompta.Lib.TreeMap as TreeMap
  28 -- import qualified Hcompta.Anchor as Anchor
  29 import           Hcompta.Tag (Tags(..))
  30
  31 data Account account
  32  => Chart    account
  33  =  Chart
  34  { chart_accounts :: TreeMap (Account_Section account) Account_Tags
  35  -- , chart_tags     :: Account_Tags
  36  , chart_anchors  :: Map Account_Anchor account
  37  }
  38 deriving instance ( Account        account
  39                   , Data           account
  40                   ) => Data (Chart account)
  41 deriving instance ( Account      account
  42                   , Eq           account
  43                   ) => Eq (Chart account)
  44 deriving instance ( Account        account
  45                   , Show           account
  46                   ) => Show (Chart account)
  47 deriving instance Typeable1 Chart
  48  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
  49
  50 instance Account account
  51  => Monoid (Chart account) where
  52         mempty =
  53                 Chart
  54                  { chart_accounts   = mempty
  55                  -- , chart_tags = mempty
  56                  , chart_anchors    = mempty
  57                  }
  58         mappend x y =
  59                 Chart
  60                  { chart_accounts = chart_accounts    x `mappend` chart_accounts   y
  61                  -- , chart_tags = chart_tags  x `mappend` chart_tags y
  62                  , chart_anchors  = chart_anchors     x `mappend` chart_anchors    y
  63                  }
  64
  65 instance
  66  ( NFData  account
  67  , Account account
  68  ) => NFData (Chart account) where
  69         rnf Chart{chart_accounts, chart_anchors} =
  70                 rnf chart_accounts `seq`
  71                 rnf chart_anchors
  72
  73 -- | Return the 'Account_Tags'
  74 --   associated with the given 'Account_Path'
  75 --   in the given 'Chart'.
  76 account_tags :: Account account => account -> Chart account -> Account_Tags
  77 account_tags acct chart =
  78         Account_Tags $ Tags $
  79         Map.unionsWith mappend $
  80         fmap (\(Account_Tags (Tags tags)) -> tags) $
  81         TreeMap.find_along (account_path acct) $
  82         chart_accounts chart
  83
  84 data Charted account x
  85  =   Charted
  86  { charted_chart :: Chart account
  87  , charted       :: x
  88  }
  89  deriving (Data, Show, Typeable)
  90
  91 instance
  92  ( Account.Account account
  93  , Account.Account x
  94  ) =>  Account.Account (Charted account x) where
  95         type Account_Section (Charted account x) = Account.Account_Section x
  96         account_path = Account.account_path . charted
  97 instance
  98  ( Account account
  99  , Eq x
 100  ) => Eq (Charted account x) where
 101         (==) = (==) `on` charted
 102 instance
 103  ( Account account
 104  , Ord x
 105  ) => Ord (Charted account x) where
 106         compare = compare `on` charted
 107 instance Functor (Charted account) where
 108         fmap f (Charted a x) = Charted a $ f x
 109 instance
 110  ( Account account
 111  , Monoid x
 112  ) => Monoid (Charted account x) where
 113         mempty = Charted mempty mempty
 114         mappend (Charted xc xt) (Charted yc yt) =
 115                 Charted (mappend xc yc) (mappend xt yt)
 116 instance
 117  ( Account account
 118  , NFData account, NFData x
 119  ) => NFData (Charted account x) where
 120         rnf (Charted c x) = rnf c `seq` rnf x
 121
 122
 123 {-
 124 -- | Return the 'Account's associated with
 125 --   the given 'Tag'
 126 --   in the given 'Chart'.
 127 tag_accounts :: Tag -> Chart -> [Account]
 128 tag_accounts (p:|ps, value) chart =
 129         concat $
 130         TreeMap.find_along (p:|ps `mappend` [value]) $
 131         chart_tags chart
 132 -}