]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Polarize.hs
Fix balance tests to use new TreeMap.
[comptalang.git] / lib / Hcompta / Polarize.hs
1 {-# LANGUAGE DeriveFunctor #-}
2 module Hcompta.Polarize where
3
4 import Control.DeepSeq
5 import Data.Data (Data)
6 import Data.Decimal (Decimal)
7 import Data.Eq (Eq)
8 import Data.Ord (Ord(..))
9 import Data.Functor (Functor, (<$>))
10 import Data.Map.Strict (Map)
11 import qualified Data.Map.Strict as Map
12 import Data.Maybe (Maybe(..))
13 import Data.Typeable
14 import Prelude (Integer, seq)
15 import Text.Show (Show)
16
17 import Hcompta.Quantity
18
19 -- * Type 'Polarized'
20
21 -- | Polarize a 'Quantity' to distinctively keep track
22 -- of negative and positive 'Quantity's.
23 data Polarized q
24 = Polarized_Negative !q
25 | Polarized_Positive !q
26 | Polarized_Both !q !q
27 deriving (Data, Eq, Functor, Ord, Show, Typeable)
28 instance -- NFData
29 NFData q =>
30 NFData (Polarized q) where
31 rnf (Polarized_Negative n) = rnf n
32 rnf (Polarized_Positive p) = rnf p
33 rnf (Polarized_Both n p) = rnf n `seq` rnf p
34 instance -- Zero
35 ( Zero q
36 , Addable q
37 ) => Zero (Polarized q) where
38 quantity_zero = Polarized_Positive quantity_zero
39 quantity_null qty =
40 case qty of
41 Polarized_Negative n -> quantity_null n
42 Polarized_Positive p -> quantity_null p
43 Polarized_Both n p -> quantity_null (quantity_add n p)
44 instance -- Addable
45 Addable q =>
46 Addable (Polarized q) where
47 quantity_add a0 a1 =
48 case (a0, a1) of
49 (Polarized_Negative n0, Polarized_Negative n1) -> Polarized_Negative (quantity_add n0 n1)
50 (Polarized_Negative n , Polarized_Positive p) -> Polarized_Both n p
51 (Polarized_Negative n0, Polarized_Both n1 p) -> Polarized_Both (quantity_add n0 n1) p
52
53 (Polarized_Positive p , Polarized_Negative n) -> Polarized_Both n p
54 (Polarized_Positive p0, Polarized_Positive p1) -> Polarized_Positive (quantity_add p0 p1)
55 (Polarized_Positive p , Polarized_Both n1 p1) -> Polarized_Both n1 (quantity_add p p1)
56
57 (Polarized_Both n0 p0, Polarized_Negative n) -> Polarized_Both (quantity_add n0 n) p0
58 (Polarized_Both n0 p0, Polarized_Positive p1) -> Polarized_Both n0 (quantity_add p0 p1)
59 (Polarized_Both n0 p0, Polarized_Both n1 p1) -> Polarized_Both (quantity_add n0 n1) (quantity_add p0 p1)
60 instance -- Negable
61 Negable q =>
62 Negable (Polarized q) where
63 quantity_neg qty =
64 case qty of
65 Polarized_Negative n -> Polarized_Positive (quantity_neg n)
66 Polarized_Positive p -> Polarized_Negative (quantity_neg p)
67 Polarized_Both n p -> Polarized_Both (quantity_neg p) (quantity_neg n)
68
69 polarized_negative :: Polarized q -> Maybe q
70 polarized_negative qty =
71 case qty of
72 Polarized_Negative n -> Just n
73 Polarized_Positive _ -> Nothing
74 Polarized_Both n _ -> Just n
75 polarized_positive :: Polarized q -> Maybe q
76 polarized_positive qty =
77 case qty of
78 Polarized_Negative _ -> Nothing
79 Polarized_Positive p -> Just p
80 Polarized_Both _ p -> Just p
81
82 -- * Class 'Polarizable'
83
84 class Polarizable q where
85 polarizable_negative :: q -> Maybe q
86 polarizable_positive :: q -> Maybe q
87 instance Polarizable Integer where
88 polarizable_negative q =
89 case q of
90 _ | q < 0 -> Just q
91 _ -> Nothing
92 polarizable_positive q =
93 case q of
94 _ | q <= 0 -> Nothing
95 _ -> Just q
96 instance Polarizable Decimal where
97 polarizable_negative q =
98 case q of
99 _ | q < 0 -> Just q
100 _ -> Nothing
101 polarizable_positive q =
102 case q of
103 _ | q <= 0 -> Nothing
104 _ -> Just q
105 instance -- Polarized
106 Polarizable (Polarized q) where
107 polarizable_negative qty =
108 case qty of
109 Polarized_Negative _ -> Just qty
110 Polarized_Positive _ -> Nothing
111 Polarized_Both n _ -> Just (Polarized_Negative n)
112 polarizable_positive qty =
113 case qty of
114 Polarized_Negative _ -> Nothing
115 Polarized_Positive _ -> Just qty
116 Polarized_Both _ p -> Just (Polarized_Positive p)
117 instance -- Map unit qty
118 Polarizable qty =>
119 Polarizable (Map unit qty) where
120 polarizable_positive q =
121 case Map.mapMaybe polarizable_positive q of
122 m | Map.null m -> Nothing
123 m -> Just m
124 polarizable_negative q =
125 case Map.mapMaybe polarizable_negative q of
126 m | Map.null m -> Nothing
127 m -> Just m
128 instance -- (unit, qty)
129 Polarizable qty =>
130 Polarizable (unit, qty) where
131 polarizable_positive (u, q) = (u,) <$> polarizable_positive q
132 polarizable_negative (u, q) = (u,) <$> polarizable_negative q
133
134 polarize
135 :: Polarizable q
136 => q -> Polarized q
137 polarize qty =
138 case ( polarizable_negative qty
139 , polarizable_positive qty ) of
140 (Just n, Nothing) -> Polarized_Negative n
141 (Nothing, Just p) -> Polarized_Positive p
142 (Just n, Just p) -> Polarized_Both n p
143 (Nothing, Nothing) -> Polarized_Both qty qty
144 depolarize
145 :: Addable q
146 => Polarized q -> q
147 depolarize qty =
148 case qty of
149 Polarized_Negative n -> n
150 Polarized_Positive p -> p
151 Polarized_Both n p -> quantity_add n p