lcc/Hcompta/LCC/Chart.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE DeriveTraversable #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.LCC.Chart where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Control.DeepSeq (NFData(..))
  11 import Data.Bool
  12 import Data.Data
  13 import Data.Eq (Eq)
  14 import Data.Int (Int)
  15 import Data.Foldable (Foldable)
  16 import Data.Function (($), (.), on)
  17 import Data.Functor (Functor)
  18 import qualified Data.List as List
  19 import Data.Map.Strict (Map)
  20 import Data.Maybe (Maybe, maybeToList)
  21 import Data.Strict.Maybe as Strict
  22 import Data.Monoid (Monoid(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Traversable (Traversable)
  25 import Data.TreeMap.Strict (TreeMap)
  26 import qualified Data.TreeMap.Strict        as TreeMap
  27 import qualified Data.TreeMap.Strict.Zipper as TreeMap
  28 import Data.Typeable ()
  29 import Prelude (seq)
  30 import Text.Show (Show)
  31
  32 import qualified Hcompta.Account as H
  33 import Hcompta.LCC.Account
  34 import Hcompta.LCC.Tag
  35
  36 -- * Type 'Chart'
  37 data Chart
  38  =   Chart
  39  {   chart_accounts :: TreeMap Account_Section Chart_Item
  40  ,   chart_anchors  :: Map Account_Anchor Account
  41  } deriving (Data, Eq, Show, Typeable)
  42 type Chart_Item = Account_Tags
  43 instance NFData Chart where
  44         rnf Chart{..} =
  45                 rnf chart_accounts `seq`
  46                 rnf chart_anchors
  47 instance Monoid Chart where
  48         mempty = Chart
  49          { chart_accounts = mempty
  50          , chart_anchors  = mempty
  51          }
  52         mappend x y =
  53                 Chart
  54                  { chart_accounts = chart_accounts x `mappend` chart_accounts y
  55                  , chart_anchors  = chart_anchors  x `mappend` chart_anchors  y
  56                  }
  57
  58 -- * Type 'Charted'
  59 data Charted a
  60  =   Charted
  61  {   chart   :: Chart
  62  ,   charted :: a
  63  } deriving (Data, Eq, Foldable, Functor, Show, Traversable, Typeable)
  64
  65 instance Ord a => Ord (Charted a) where
  66         compare = compare `on` charted
  67 instance H.Account (Charted Account)
  68
  69 type Zipper_Chart = TreeMap.Zipper Account_Section Chart_Item
  70 type Zipper_Account_Tags = TreeMap.Zipper Tag_Path_Section [Tag_Value]
  71 type Chart_Select = Zipper_Chart -> [Zipper_Chart]
  72 type Zipper_Select k a = TreeMap.Zipper k a -> [TreeMap.Zipper k a]
  73 type Zipper_SelectF f k a = TreeMap.Zipper k a -> f (TreeMap.Zipper k a)
  74
  75 -- * Zipper
  76 zipper_chart :: Chart -> Zipper_Chart
  77 zipper_chart = TreeMap.zipper . chart_accounts
  78
  79 zipper_accounts_tags :: Zipper_Chart -> Zipper_Account_Tags
  80 zipper_accounts_tags z =
  81         case TreeMap.node_value $ TreeMap.zipper_self z of
  82          Strict.Just (Account_Tags (Tags tags)) -> TreeMap.zipper tags
  83          _ -> TreeMap.zipper TreeMap.empty
  84
  85 {-
  86 -- /child::A
  87 account_step account_child (\a -> "A" == a_name a)
  88 -- /child::A/child::B
  89 account_step account_child (\a -> "A" == a_name a) >=>
  90 account_step account_child (\a -> "B" == a_name a)
  91 -}