Merge pull request #1547 from github/boolean-arithmetic-evaluation

Implement evaluation over Arithmetic and Boolean operations.

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Value where
 
 import Control.Abstract.Addressable
@@ -7,7 +7,8 @@ import Data.Abstract.Environment
 import Data.Abstract.FreeVariables
 import Data.Abstract.Type as Type
 import Data.Abstract.Value as Value
-import Data.Scientific (Scientific)
+import Data.Bitraversable
+import Data.Scientific (Scientific, fromFloatDigits, toRealFloat)
 import Prelude hiding (fail)
 import Prologue
 
@@ -22,6 +23,18 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Construct an abstract integral value.
   integer :: Prelude.Integer -> m value
 
+  -- | Lift a unary operator over a 'Num' to a function on 'value's.
+  liftNumeric  :: (forall a . Num a => a -> a)
+               -> (value -> m value)
+
+  -- | Lift a pair of binary operators to a function on 'value's.
+  --   You usually pass the same operator as both arguments, except in the cases where
+  --   Haskell provides different functions for integral and fractional operations, such
+  --   as division, exponentiation, and modulus.
+  liftNumeric2 :: (forall a . (Real a, Floating a) => a -> a -> a)
+               -> (forall b . Integral b           => b -> b -> b)
+               -> (value -> value -> m value)
+
   -- | Construct an abstract boolean value.
   boolean :: Bool -> m value
 
@@ -38,7 +51,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   interface :: value -> m value
 
   -- | Eliminate boolean values. TODO: s/boolean/truthy
-  ifthenelse :: value -> m value -> m value -> m value
+  ifthenelse :: value -> m a -> m a -> m a
 
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   abstract :: [Name] -> Subterm term (m value) -> m value
@@ -48,6 +61,10 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Extract the environment from an interface value.
   environment :: value -> m (EnvironmentFor value)
 
+-- | Attempt to extract a 'Prelude.Bool' from a given value.
+toBool :: MonadValue term value m => value -> m Bool
+toBool v = ifthenelse v (pure True) (pure False)
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
 instance ( MonadAddressable location (Value location term) m
          , MonadAnalysis term (Value location term) m
@@ -70,6 +87,26 @@ instance ( MonadAddressable location (Value location term) m
     | Just (Boolean b) <- prjValue cond = if b then if' else else'
     | otherwise = fail ("not defined for non-boolean conditions: " <> show cond)
 
+  liftNumeric f arg
+    | Just (Integer i)     <- prjValue arg = pure . injValue . Integer     $ f i
+    | Just (Value.Float i) <- prjValue arg = pure . injValue . Value.Float $ f i
+    | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
+
+  liftNumeric2 f g left right
+    | Just (Integer i, Integer j)         <- prjPair pair = pure . injValue . Integer $ g i j
+    | Just (Integer i, Value.Float j)     <- prjPair pair = pure . injValue . float   $ f (fromIntegral i) (munge j)
+    | Just (Value.Float i, Value.Float j) <- prjPair pair = pure . injValue . float   $ f (munge i) (munge j)
+    | Just (Value.Float i, Integer j)     <- prjPair pair = pure . injValue . float   $ f (munge i) (fromIntegral j)
+    | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
+      where
+        -- Yucky hack to work around the lack of a Floating instance for Scientific.
+        -- This may possibly lose precision, but there's little we can do about that.
+        munge :: Scientific -> Double
+        munge = toRealFloat
+        float :: Double -> Value.Float a
+        float = Value.Float . fromFloatDigits
+        pair = (left, right)
+
   abstract names (Subterm body _) = injValue . Closure names body <$> askLocalEnv
 
   apply op params = do
@@ -108,6 +145,16 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue
 
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
+  liftNumeric _ Type.Float = pure Type.Float
+  liftNumeric _ Int        = pure Int
+  liftNumeric _ _          = fail "Invalid type in unary numeric operation"
+
+  liftNumeric2 _ _ left right = case (left, right) of
+    (Type.Float, Int) -> pure Type.Float
+    (Int, Type.Float) -> pure Type.Float
+    _                 -> unify left right
+
+
   apply op params = do
     tvar <- fresh
     paramTypes <- traverse subtermValue params

src/Data/Abstract/Value.hs

@@ -37,6 +37,13 @@ injValue = Value . inj
 prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term))
 prjValue = prj . deValue
 
+-- | Convenience function for projecting two values.
+prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2)
+        => (Value loc term1, Value loc term2)
+        -> Maybe (f (Value loc term1), g (Value loc term2))
+prjPair = bitraverse prjValue prjValue
+
+
 -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
 
 -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body.

src/Data/Syntax/Expression.hs

@@ -2,7 +2,9 @@
 module Data.Syntax.Expression where
 
 import Data.Abstract.Evaluatable
+import Data.Fixed
 import Diffing.Algorithm
+import Prelude hiding (fail)
 import Prologue hiding (apply)
 
 -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
@@ -51,8 +53,15 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare
 instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Arithmetic
-instance Evaluatable Arithmetic
-
+instance Evaluatable Arithmetic where
+  eval = traverse subtermValue >=> go where
+    go (Plus a b)      = liftNumeric2 (+) (+) a b
+    go (Minus a b)     = liftNumeric2 (-) (-) a b
+    go (Times a b)     = liftNumeric2 (*) (*) a b
+    go (DividedBy a b) = liftNumeric2 (/) div a b
+    go (Modulo a b)    = liftNumeric2 mod' mod a b
+    go (Power a b)     = liftNumeric2 (**) (^) a b
+    go (Negate a)      = liftNumeric negate a
 
 -- | Boolean operators.
 data Boolean a
@@ -66,9 +75,17 @@ instance Eq1 Boolean where liftEq = genericLiftEq
 instance Ord1 Boolean where liftCompare = genericLiftCompare
 instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Boolean
-instance Evaluatable Boolean
-
+instance Evaluatable Boolean where
+  -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
+  eval = go . fmap subtermValue where
+    go (And a b) = do
+      cond <- a
+      ifthenelse cond b (pure cond)
+    go (Or a b) = do
+      cond <- a
+      ifthenelse cond (pure cond) b
+    go (Not a) = a >>= toBool >>= boolean . not
+    go (XOr a b) = liftA2 (/=) (a >>= toBool) (b >>= toBool) >>= boolean
 
 -- | Javascript delete operator
 newtype Delete a = Delete a