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