From fb727c05cf5ef5bd3217ca982b06df9410b7a681 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 23 Mar 2018 20:12:19 -0400 Subject: [PATCH] Move the MonadValue instances into the Value/Type modules. --- src/Control/Abstract/Addressable.hs | 1 - src/Control/Abstract/Analysis.hs | 195 +--------------------------- src/Control/Abstract/Evaluator.hs | 33 ++++- src/Control/Abstract/Value.hs | 15 ++- src/Data/Abstract/Configuration.hs | 4 - src/Data/Abstract/Type.hs | 78 ++++++++++- src/Data/Abstract/Value.hs | 155 +++++++++++++++++----- src/Language/Ruby/Syntax.hs | 2 - 8 files changed, 241 insertions(+), 242 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 4021a490d..ddb2c9090 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -8,7 +8,6 @@ import Data.Abstract.Address import Data.Abstract.Environment (insert) import Data.Abstract.FreeVariables import Data.Abstract.Heap -import Data.Abstract.Value import Data.Semigroup.Reducer import Prelude hiding (fail) import Prologue diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index fdc24cd1f..e10328c42 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -14,12 +14,6 @@ module Control.Abstract.Analysis , MonadEvaluateModule(..) , Evaluatable(..) , MonadEvaluatable -, MonadValue(..) -, while -, doWhile -, forLoop -, toBool -, Comparator(..) , require , load ) where @@ -34,20 +28,14 @@ import qualified Control.Monad.Effect as Effect import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X -import Data.Abstract.Address import qualified Data.Abstract.Environment as Env import qualified Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable -import Data.Abstract.Number as Number -import Data.Abstract.Type as Type -import Data.Abstract.Value as Value import Data.Coerce -import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable -import qualified Data.Set as Set import Data.Term import Prelude hiding (fail) import Prologue @@ -75,12 +63,7 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. evaluateTerm :: ( Evaluatable (Base term) - , FreeVariables term - , MonadAddressable (LocationFor value) value m - , MonadEvaluateModule term value m - , MonadValue value m - , Show (LocationFor value) - , MonadThrow Prelude.String value m + , MonadEvaluatable term value m ) => term -> m value @@ -175,182 +158,6 @@ runAnalysis :: ( Effectful m runAnalysis = Effect.run . runEffects . lower - --- | Construct a 'Value' wrapping the value arguments (if any). -instance ( Evaluatable (Base term) - , FreeVariables term - , Monad m - , MonadAddressable Precise Value m - , MonadEvaluateModule term Value m - , MonadValue Value m - , MonadThrow Prelude.String Value m - ) - => MonadValue Value m where - - unit = pure . injValue $ Value.Unit - integer = pure . injValue . Value.Integer . Number.Integer - boolean = pure . injValue . Boolean - string = pure . injValue . Value.String - float = pure . injValue . Value.Float . Decimal - symbol = pure . injValue . Value.Symbol - rational = pure . injValue . Value.Rational . Ratio - - multiple = pure . injValue . Value.Tuple - array = pure . injValue . Value.Array - - klass n [] env = pure . injValue $ Class n env - klass n supers env = do - product <- mconcat <$> traverse objectEnvironment supers - pure . injValue $ Class n (Env.push product <> env) - - - objectEnvironment o - | Just (Class _ env) <- prjValue o = pure env - | otherwise = fail ("non-object type passed to objectEnvironment: " <> show o) - - asString v - | Just (Value.String n) <- prjValue v = pure n - | otherwise = fail ("expected " <> show v <> " to be a string") - - ifthenelse cond if' else' - | 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 (Value.Integer (Number.Integer i)) <- prjValue arg = integer $ f i - | Just (Value.Float (Decimal d)) <- prjValue arg = float $ f d - | Just (Value.Rational (Ratio r)) <- prjValue arg = rational $ f r - | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) - - liftNumeric2 f left right - | Just (Value.Integer i, Value.Integer j) <- prjPair pair = f i j & specialize - | Just (Value.Integer i, Value.Rational j) <- prjPair pair = f i j & specialize - | Just (Value.Integer i, Value.Float j) <- prjPair pair = f i j & specialize - | Just (Value.Rational i, Value.Integer j) <- prjPair pair = f i j & specialize - | Just (Value.Rational i, Value.Rational j) <- prjPair pair = f i j & specialize - | Just (Value.Rational i, Value.Float j) <- prjPair pair = f i j & specialize - | Just (Value.Float i, Value.Integer j) <- prjPair pair = f i j & specialize - | Just (Value.Float i, Value.Rational j) <- prjPair pair = f i j & specialize - | Just (Value.Float i, Value.Float j) <- prjPair pair = f i j & specialize - | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) - where - -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: MonadValue value m => SomeNumber -> m value - specialize (SomeNumber (Number.Integer i)) = integer i - specialize (SomeNumber (Ratio r)) = rational r - specialize (SomeNumber (Decimal d)) = float d - pair = (left, right) - - liftComparison comparator left right - | Just (Value.Integer (Number.Integer i), Value.Integer (Number.Integer j)) <- prjPair pair = go i j - | Just (Value.Integer (Number.Integer i), Value.Float (Decimal j)) <- prjPair pair = go (fromIntegral i) j - | Just (Value.Float (Decimal i), Value.Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) - | Just (Value.Float (Decimal i), Value.Float (Decimal j)) <- prjPair pair = go i j - | Just (Value.String i, Value.String j) <- prjPair pair = go i j - | Just (Boolean i, Boolean j) <- prjPair pair = go i j - | Just (Value.Unit, Value.Unit) <- prjPair pair = boolean True - | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair) - where - -- Explicit type signature is necessary here because we're passing all sorts of things - -- to these comparison functions. - go :: (Ord a, MonadValue value m) => a -> a -> m value - go l r = case comparator of - Concrete f -> boolean (f l r) - Generalized -> integer (orderingToInt (compare l r)) - - -- Map from [LT, EQ, GT] to [-1, 0, 1] - orderingToInt :: Ordering -> Prelude.Integer - orderingToInt = toInteger . pred . fromEnum - - pair = (left, right) - - - liftBitwise operator target - | Just (Value.Integer (Number.Integer i)) <- prjValue target = integer $ operator i - | otherwise = fail ("Type error: invalid unary bitwise operation on " <> show target) - - liftBitwise2 operator left right - | Just (Value.Integer (Number.Integer i), Value.Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j - | otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair) - where pair = (left, right) - - abstract names (Subterm body _) = do - l <- label body - injValue . Closure names l . Env.bind (foldr Set.delete (freeVariables body) names) <$> getEnv - - apply op params = do - Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) - bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mappend bindings) (goto label >>= evaluateTerm) - - loop = fix - --- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where - abstract names (Subterm _ body) = do - (env, tvars) <- foldr (\ name rest -> do - a <- alloc name - tvar <- Var <$> fresh - assign a tvar - (env, tvars) <- rest - pure (Env.insert name a env, tvar : tvars)) (pure mempty) names - ret <- localEnv (mappend env) body - pure (Product tvars :-> ret) - - unit = pure Type.Unit - integer _ = pure Int - boolean _ = pure Bool - string _ = pure Type.String - float _ = pure Type.Float - symbol _ = pure Type.Symbol - rational _ = pure Type.Rational - multiple = pure . Type.Product - array = pure . Type.Array - - klass _ _ _ = pure Object - - objectEnvironment _ = pure mempty - - asString _ = fail "Must evaluate to Value to use asString" - - 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 - - liftBitwise _ Int = pure Int - liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t) - - liftBitwise2 _ Int Int = pure Int - liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)) - - liftComparison (Concrete _) left right = case (left, right) of - (Type.Float, Int) -> pure Bool - (Int, Type.Float) -> pure Bool - _ -> unify left right $> Bool - liftComparison Generalized left right = case (left, right) of - (Type.Float, Int) -> pure Int - (Int, Type.Float) -> pure Int - _ -> unify left right $> Bool - - apply op params = do - tvar <- fresh - paramTypes <- sequenceA params - _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar) - pure ret - - loop f = f empty - instance Evaluatable [] where -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 9b53923a7..df08be19b 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator ( MonadEvaluator(..) , MonadEnvironment(..) @@ -15,6 +15,13 @@ module Control.Abstract.Evaluator , MonadControl(..) , MonadThrow(..) , EvaluateModule(..) +, EnvironmentFor +, ExportsFor +, HeapFor +, CellFor +, LiveFor +, LocationFor +, ConfigurationFor ) where import Control.Effect @@ -25,9 +32,9 @@ import qualified Data.Abstract.Environment as Env import qualified Data.Abstract.Exports as Export import Data.Abstract.FreeVariables import Data.Abstract.Heap +import Data.Abstract.Live import Data.Abstract.Module import Data.Abstract.ModuleTable -import Data.Abstract.Value import Data.Semigroup.Reducer import Prologue hiding (throwError) @@ -169,3 +176,25 @@ newtype EvaluateModule term = EvaluateModule (Module term) instance (Effectful m, Members '[Resumable exc value] effects, Monad (m effects)) => MonadThrow exc value (m effects) where throwException = raise . throwError + + +-- | The environment for an abstract value type. +type EnvironmentFor v = Env.Environment (LocationFor v) v + +-- | The exports for an abstract value type. +type ExportsFor v = Export.Exports (LocationFor v) v + +-- | The 'Heap' for an abstract value type. +type HeapFor value = Heap (LocationFor value) value + +-- | The cell for an abstract value type. +type CellFor value = Cell (LocationFor value) value + +-- | The address set type for an abstract value type. +type LiveFor value = Live (LocationFor value) value + +-- | The configuration for term and abstract value types. +type ConfigurationFor term value = Configuration (LocationFor value) term value + +-- | The location type (the body of 'Address'es) which should be used for an abstract value type. +type family LocationFor value :: * diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 942c4ad2f..321647ab7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -6,12 +6,19 @@ module Control.Abstract.Value , doWhile , forLoop , toBool +, ValueRoots(..) +, EnvironmentFor +, ExportsFor +, HeapFor +, CellFor +, LiveFor +, LocationFor +, ConfigurationFor ) where import Control.Abstract.Evaluator import Data.Abstract.FreeVariables import Data.Abstract.Number as Number -import Data.Abstract.Value as Value import Data.Scientific (Scientific) import Prelude hiding (fail) import Prologue @@ -139,3 +146,9 @@ doWhile :: MonadValue value m doWhile body cond = loop $ \ continue -> body *> do this <- cond ifthenelse this continue unit + + +-- | Value types, e.g. closures, which can root a set of addresses. +class ValueRoots value where + -- | Compute the set of addresses rooted by a given value. + valueRoots :: value -> LiveFor value diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index f08aef5c5..23afb9f09 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -5,12 +5,8 @@ import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.Heap import Data.Abstract.Live -import Data.Abstract.Value import Prologue --- | The configuration for term and abstract value types. -type ConfigurationFor term value = Configuration (LocationFor value) term value - -- | A single point in a program’s execution. data Configuration l t v = Configuration diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 8da343b44..af793c922 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} module Data.Abstract.Type where -import Prologue +import Control.Abstract.Analysis +import Data.Abstract.Address +import Data.Abstract.Environment as Env import Data.Align (alignWith) import Prelude hiding (fail) - --- | The type of type variable names. -type TName = Int +import Prologue -- | A datatype representing primitive types and combinations thereof. data Type @@ -36,3 +37,72 @@ unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure p unify t1 t2 | t1 == t2 = pure t2 | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) + + +type instance LocationFor Type = Monovariant + +instance ValueRoots Type where + valueRoots _ = mempty + + +-- | Discard the value arguments (if any), constructing a 'Type' instead. +instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where + abstract names (Subterm _ body) = do + (env, tvars) <- foldr (\ name rest -> do + a <- alloc name + tvar <- Var <$> fresh + assign a tvar + (env, tvars) <- rest + pure (Env.insert name a env, tvar : tvars)) (pure mempty) names + ret <- localEnv (mappend env) body + pure (Product tvars :-> ret) + + unit = pure Unit + integer _ = pure Int + boolean _ = pure Bool + string _ = pure String + float _ = pure Float + symbol _ = pure Symbol + rational _ = pure Rational + multiple = pure . Product + array = pure . Array + + klass _ _ _ = pure Object + + objectEnvironment _ = pure mempty + + asString _ = fail "Must evaluate to Value to use asString" + + ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') + + liftNumeric _ Float = pure Float + liftNumeric _ Int = pure Int + liftNumeric _ _ = fail "Invalid type in unary numeric operation" + + liftNumeric2 _ left right = case (left, right) of + (Float, Int) -> pure Float + (Int, Float) -> pure Float + _ -> unify left right + + liftBitwise _ Int = pure Int + liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t) + + liftBitwise2 _ Int Int = pure Int + liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)) + + liftComparison (Concrete _) left right = case (left, right) of + (Float, Int) -> pure Bool + (Int, Float) -> pure Bool + _ -> unify left right $> Bool + liftComparison Generalized left right = case (left, right) of + (Float, Int) -> pure Int + (Int, Float) -> pure Int + _ -> unify left right $> Bool + + apply op params = do + tvar <- fresh + paramTypes <- sequenceA params + _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar) + pure ret + + loop f = f empty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 14751967d..527104779 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,18 +1,16 @@ -{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Abstract.Value where +import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env -import Data.Abstract.Exports import Data.Abstract.FreeVariables -import Data.Abstract.Heap -import Data.Abstract.Live -import Data.Abstract.Number -import qualified Data.Abstract.Type as Type +import qualified Data.Abstract.Number as Number import Data.Scientific (Scientific) +import qualified Data.Set as Set import Prologue -import Prelude hiding (Float, Integer, String, Rational) +import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude type ValueConstructors @@ -75,7 +73,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -- | Arbitrary-width integral values. -newtype Integer value = Integer (Number Prelude.Integer) +newtype Integer value = Integer (Number.Number Prelude.Integer) deriving (Eq, Generic1, Ord, Show) instance Eq1 Integer where liftEq = genericLiftEq @@ -83,7 +81,7 @@ instance Ord1 Integer where liftCompare = genericLiftCompare instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec -- | Arbitrary-width rational values values. -newtype Rational value = Rational (Number Prelude.Rational) +newtype Rational value = Rational (Number.Number Prelude.Rational) deriving (Eq, Generic1, Ord, Show) instance Eq1 Rational where liftEq = genericLiftEq @@ -108,7 +106,7 @@ instance Ord1 Symbol where liftCompare = genericLiftCompare instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec -- | Float values. -newtype Float value = Float (Number Scientific) +newtype Float value = Float (Number.Number Scientific) deriving (Eq, Generic1, Ord, Show) instance Eq1 Float where liftEq = genericLiftEq @@ -145,35 +143,124 @@ instance Eq1 Class where liftEq = genericLiftEq instance Ord1 Class where liftCompare = genericLiftCompare instance Show1 Class where liftShowsPrec = genericLiftShowsPrec --- | The environment for an abstract value type. -type EnvironmentFor v = Environment (LocationFor v) v --- | The exports for an abstract value type. -type ExportsFor v = Exports (LocationFor v) v - --- | The 'Heap' for an abstract value type. -type HeapFor value = Heap (LocationFor value) value - --- | The cell for an abstract value type. -type CellFor value = Cell (LocationFor value) value - --- | The address set type for an abstract value type. -type LiveFor value = Live (LocationFor value) value - --- | The location type (the body of 'Address'es) which should be used for an abstract value type. -type family LocationFor value :: * type instance LocationFor Value = Precise -type instance LocationFor Type.Type = Monovariant - --- | Value types, e.g. closures, which can root a set of addresses. -class ValueRoots value where - -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> LiveFor value instance ValueRoots Value where valueRoots v | Just (Closure _ _ env) <- prjValue v = Env.addresses env | otherwise = mempty -instance ValueRoots Type.Type where - valueRoots _ = mempty + +-- | Construct a 'Value' wrapping the value arguments (if any). +instance ( Evaluatable (Base term) + , FreeVariables term + , Monad m + , MonadAddressable Precise Value m + , MonadEvaluateModule term Value m + , MonadValue Value m + , MonadThrow Prelude.String Value m + ) + => MonadValue Value m where + + unit = pure . injValue $ Unit + integer = pure . injValue . Data.Abstract.Value.Integer . Number.Integer + boolean = pure . injValue . Boolean + string = pure . injValue . String + float = pure . injValue . Float . Number.Decimal + symbol = pure . injValue . Symbol + rational = pure . injValue . Rational . Number.Ratio + + multiple = pure . injValue . Tuple + array = pure . injValue . Array + + klass n [] env = pure . injValue $ Class n env + klass n supers env = do + product <- mconcat <$> traverse objectEnvironment supers + pure . injValue $ Class n (Env.push product <> env) + + + objectEnvironment o + | Just (Class _ env) <- prjValue o = pure env + | otherwise = fail ("non-object type passed to objectEnvironment: " <> show o) + + asString v + | Just (String n) <- prjValue v = pure n + | otherwise = fail ("expected " <> show v <> " to be a string") + + ifthenelse cond if' else' + | 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 (Number.Integer i)) <- prjValue arg = integer $ f i + | Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d + | Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r + | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) + + liftNumeric2 f left right + | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize + | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize + | Just (Integer i, Float j) <- prjPair pair = f i j & specialize + | Just (Rational i, Integer j) <- prjPair pair = f i j & specialize + | Just (Rational i, Rational j) <- prjPair pair = f i j & specialize + | Just (Rational i, Float j) <- prjPair pair = f i j & specialize + | Just (Float i, Integer j) <- prjPair pair = f i j & specialize + | Just (Float i, Rational j) <- prjPair pair = f i j & specialize + | Just (Float i, Float j) <- prjPair pair = f i j & specialize + | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) + where + -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor + specialize :: MonadValue value m => Number.SomeNumber -> m value + specialize (Number.SomeNumber (Number.Integer i)) = integer i + specialize (Number.SomeNumber (Number.Ratio r)) = rational r + specialize (Number.SomeNumber (Number.Decimal d)) = float d + pair = (left, right) + + liftComparison comparator left right + | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j + | Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j + | Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) + | Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j + | Just (String i, String j) <- prjPair pair = go i j + | Just (Boolean i, Boolean j) <- prjPair pair = go i j + | Just (Unit, Unit) <- prjPair pair = boolean True + | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair) + where + -- Explicit type signature is necessary here because we're passing all sorts of things + -- to these comparison functions. + go :: (Ord a, MonadValue value m) => a -> a -> m value + go l r = case comparator of + Concrete f -> boolean (f l r) + Generalized -> integer (orderingToInt (compare l r)) + + -- Map from [LT, EQ, GT] to [-1, 0, 1] + orderingToInt :: Ordering -> Prelude.Integer + orderingToInt = toInteger . pred . fromEnum + + pair = (left, right) + + + liftBitwise operator target + | Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i + | otherwise = fail ("Type error: invalid unary bitwise operation on " <> show target) + + liftBitwise2 operator left right + | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j + | otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair) + where pair = (left, right) + + abstract names (Subterm body _) = do + l <- label body + injValue . Closure names l . Env.bind (foldr Set.delete (freeVariables body) names) <$> getEnv + + apply op params = do + Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Env.insert name a <$> rest) (pure env) (zip names params) + localEnv (mappend bindings) (goto label >>= evaluateTerm) + + loop = fix diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 7f37d8936..af2e95a3a 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -2,11 +2,9 @@ module Language.Ruby.Syntax where import Control.Monad (unless) -import Control.Abstract.Value (MonadValue) import Data.Abstract.Evaluatable import Data.Abstract.ModuleTable import Data.Abstract.Path -import Data.Abstract.Value (EnvironmentFor) import Diffing.Algorithm import Prelude hiding (fail) import Prologue