Handle needed changes associated with NumericFunction.

github · Jul 6, 2019 · 0329984 · 0329984
1 parent 94c8adb
commit 0329984
Show file tree

Hide file tree

Showing 3 changed files with 20 additions and 11 deletions.
diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs
@@ -48,6 +48,8 @@ module Control.Abstract.Value
 , ObjectC(..)
 , runObject
 , runNumeric
+, runNumericFunction
+, runNumeric2Function
 , castToInteger
 , liftBitwise
 , liftBitwise2
@@ -289,8 +291,15 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m)
 liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure)
 
 data NumericFunction = NumericFunction (forall a . Num a => a -> a)
+
+runNumericFunction :: Num a => NumericFunction -> a -> a
+runNumericFunction (NumericFunction f) a = f a
+
 data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber)
 
+runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber
+runNumeric2Function (Numeric2Function f) a b = f a b
+
 data Numeric value (m :: * -> *) k
   = Integer Integer (value -> m k)
   | Float Scientific (value -> m k)

diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Interpose
 ( Interpose(..)
 , interpose
@@ -12,7 +12,7 @@ import Control.Effect.Carrier
 import Control.Effect.Reader
 import Control.Effect.Sum
 
-data Interpose eff m k
+data Interpose (eff :: (* -> *) -> * -> *) m k
   = forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k)
 
 -- deriving instance Functor m => Functor (Interpose eff m)

diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs
@@ -231,15 +231,15 @@ instance ( Member (Reader ModuleInfo) sig
       Rational (Number.Ratio r)  -> pure $ Rational (Number.Ratio (f r))
       other                      -> throwBaseError (NumericError other)
     Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of
-      (Integer  i, Integer j)  -> attemptUnsafeArithmetic (f i j) & specialize
-      (Integer  i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
-      (Integer  i, Float j)    -> attemptUnsafeArithmetic (f i j) & specialize
-      (Rational i, Integer j)  -> attemptUnsafeArithmetic (f i j) & specialize
-      (Rational i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
-      (Rational i, Float j)    -> attemptUnsafeArithmetic (f i j) & specialize
-      (Float    i, Integer j)  -> attemptUnsafeArithmetic (f i j) & specialize
-      (Float    i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
-      (Float    i, Float j)    -> attemptUnsafeArithmetic (f i j) & specialize
+      (Integer  i, Integer j)  -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Integer  i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Integer  i, Float j)    -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Rational i, Integer j)  -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Rational i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Rational i, Float j)    -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Float    i, Integer j)  -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Float    i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
+      (Float    i, Float j)    -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize
       _                        -> throwBaseError (Numeric2Error left right)
 
 -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor