src/Symantic/Compta/Lang/Math.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 module Symantic.Compta.Lang.Math where
   3
   4 import Data.Bool
   5 import Data.Function ((.), flip)
   6 import Data.Decimal (Decimal, DecimalRaw(..), roundTo)
   7 import Data.Eq (Eq(..))
   8 import Data.Map.Strict (Map)
   9 import Data.Maybe (Maybe(..))
  10 import Data.Functor ((<$>))
  11 import Data.Monoid (Endo(..))
  12 import Data.String (String)
  13 import Data.Ord (Ord(..), Ordering(..))
  14 import Data.Word (Word8)
  15 import Data.Int (Int)
  16 import Prelude (Integral, Integer, fromIntegral)
  17 import qualified Data.Map.Strict as Map
  18 import qualified Prelude
  19
  20 import Symantic.Compta.Lang.Rebindable
  21
  22 -- * Class 'Zeroable'
  23 class Zeroable a where
  24   zero :: a
  25 instance Zeroable String where
  26   zero = ""
  27 instance Zeroable Decimal where
  28   zero = 0
  29 instance Zeroable (Map.Map k a) where
  30   zero = Map.empty
  31
  32 {-
  33 instance Zeroable Decimal where
  34   zero = 0
  35 instance Zeroable (Map k a) where
  36   zero = Map.empty
  37 -}
  38
  39 -- * Class 'Nullable'
  40 class Nullable a where
  41   null :: a -> Bool
  42   default null :: Zeroable a => Eq a => a -> Bool
  43   null = (== zero)
  44 instance Nullable String
  45 instance Nullable Decimal
  46
  47 {-
  48 instance Nullable Decimal where
  49   null = (==) zero
  50 instance Nullable a => Nullable (Map k a) where
  51   null = Foldable.all null
  52 -}
  53
  54 -- * Class 'Signable'
  55 class Signable a where
  56   sign :: a -> Ordering
  57   default sign :: Zeroable a => Nullable a => Ord a => a -> Ordering
  58   sign a =
  59     case () of
  60      _ | null a -> EQ
  61      _ | a < zero -> LT
  62      _ -> GT
  63 --instance Signable Decimal
  64
  65 -- * Class 'Addable'
  66 class Addable a where
  67   (+) :: a -> a -> a; infixl 6 +
  68   default (+) :: Prelude.Num a => a -> a -> a
  69   (+) = (Prelude.+)
  70 -- | For @'Addable' ('Map' k ())@.
  71 instance Addable () where
  72   (+) () () = ()
  73 instance (Ord k, Addable a) => Addable (Map k a) where
  74   (+) = Map.unionWith (flip (+))
  75 instance Addable a => Addable (Maybe a) where
  76   Nothing + Nothing = Nothing
  77   Just x + Nothing = Just x
  78   Nothing + Just y = Just y
  79   Just x + Just y = Just (x + y)
  80 instance Addable Decimal where
  81   (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny))
  82     where (e, nx, ny) = roundMinDecimal x y
  83 -- | Round the two 'DecimalRaw' values to the smallest exponent.
  84 roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
  85 roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
  86   where
  87     e = min e1 e2
  88     Decimal _ n1 = roundTo e d1
  89     Decimal _ n2 = roundTo e d2
  90
  91 -- * Class 'Negable'
  92 class Negable a where
  93   negate :: a -> a
  94   default negate :: Prelude.Num a => a -> a
  95   negate = Prelude.negate
  96 -- | For @'Negable' ('Map' k ())@.
  97 instance Negable () where
  98   negate () = ()
  99 instance Negable Int
 100 instance Negable Integer
 101 instance Negable Decimal
 102 instance Negable a => Negable (Map k a) where
 103   negate = Map.map negate
 104 instance Negable a => Negable (Endo a) where
 105   negate (Endo f) = Endo (f . negate)
 106 instance Negable a => Negable [a] where
 107   negate = (negate <$>)
 108
 109 -- * Class 'Subable'
 110 class Subable a where
 111   (-) :: a -> a -> a; infixl 6 -
 112   default (-) :: Prelude.Num a => a -> a -> a
 113   (-) = (Prelude.-)
 114 -- | For @'Subable' ('Map' k ())@.
 115 instance Subable () where
 116   (-) () () = ()
 117 instance Subable Int
 118 instance Subable Integer
 119 instance Subable Decimal
 120 instance (Ord k, Addable a, Negable a) => Subable (Map k a) where
 121   (-) x y = Map.unionWith (flip (+)) x (negate y)