1 {-# LANGUAGE DeriveFunctor #-}
2 module Hcompta.Polarize where
5 import Data.Data (Data)
6 import Data.Decimal (Decimal)
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(..))
14 import Prelude (Integer, seq)
15 import Text.Show (Show)
17 import Hcompta.Quantity
21 -- | Polarize a 'Quantity' to distinctively keep track
22 -- of negative and positive 'Quantity's.
24 = Polarized_Negative !q
25 | Polarized_Positive !q
26 | Polarized_Both !q !q
27 deriving (Data, Eq, Functor, Ord, Show, Typeable)
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
37 ) => Zero (Polarized q) where
38 quantity_zero = Polarized_Positive quantity_zero
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)
46 Addable (Polarized q) where
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
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)
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)
62 Negable (Polarized q) where
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)
69 polarized_negative :: Polarized q -> Maybe q
70 polarized_negative qty =
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 =
78 Polarized_Negative _ -> Nothing
79 Polarized_Positive p -> Just p
80 Polarized_Both _ p -> Just p
82 -- * Class 'Polarizable'
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 =
92 polarizable_positive q =
96 instance Polarizable Decimal where
97 polarizable_negative q =
101 polarizable_positive q =
103 _ | q <= 0 -> Nothing
105 instance -- Polarized
106 Polarizable (Polarized q) where
107 polarizable_negative qty =
109 Polarized_Negative _ -> Just qty
110 Polarized_Positive _ -> Nothing
111 Polarized_Both n _ -> Just (Polarized_Negative n)
112 polarizable_positive qty =
114 Polarized_Negative _ -> Nothing
115 Polarized_Positive _ -> Just qty
116 Polarized_Both _ p -> Just (Polarized_Positive p)
117 instance -- Map unit 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
124 polarizable_negative q =
125 case Map.mapMaybe polarizable_negative q of
126 m | Map.null m -> Nothing
128 instance -- (unit, qty)
130 Polarizable (unit, qty) where
131 polarizable_positive (u, q) = (u,) <$> polarizable_positive q
132 polarizable_negative (u, q) = (u,) <$> polarizable_negative q
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
149 Polarized_Negative n -> n
150 Polarized_Positive p -> p
151 Polarized_Both n p -> quantity_add n p