lib/Hcompta/Polarize.hs

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