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 class Chart c where
  32         chart_account_tags   :: c -> account -> Account_Tags
  33         chart_anchor_account :: c -> Account_Anchor -> account
  34
  35 {-
  36 data Account account
  37  => Chart account account_data
  38  =  Chart
  39  { chart_accounts :: TreeMap (Account_Section account) account_data
  40  , chart_anchors  :: Map Account_Anchor account
  41  }
  42
  43 deriving instance ( Account             account
  44                   , Data                account
  45                   , Data                account_data
  46                   ) => Data (Chart account account_data)
  47 deriving instance ( Account             account
  48                   , Show                account
  49                   , Show                account_data
  50                   ) => Show (Chart account account_data)
  51 deriving instance Typeable2 Chart
  52
  53 instance
  54  ( Account account
  55  , Monoid account_data
  56  ) => Monoid (Chart account account_data) where
  57         mempty =
  58                 Chart
  59                  { chart_accounts = mempty
  60                  , chart_anchors  = mempty
  61                  }
  62         mappend x y =
  63                 Chart
  64                  { chart_accounts = chart_accounts x `mappend` chart_accounts y
  65                  , chart_anchors  = chart_anchors  x `mappend` chart_anchors  y
  66                  }
  67 -}
  68 {-
  69 data Charted account_section account account_data x
  70  =   Charted
  71  { chart   :: Chart account_section account account_data
  72  , charted :: x
  73  }
  74  deriving (Data, Show, Typeable)
  75
  76
  77 class Chart_Account_Data account_data where
  78         chart_account_data_tags :: account_data -> Account_Tags
  79
  80 data
  81  ( Account account
  82  , Chart_Account_Data account_data
  83  ) => Chart account account_data
  84  =  Chart
  85  { chart_accounts :: TreeMap (Account_Section account) account_data
  86  , chart_anchors  :: Map Account_Anchor account
  87  -- , chart_tags     :: Account_Tags
  88  }
  89 deriving instance ( Account             account
  90                   , Chart_Account_Data  account_data
  91                   , Data                account
  92                   , Data                account_data
  93                   ) => Data (Chart account account_data)
  94 deriving instance ( Account      account
  95                   , Eq           account
  96                   , Eq           account_data
  97                   ) => Eq (Chart account account_data)
  98 deriving instance ( Account        account
  99                   , Show           account
 100                   ) => Show (Chart account account_data)
 101 deriving instance Typeable2 Chart
 102  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 103
 104 instance Account account
 105  => Monoid (Chart account_data account) where
 106         mempty =
 107                 Chart
 108                  { chart_accounts   = mempty
 109                  -- , chart_tags = mempty
 110                  , chart_anchors    = mempty
 111                  }
 112         mappend x y =
 113                 Chart
 114                  { chart_accounts = chart_accounts    x `mappend` chart_accounts   y
 115                  -- , chart_tags = chart_tags  x `mappend` chart_tags y
 116                  , chart_anchors  = chart_anchors     x `mappend` chart_anchors    y
 117                  }
 118
 119 instance
 120  ( NFData  account
 121  , Account account
 122  ) => NFData (Chart account_data account) where
 123         rnf Chart{chart_accounts, chart_anchors} =
 124                 rnf chart_accounts `seq`
 125                 rnf chart_anchors
 126
 127 -- | Return the 'Account_Tags'
 128 --   associated with the given 'Account_Path'
 129 --   in the given 'Chart'.
 130 account_tags :: Account account => account -> Chart account account_data -> Account_Tags
 131 account_tags acct chart =
 132         Account_Tags $ Tags $
 133         Map.unionsWith mappend $
 134         fmap ((\(Account_Tags (Tags tags)) -> tags) . chart_account_data_tags) $
 135         TreeMap.find_along (account_path acct) $
 136         chart_accounts chart
 137
 138 data Charted account_data account x
 139  =   Charted
 140  { charted_chart :: Chart account account_data
 141  , charted       :: x
 142  }
 143  deriving (Data, Show, Typeable)
 144
 145 instance
 146  ( Account.Account account
 147  , Account.Account x
 148  ) =>  Account.Account (Charted account account_data x) where
 149         type Account_Section (Charted account account_data x) = Account.Account_Section x
 150         account_path = Account.account_path . charted
 151 instance
 152  ( Account account
 153  , Eq x
 154  ) => Eq (Charted account account_data x) where
 155         (==) = (==) `on` charted
 156 instance
 157  ( Account account
 158  , Ord x
 159  ) => Ord (Charted account account_data x) where
 160         compare = compare `on` charted
 161 instance Functor (Charted account account_data) where
 162         fmap f (Charted a x) = Charted a $ f x
 163 instance
 164  ( Account account
 165  , Monoid x
 166  ) => Monoid (Charted account account_data x) where
 167         mempty = Charted mempty mempty
 168         mappend (Charted xc xt) (Charted yc yt) =
 169                 Charted (mappend xc yc) (mappend xt yt)
 170 instance
 171  ( Account account
 172  , NFData account, NFData x
 173  ) => NFData (Charted account account_data x) where
 174         rnf (Charted c x) = rnf c `seq` rnf x
 175 -}
 176
 177 {-
 178 -- | Return the 'Account's associated with
 179 --   the given 'Tag'
 180 --   in the given 'Chart'.
 181 tag_accounts :: Tag -> Chart -> [Account]
 182 tag_accounts (p:|ps, value) chart =
 183         concat $
 184         TreeMap.find_along (p:|ps `mappend` [value]) $
 185         chart_tags chart
 186 -}