add castToInteger

src/Control/Abstract/Value.hs

@@ -97,6 +97,10 @@ class Show value => AbstractIntro value where
 --
 --   This allows us to abstract the choice of whether to evaluate under binders for different value types.
 class AbstractIntro value => AbstractValue address value effects where
+  -- | Cast numbers to integers
+  castToInteger :: value -> Evaluator address value effects value
+
+
   -- | Lift a unary operator over a 'Num' to a function on 'value's.
   liftNumeric  :: (forall a . Num a => a -> a)
                -> (value -> Evaluator address value effects value)

src/Data/Abstract/Value/Abstract.hs

@@ -95,3 +95,5 @@ instance ( Member (Allocator address) effects
   liftComparison _ _ _ = pure Abstract
 
   loop f = f empty
+
+  castToInteger _ = pure Abstract

src/Data/Abstract/Value/Concrete.hs

@@ -19,7 +19,7 @@ import qualified Data.Abstract.Number as Number
 import Data.Bits
 import Data.Coerce
 import Data.List (genericIndex, genericLength)
-import Data.Scientific (Scientific, coefficient)
+import Data.Scientific (Scientific, coefficient, normalize)
 import Data.Scientific.Exts
 import qualified Data.Set as Set
 import Data.Word
@@ -269,12 +269,10 @@ instance ( Coercible body (Eff effects)
 
   liftBitwise operator target
     | Integer (Number.Integer i) <- target = pure . integer $ operator i
-    | Float (Number.Decimal i) <- target = pure . integer $ operator (coefficient (normalize i))
     | otherwise = throwValueError (BitwiseError target)
 
   liftBitwise2 operator left right
     | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . integer $ operator i j
-    | (Float   (Number.Decimal i), Float   (Number.Decimal j)) <- pair = pure . integer $ operator (coefficient (normalize i)) (coefficient (normalize j))
     | otherwise = throwValueError (Bitwise2Error left right)
       where pair = (left, right)
 
@@ -282,9 +280,6 @@ instance ( Coercible body (Eff effects)
     | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair =
       if i >= 0 then pure . integer $ ourShift (fromIntegral i) (fromIntegral j)
       else throwValueError (Bitwise2Error left right)
-    | (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair =
-      if i >= 0 then pure . integer $ ourShift (fromInteger (coefficient (normalize i))) (fromInteger (coefficient (normalize j)))
-      else throwValueError (Bitwise2Error left right)
     | otherwise = throwValueError (Bitwise2Error left right)
       where
         pair = (left, right)
@@ -296,6 +291,8 @@ instance ( Coercible body (Eff effects)
     -- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label.
     Continue _  -> loop x)
 
+  castToInteger (Integer (Number.Integer i)) = pure (Integer (Number.Integer i))
+  castToInteger (Float (Number.Decimal i)) = pure (Integer (Number.Integer (coefficient (normalize i))))
 
 -- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
 data ValueError address body resume where

src/Data/Abstract/Value/Type.hs

@@ -343,3 +343,5 @@ instance ( Member (Allocator address) effects
     _                 -> unify left right $> Bool
 
   loop f = f empty
+
+  castToInteger t = unify t (Int :+ Float :+ Rational) $> Int

src/Data/Syntax/Expression.hs

@@ -327,8 +327,8 @@ instance Ord1 BOr where liftCompare = genericLiftCompare
 instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable BOr where
   eval (BOr a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     liftBitwise2 (.|.) a' b' >>= rvalBox
 
 data BAnd a = BAnd { left :: a, right :: a }
@@ -339,8 +339,8 @@ instance Ord1 BAnd where liftCompare = genericLiftCompare
 instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable BAnd where
   eval (BAnd a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     liftBitwise2 (.&.) a' b' >>= rvalBox
 
 
@@ -352,8 +352,8 @@ instance Ord1 BXOr where liftCompare = genericLiftCompare
 instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable BXOr where
   eval (BXOr a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     liftBitwise2 xor a' b' >>= rvalBox
 
 data LShift a = LShift { left :: a, right :: a }
@@ -364,8 +364,8 @@ instance Ord1 LShift where liftCompare = genericLiftCompare
 instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable LShift where
   eval (LShift a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     liftBitwise2 shiftL' a' b' >>= rvalBox
     where
       shiftL' a b = shiftL a (fromIntegral (toInteger b))
@@ -378,8 +378,8 @@ instance Ord1 RShift where liftCompare = genericLiftCompare
 instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable RShift where
   eval (RShift a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     liftBitwise2 shiftR' a' b' >>= rvalBox
     where
       shiftR' a b = shiftR a (fromIntegral (toInteger b))
@@ -392,8 +392,8 @@ instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare
 instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable UnsignedRShift where
   eval (UnsignedRShift a b) = do
-    a' <- subtermValue a
-    b' <- subtermValue b
+    a' <- subtermValue a >>= castToInteger
+    b' <- subtermValue b >>= castToInteger
     unsignedRShift a' b' >>= rvalBox
     -- This isn't working for JavaScript
 
@@ -406,7 +406,7 @@ instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Complement where
   eval (Complement a) = do
-    a' <- subtermValue a
+    a' <- subtermValue a >>= castToInteger
     liftBitwise complement a' >>= rvalBox
 
 -- | Member Access (e.g. a.b)