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