mirror of
https://github.com/github/semantic.git
synced 2024-12-22 06:11:49 +03:00
Move the MonadValue instances into the Value/Type modules.
This commit is contained in:
Rob Rix
parent
d99877d397
commit
fb727c05cf
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 :: *
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user