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 q
 110  => Polarizable (Polarized q) where
 111         polarizable_negative qty =
 112                 case qty of
 113                  Polarized_Negative _ -> Just qty
 114                  Polarized_Positive _ -> Nothing
 115                  Polarized_Both n _   -> Just (Polarized_Negative n)
 116         polarizable_positive qty =
 117                 case qty of
 118                  Polarized_Negative _ -> Nothing
 119                  Polarized_Positive _ -> Just qty
 120                  Polarized_Both _ p   -> Just (Polarized_Positive p)
 121 instance -- Map unit quantity
 122  ( Polarizable quantity
 123  , Data        unit
 124  , Ord         unit
 125  , Show        unit
 126  ) => Polarizable (Map unit quantity) where
 127         polarizable_positive q =
 128                 case Map.mapMaybe polarizable_positive q of
 129                  m | Map.null m -> Nothing
 130                  m -> Just m
 131         polarizable_negative q =
 132                 case Map.mapMaybe polarizable_negative q of
 133                  m | Map.null m -> Nothing
 134                  m -> Just m
 135 instance -- (unit, quantity)
 136  ( Polarizable quantity
 137  ) => Polarizable (unit, quantity) where
 138         polarizable_positive (u, q) = (u,) <$> polarizable_positive q
 139         polarizable_negative (u, q) = (u,) <$> polarizable_negative q
 140
 141 polarize
 142  :: Polarizable q
 143  => q -> Polarized q
 144 polarize qty =
 145         case ( polarizable_negative qty
 146              , polarizable_positive qty ) of
 147          (Just n, Nothing)  -> Polarized_Negative n
 148          (Nothing, Just p)  -> Polarized_Positive p
 149          (Just n, Just p)   -> Polarized_Both n p
 150          (Nothing, Nothing) -> Polarized_Both qty qty
 151 depolarize
 152  :: Addable q
 153  => Polarized q -> q
 154 depolarize qty =
 155         case qty of
 156          Polarized_Negative n -> n
 157          Polarized_Positive p -> p
 158          Polarized_Both n p   -> quantity_add n p