lib/Hcompta/Quantity.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Quantity where
   7
   8 import Control.DeepSeq (NFData(..))
   9 import Data.Bool
  10 import Data.Data (Data)
  11 import Data.Decimal (Decimal, DecimalRaw(..), roundTo)
  12 import Data.Eq (Eq(..))
  13 import Data.Function (const, flip)
  14 import Data.Functor (Functor(..), (<$>))
  15 import Data.Map.Strict (Map)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Ord (Ord(..), Ordering(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (Seq)
  20 import Data.TreeMap.Strict (TreeMap)
  21 import Data.Tuple (curry, uncurry)
  22 import Data.Typeable (Typeable)
  23 import Data.Word (Word8)
  24 import Prelude (Integer, Integral, fromIntegral, seq)
  25 import Text.Show (Show(..))
  26 import qualified Data.Foldable as Foldable
  27 import qualified Data.List as L
  28 import qualified Data.Map.Strict as Map
  29 import qualified Data.Sequence as Seq
  30 import qualified Data.TreeMap.Strict as TM
  31 import qualified Prelude
  32
  33 -- * Class 'Zeroable'
  34 class Zeroable a where
  35         zero :: a
  36
  37 instance Zeroable () where
  38         zero = ()
  39 instance Zeroable Integer where
  40         zero = 0
  41 instance Zeroable Decimal where
  42         zero = 0
  43 instance Zeroable (Seq a) where
  44         zero = Seq.empty
  45 instance Zeroable [a] where
  46         zero = []
  47 instance Zeroable (Map k a) where
  48         zero = Map.empty
  49 instance Zeroable (TreeMap k a) where
  50         zero = TM.empty
  51
  52 -- * Class 'Nullable'
  53 class Zeroable a => Nullable a where
  54         null :: a -> Bool
  55         default null :: Eq a => a -> Bool
  56         null = (== zero)
  57
  58 instance Nullable Integer where
  59         null = (==) 0
  60 instance Nullable Decimal where
  61         null = (==) 0
  62 instance Nullable [a] where
  63         null = L.null
  64 instance Nullable (Seq a) where
  65         null = Seq.null
  66 instance Nullable a => Nullable (Map k a) where
  67         null = Foldable.all null
  68 instance Nullable (TreeMap k a) where
  69         null = TM.null
  70
  71 -- * Class 'Signable'
  72 class Signable a where
  73         sign :: a -> Ordering
  74         default sign :: (Nullable a, Ord a) => a -> Ordering
  75         sign a =
  76                 case () of
  77                  _ | null a -> EQ
  78                  _ | a < zero -> LT
  79                  _ -> GT
  80
  81 instance Signable Integer
  82 instance Signable Decimal
  83
  84 -- * Class 'Addable'
  85 class Addable a where
  86         (+) :: a -> a -> a; infixl 6 +
  87 instance Addable () where
  88         (+) = const
  89 instance Addable Integer where
  90         (+) = (Prelude.+)
  91 instance Addable Decimal where
  92         (+) x y =
  93                 Decimal e (fromIntegral (nx Prelude.+ ny))
  94                 where (e, nx, ny) = roundMinDecimal x y
  95 instance Addable [a] where
  96         (+) = (<>)
  97 instance Addable (Seq a) where
  98         (+) = (<>)
  99 instance (Ord k, Addable a) => Addable (Map k a) where
 100         (+) = Map.unionWith (flip (+))
 101 instance (Ord k, Addable a) => Addable (TreeMap k a) where
 102         (+) = TM.union (+)
 103
 104 -- * Class 'Negable'
 105 class Negable a where
 106         neg  :: a -> a
 107 instance Negable Integer where
 108         neg = Prelude.negate
 109 instance Negable Decimal where
 110         neg = Prelude.negate
 111 instance Negable a => Negable (Map k a) where
 112         neg = Map.map neg
 113
 114 -- * Class 'Subable'
 115 class Subable a where
 116         (-) :: a -> a -> a; infixl 6 -
 117 instance Subable Integer where
 118         (-) = (Prelude.-)
 119 instance Subable Decimal where
 120         (-) = (Prelude.-)
 121 instance (Ord k, Addable a, Negable a) => Subable (Map k a) where
 122         (-) x y = Map.unionWith (flip (+)) x (neg y)
 123
 124 -- * Class 'Sumable'
 125 class Sumable s a where
 126         (+=) :: s -> a -> s; infix 4 +=
 127         sum :: a -> s
 128         default sum :: Zeroable s => a -> s
 129         sum = (zero +=)
 130 instance (Sumable s a, Zeroable s) => Sumable s [a] where
 131         (+=) = Foldable.foldr (flip (+=))
 132         sum = (zero +=)
 133 instance (Ord k, Addable a) => Sumable (TreeMap k a) (TM.Path k, a) where
 134         (+=) = flip (uncurry (TM.insert (flip (+))))
 135 instance (Ord k, Addable a, Sumable (Map k b) (TM.Path k, a)) =>
 136          Sumable (Map k b) (TreeMap k a) where
 137         (+=) = TM.foldrWithPath (curry (flip (+=)))
 138
 139 -- * Class 'Polarizable'
 140 class Polarizable a where
 141         negativeOf :: a -> Maybe a
 142         positiveOf :: a -> Maybe a
 143 instance Polarizable Integer where
 144         negativeOf q =
 145                 case q of
 146                  _ | q < 0 -> Just q
 147                  _         -> Nothing
 148         positiveOf q =
 149                 case q of
 150                  _ | q <= 0 -> Nothing
 151                  _          -> Just q
 152 instance Polarizable Decimal where
 153         negativeOf q =
 154                 case q of
 155                  _ | q < 0 -> Just q
 156                  _         -> Nothing
 157         positiveOf q =
 158                 case q of
 159                  _ | q <= 0 -> Nothing
 160                  _          -> Just q
 161 instance Polarizable (Polarized a) where
 162         negativeOf qty =
 163                 case qty of
 164                  PolNegative _ -> Just qty
 165                  PolPositive _ -> Nothing
 166                  PolBoth n _   -> Just (PolNegative n)
 167         positiveOf qty =
 168                 case qty of
 169                  PolNegative _ -> Nothing
 170                  PolPositive _ -> Just qty
 171                  PolBoth _ p   -> Just (PolPositive p)
 172 instance Polarizable a => Polarizable (Map k a) where
 173         positiveOf q =
 174                 case Map.mapMaybe positiveOf q of
 175                  m | Map.null m -> Nothing
 176                  m -> Just m
 177         negativeOf q =
 178                 case Map.mapMaybe negativeOf q of
 179                  m | Map.null m -> Nothing
 180                  m -> Just m
 181 instance Polarizable a => Polarizable (k, a) where
 182         positiveOf (u, q) = (u,) <$> positiveOf q
 183         negativeOf (u, q) = (u,) <$> negativeOf q
 184
 185 -- ** Type 'Polarized'
 186 -- | Polarize a quantity to distinctively keep track
 187 --   of negative and positive ones.
 188 data Polarized a
 189  =   PolNegative !a
 190  |   PolPositive !a
 191  |   PolBoth     !a !a
 192  deriving (Data, Eq, Functor, Ord, Show, Typeable)
 193 instance NFData a => NFData (Polarized a) where
 194         rnf (PolNegative n) = rnf n
 195         rnf (PolPositive p) = rnf p
 196         rnf (PolBoth n p)   = rnf n `seq` rnf p
 197 instance Zeroable a => Zeroable (Polarized a) where
 198         zero = PolPositive zero
 199 instance (Nullable a, Addable a) => Nullable (Polarized a) where
 200         null qty =
 201                 case qty of
 202                  PolNegative n -> null n
 203                  PolPositive p -> null p
 204                  PolBoth n p   -> null (n + p)
 205 instance Addable a => Addable (Polarized a) where
 206         PolNegative nx + PolNegative ny = PolNegative (nx + ny)
 207         PolNegative n  + PolPositive p  = PolBoth n p
 208         PolNegative nx + PolBoth ny p   = PolBoth (nx + ny) p
 209
 210         PolPositive p  + PolNegative n  = PolBoth n p
 211         PolPositive px + PolPositive py = PolPositive (px + py)
 212         PolPositive p  + PolBoth ny py  = PolBoth ny (p + py)
 213
 214         PolBoth nx px  + PolNegative n  = PolBoth (nx + n) px
 215         PolBoth nx px  + PolPositive py = PolBoth nx (px + py)
 216         PolBoth nx px  + PolBoth ny py  = PolBoth (nx + ny) (px + py)
 217 instance Negable a => Negable (Polarized a) where
 218         neg (PolNegative n) = PolPositive (neg n)
 219         neg (PolPositive p) = PolNegative (neg p)
 220         neg (PolBoth n p)   = PolBoth     (neg p) (neg n)
 221
 222 unNegative :: Polarized a -> Maybe a
 223 unNegative qty =
 224         case qty of
 225          PolNegative n -> Just n
 226          PolPositive _ -> Nothing
 227          PolBoth n _   -> Just n
 228
 229 unPositive :: Polarized a -> Maybe a
 230 unPositive qty =
 231         case qty of
 232          PolNegative _ -> Nothing
 233          PolPositive p -> Just p
 234          PolBoth _ p   -> Just p
 235
 236 polarize :: Polarizable a => a -> Polarized a
 237 polarize qty =
 238         case (negativeOf qty, positiveOf qty) of
 239          (Just n, Nothing)  -> PolNegative n
 240          (Nothing, Just p)  -> PolPositive p
 241          (Just n, Just p)   -> PolBoth n p
 242          (Nothing, Nothing) -> PolBoth qty qty
 243 depolarize :: Addable a => Polarized a -> a
 244 depolarize qty =
 245         case qty of
 246          PolNegative n -> n
 247          PolPositive p -> p
 248          PolBoth n p   -> n + p
 249
 250 -- * Type 'Decimal'
 251
 252 -- Orphan instance
 253 deriving instance Data Decimal
 254
 255 -- | Round the two 'DecimalRaw' values to the smallest exponent.
 256 roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
 257 roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
 258         where
 259                 e = min e1 e2
 260                 Decimal _ n1 = roundTo e d1
 261                 Decimal _ n2 = roundTo e d2