From 13fae0af42b94f1458800646eaa3f4280ede1701 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 14:10:35 +1000 Subject: [PATCH 01/16] add new EvalContext type replacing Environment in evaluation --- src/Analysis/Abstract/Caching.hs | 4 +- src/Control/Abstract/Environment.hs | 65 +++++++++++++++++------------ src/Control/Abstract/Heap.hs | 2 +- src/Data/Abstract/Configuration.hs | 8 ++-- src/Data/Abstract/Environment.hs | 4 ++ 5 files changed, 49 insertions(+), 34 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index a9ded9d3f..bb2131aa1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -93,8 +93,8 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ do - TermEvaluator (putHeap (configurationHeap c)) - TermEvaluator (putEnv (configurationEnvironment c)) + TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putCtx (configurationContext c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a3a8d47fd..3c6acf13b 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -2,8 +2,9 @@ module Control.Abstract.Environment ( Environment , Exports +, getCtx +, putCtx , getEnv -, putEnv , withEnv , export , lookupEnv @@ -21,31 +22,41 @@ module Control.Abstract.Environment ) where import Control.Abstract.Evaluator -import Data.Abstract.Environment (Bindings, Environment) +import Data.Abstract.Environment (Bindings, Environment, EvalContext(..)) import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports as Exports import Data.Abstract.Name import Prologue --- | Retrieve the environment. -getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) -getEnv = send GetEnv +-- | Retrieve the current execution context +getCtx :: Member (Env address) effects => Evaluator address value effects (EvalContext address) +getCtx = send GetCtx --- | Replace the environment. This is only for use in Analysis.Abstract.Caching. -putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () -putEnv = send . PutEnv +-- | Retrieve the current environment +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) +getEnv = ctxEnvironment <$> getCtx + +-- | Replace the execution context. This is only for use in Analysis.Abstract.Caching. +putCtx :: Member (Env address) effects => EvalContext address -> Evaluator address value effects () +putCtx = send . PutCtx + +withCtx :: Member (Env address) effects + => EvalContext address + -> Evaluator address value effects a + -> Evaluator address value effects a +withCtx ctx comp = do + oldCtx <- getCtx + putCtx ctx + value <- comp + putCtx oldCtx + pure value -- | Replace the environment for a computation withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv env comp = do - oldEnv <- getEnv - putEnv env - value <- comp - putEnv oldEnv - pure value +withEnv env = withCtx (EvalContext env) -- | Add an export to the global export state. export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () @@ -79,8 +90,8 @@ data Env address m return where Bind :: Name -> address -> Env address m () Close :: Set Name -> Env address m (Environment address) Locally :: m a -> Env address m a - GetEnv :: Env address m (Environment address) - PutEnv :: Environment address -> Env address m () + GetCtx :: Env address m (EvalContext address) + PutCtx :: EvalContext address -> Env address m () Export :: Name -> Name -> Maybe address -> Env address m () instance PureEffect (Env address) @@ -89,8 +100,8 @@ instance Effect (Env address) where handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k) handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k) handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k) - handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k) - handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k) + handleState c dist (Request GetCtx k) = Request GetCtx (dist . (<$ c) . k) + handleState c dist (Request (PutCtx e) k) = Request (PutCtx e) (dist . (<$ c) . k) handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k) -- | Runs a computation in the context of an existing environment. @@ -99,7 +110,7 @@ runEnv :: Effects effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (Bindings address, a) -runEnv initial = fmap (filterEnv . fmap (first Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv +runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState (EvalContext (Env.push initial)) . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. @@ -107,17 +118,17 @@ runEnv initial = fmap (filterEnv . fmap (first Env.head)) . runState lowerBound | Exports.null ports = (binds, a) | otherwise = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a) -handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a +handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a handleEnv = \case - Lookup name -> Env.lookupEnv' name <$> get - Bind name addr -> modify (Env.insertEnv name addr) - Close names -> Env.intersect names <$> get + Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get + Bind name addr -> modify (EvalContext . Env.insertEnv name addr . ctxEnvironment) + Close names -> Env.intersect names . ctxEnvironment <$> get Locally action -> do - modify' (Env.push @address) + modify' (EvalContext . Env.push @address . ctxEnvironment) a <- reinterpret2 handleEnv (raiseEff action) - a <$ modify' (Env.pop @address) - GetEnv -> get - PutEnv e -> put e + a <$ modify' (EvalContext . Env.pop @address . ctxEnvironment) + GetCtx -> get + PutCtx e -> put e Export name alias addr -> modify (Exports.insert name alias addr) -- | Errors involving the environment. diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 46c9cb9c1..f835dc2dd 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -40,7 +40,7 @@ import Prologue -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) -getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getCtx <*> TermEvaluator getHeap -- | Retrieve the heap. diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 7c5ca44ee..3721515ab 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -6,9 +6,9 @@ import Data.Abstract.Live -- | A single point in a program’s execution. data Configuration term address cell value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - , configurationEnvironment :: Environment address -- ^ The environment binding any free variables in 'configurationTerm'. - , configurationHeap :: Heap address cell value -- ^ The heap of values. + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address cell value -- ^ The heap of values. } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 7a3db4de8..48c7c28cc 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -1,6 +1,7 @@ module Data.Abstract.Environment ( Environment(..) , Bindings(..) + , EvalContext(..) , addresses , aliasBindings , allNames @@ -54,6 +55,9 @@ instance Lower (Bindings address) where newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings address) } deriving (Eq, Ord) +data EvalContext address = EvalContext { ctxEnvironment :: Environment address } + deriving (Eq, Ord, Show) + -- | Make and enter a new empty scope in the given environment. push :: Environment address -> Environment address push (Environment (a :| as)) = Environment (mempty :| a : as) From be665228379598ece80c10eebd2f7149f2f4680e Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 14:18:37 +1000 Subject: [PATCH 02/16] remove withEnv in favour of withCtx --- src/Control/Abstract/Environment.hs | 9 +-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 6 +++--- 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3c6acf13b..88c116157 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -4,8 +4,8 @@ module Control.Abstract.Environment , Exports , getCtx , putCtx +, withCtx , getEnv -, withEnv , export , lookupEnv , bind @@ -51,13 +51,6 @@ withCtx ctx comp = do putCtx oldCtx pure value --- | Replace the environment for a computation -withEnv :: Member (Env address) effects - => Environment address - -> Evaluator address value effects a - -> Evaluator address value effects a -withEnv env = withCtx (EvalContext env) - -- | Add an export to the global export state. export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () export name alias addr = send (Export name alias addr) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index eb8a6646b..0447a1a5e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -212,7 +212,7 @@ evaluateInScopedEnv :: ( AbstractValue address value effects evaluateInScopedEnv scopedEnvTerm term = do scopedEnv <- scopedEnvironment scopedEnvTerm env <- maybeM getEnv scopedEnv - withEnv env term + withCtx (EvalContext env) term -- | Evaluates a 'Value' returning the referenced value diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index be9a76cc4..8a23b267e 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -10,7 +10,7 @@ module Data.Abstract.Value.Concrete ) where import Control.Abstract -import Data.Abstract.Environment (Environment, Bindings) +import Data.Abstract.Environment (Environment, Bindings, EvalContext(..)) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import qualified Data.Abstract.Number as Number @@ -87,8 +87,8 @@ instance ( Coercible body (Eff effects) bindings <- foldr (\ (name, param) rest -> do addr <- param Env.insert name addr <$> rest) (pure lowerBound) (zip names params) - let fnEnv = Env.push env - withEnv fnEnv (catchReturn (bindAll bindings *> raiseEff (coerce body))) + let fnCtx = EvalContext (Env.push env) + withCtx fnCtx (catchReturn (bindAll bindings *> raiseEff (coerce body))) _ -> box =<< throwValueError (CallError op) From 11ee6977ccb1a0e7181f6b3937b6c158ccc38b47 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 14:21:47 +1000 Subject: [PATCH 03/16] add ctxSelf field as unit to EvalContext --- src/Control/Abstract/Environment.hs | 8 ++++---- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Environment.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 88c116157..670e14ac9 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -103,7 +103,7 @@ runEnv :: Effects effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (Bindings address, a) -runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState (EvalContext (Env.push initial)) . reinterpret2 handleEnv +runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState (EvalContext () (Env.push initial)) . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. @@ -114,12 +114,12 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a handleEnv = \case Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get - Bind name addr -> modify (EvalContext . Env.insertEnv name addr . ctxEnvironment) + Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) Close names -> Env.intersect names . ctxEnvironment <$> get Locally action -> do - modify' (EvalContext . Env.push @address . ctxEnvironment) + modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment)) a <- reinterpret2 handleEnv (raiseEff action) - a <$ modify' (EvalContext . Env.pop @address . ctxEnvironment) + a <$ modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment)) GetCtx -> get PutCtx e -> put e Export name alias addr -> modify (Exports.insert name alias addr) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0447a1a5e..adcb78ba4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -212,7 +212,7 @@ evaluateInScopedEnv :: ( AbstractValue address value effects evaluateInScopedEnv scopedEnvTerm term = do scopedEnv <- scopedEnvironment scopedEnvTerm env <- maybeM getEnv scopedEnv - withCtx (EvalContext env) term + withCtx (EvalContext () env) term -- | Evaluates a 'Value' returning the referenced value diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 48c7c28cc..560a3bf4c 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -55,7 +55,7 @@ instance Lower (Bindings address) where newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings address) } deriving (Eq, Ord) -data EvalContext address = EvalContext { ctxEnvironment :: Environment address } +data EvalContext address = EvalContext { ctxSelf :: (), ctxEnvironment :: Environment address } deriving (Eq, Ord, Show) -- | Make and enter a new empty scope in the given environment. diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 8a23b267e..639fb26b5 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -87,7 +87,7 @@ instance ( Coercible body (Eff effects) bindings <- foldr (\ (name, param) rest -> do addr <- param Env.insert name addr <$> rest) (pure lowerBound) (zip names params) - let fnCtx = EvalContext (Env.push env) + let fnCtx = EvalContext () (Env.push env) withCtx fnCtx (catchReturn (bindAll bindings *> raiseEff (coerce body))) _ -> box =<< throwValueError (CallError op) From c1b075d56eb5130555179332d4bc8d58b2965dbf Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 15:09:22 +1000 Subject: [PATCH 04/16] implement self in EvalContext and call --- src/Control/Abstract/Environment.hs | 7 +++++-- src/Control/Abstract/Value.hs | 8 ++++---- src/Data/Abstract/Environment.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Value/Abstract.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 4 ++-- src/Data/Abstract/Value/Type.hs | 2 +- src/Data/Syntax/Expression.hs | 3 ++- src/Language/Ruby/Syntax.hs | 5 +++-- 9 files changed, 20 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 670e14ac9..f9a783d5c 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -12,6 +12,7 @@ module Control.Abstract.Environment , bindAll , locally , close +, self -- * Effects , Env(..) , runEnv @@ -75,6 +76,8 @@ locally = send . Locally @_ @_ @address . lowerEff close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close +self :: Member (Env address) effects => Evaluator address value effects (Maybe address) +self = ctxSelf <$> getCtx -- Effects @@ -100,10 +103,10 @@ instance Effect (Env address) where -- | Runs a computation in the context of an existing environment. -- New bindings created in the computation are returned. runEnv :: Effects effects - => Environment address + => EvalContext address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (Bindings address, a) -runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState (EvalContext () (Env.push initial)) . reinterpret2 handleEnv +runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index adcb78ba4..4b97f8da9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -44,7 +44,7 @@ class Show value => AbstractFunction address value effects where -> Evaluator address value effects address -- ^ The evaluator for the body of the closure. -> Evaluator address value effects value -- | Evaluate an application (like a function call). - call :: value -> [Evaluator address value effects address] -> Evaluator address value effects address + call :: value -> address -> [Evaluator address value effects address] -> Evaluator address value effects address class Show value => AbstractIntro value where @@ -209,10 +209,10 @@ evaluateInScopedEnv :: ( AbstractValue address value effects => address -> Evaluator address value effects a -> Evaluator address value effects a -evaluateInScopedEnv scopedEnvTerm term = do - scopedEnv <- scopedEnvironment scopedEnvTerm +evaluateInScopedEnv receiver term = do + scopedEnv <- scopedEnvironment receiver env <- maybeM getEnv scopedEnv - withCtx (EvalContext () env) term + withCtx (EvalContext (Just receiver) env) term -- | Evaluates a 'Value' returning the referenced value diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 560a3bf4c..4cc65629b 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -55,7 +55,7 @@ instance Lower (Bindings address) where newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings address) } deriving (Eq, Ord) -data EvalContext address = EvalContext { ctxSelf :: (), ctxEnvironment :: Environment address } +data EvalContext address = EvalContext { ctxSelf :: Maybe address, ctxEnvironment :: Environment address } deriving (Eq, Ord, Show) -- | Make and enter a new empty scope in the given environment. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2ef254b16..a4c510ba4 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -124,7 +124,7 @@ evaluate lang analyzeModule analyzeTerm modules = do = runReader info . runAllocator . runDeref - . runEnv (newEnv preludeBinds) + . runEnv (EvalContext Nothing (newEnv preludeBinds)) . runReturn . runLoopControl diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index e8b9533e6..74138cfb6 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -42,7 +42,7 @@ instance ( Member (Allocator address Abstract) effects addr <- locally (bindAll binds *> catchReturn body) deref addr - call Abstract params = do + call Abstract _ params = do traverse_ (>>= deref) params box Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 639fb26b5..4e2caa50f 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -78,7 +78,7 @@ instance ( Coercible body (Eff effects) i <- fresh Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) <$> close (foldr Set.delete freeVariables parameters) - call op params = do + call op self params = do case op of Closure packageInfo moduleInfo names (ClosureBody _ body) env -> do -- Evaluate the bindings and body with the closure’s package/module info in scope in order to @@ -87,7 +87,7 @@ instance ( Coercible body (Eff effects) bindings <- foldr (\ (name, param) rest -> do addr <- param Env.insert name addr <$> rest) (pure lowerBound) (zip names params) - let fnCtx = EvalContext () (Env.push env) + let fnCtx = EvalContext (Just self) (Env.push env) withCtx fnCtx (catchReturn (bindAll bindings *> raiseEff (coerce body))) _ -> box =<< throwValueError (CallError op) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 1fd617408..7b268133c 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -249,7 +249,7 @@ instance ( Member (Allocator address Type) effects bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) names (zeroOrMoreProduct tvars :->) <$> (deref =<< locally (catchReturn (bindAll binds *> body))) - call op params = do + call op _ params = do tvar <- fresh paramTypes <- traverse (>>= deref) params let needed = zeroOrMoreProduct paramTypes :-> Var tvar diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 0a6053c93..39865a048 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -21,7 +21,8 @@ instance Show1 Call where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Call where eval Call{..} = do op <- subtermValue callFunction - Rval <$> call op (map subtermAddress callParams) + recv <- box unit -- TODO + Rval <$> call op recv (map subtermAddress callParams) data LessThan a = LessThan { lhs :: a, rhs :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 8b35a1888..377770e2f 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -55,8 +55,9 @@ instance Evaluatable Send where let sel = case sendSelector of Just sel -> subtermAddress sel Nothing -> variable (name "call") - func <- deref =<< maybe sel (flip evaluateInScopedEnv sel <=< subtermAddress) sendReceiver - Rval <$> call func (map subtermAddress sendArgs) -- TODO pass through sendBlock + recv <- maybe (self >>= maybeM (box unit)) subtermAddress sendReceiver + func <- deref =<< evaluateInScopedEnv recv sel + Rval <$> call func recv (map subtermAddress sendArgs) -- TODO pass through sendBlock data Require a = Require { requireRelative :: Bool, requirePath :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) From c7b33f5723c7009387721a57ddb2ee30b73959d6 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 15:15:05 +1000 Subject: [PATCH 05/16] assign self in ruby to Expression.This --- src/Language/Ruby/Assignment.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 0ada288ce..6037aed40 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -80,6 +80,7 @@ type Syntax = '[ , Expression.MemberAccess , Expression.ScopeResolution , Expression.Subscript + , Expression.This , Expression.Member , Literal.Array , Literal.Complex @@ -178,6 +179,7 @@ expressionChoices = , parseError , rescue , scopeResolution + , self , singletonClass , singletonMethod , subscript @@ -217,7 +219,6 @@ identifier = <|> mk ClassVariable <|> mk GlobalVariable <|> mk Operator - <|> mk Self <|> mk Super <|> mk Setter <|> mk SplatArgument @@ -237,6 +238,9 @@ identifier = then pure identTerm else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing) +self :: Assignment Term +self = makeTerm <$> symbol Self <*> pure Expression.This + -- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc). literal :: Assignment Term literal = From ec163d591041ca19b29549e11ed80e7729bc56fa Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 15:20:11 +1000 Subject: [PATCH 06/16] implement This evaluation --- src/Data/Syntax/Expression.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 39865a048..6dd2be07a 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -7,7 +7,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedF import Data.Fixed import Data.JSON.Fields import Diffing.Algorithm -import Prologue hiding (index, Member) +import Prologue hiding (index, Member, This) import Proto3.Suite.Class -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. @@ -501,4 +501,5 @@ data This a = This instance Eq1 This where liftEq = genericLiftEq instance Ord1 This where liftCompare = genericLiftCompare instance Show1 This where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable This +instance Evaluatable This where + eval This = Rval <$> (maybeM (box unit) =<< self) From 2fbbd239e3cafc1831c84e1b65cca76bad32c6d2 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 15:22:58 +1000 Subject: [PATCH 07/16] implement Lower for EvalContext --- src/Data/Abstract/Environment.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 4cc65629b..f9e7ce90d 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -58,6 +58,9 @@ newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings data EvalContext address = EvalContext { ctxSelf :: Maybe address, ctxEnvironment :: Environment address } deriving (Eq, Ord, Show) +instance Lower (EvalContext address) where + lowerBound = EvalContext Nothing lowerBound + -- | Make and enter a new empty scope in the given environment. push :: Environment address -> Environment address push (Environment (a :| as)) = Environment (mempty :| a : as) From b364c6637a6f2ab62b7efaf624c1a3ab82d52b1d Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 16:23:44 +1000 Subject: [PATCH 08/16] implement the right type classes for This --- src/Data/Syntax/Expression.hs | 2 +- test/Data/Functor/Listable.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 6dd2be07a..0122c7d29 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -496,7 +496,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Super data This a = This - deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1) instance Eq1 This where liftEq = genericLiftEq instance Ord1 This where liftCompare = genericLiftCompare diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 1cbef66fe..79b9b4c89 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -395,6 +395,9 @@ instance Listable1 Expression.Subscript where instance Listable1 Expression.Member where liftTiers tiers = liftCons2 tiers tiers Expression.Member +instance Listable1 Expression.This where + liftTiers tiers = cons0 Expression.This + instance Listable1 Literal.Complex where liftTiers tiers = cons1 Literal.Complex From ee227d809126c79ed211b0659298e817184110eb Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 24 Jul 2018 16:23:53 +1000 Subject: [PATCH 09/16] fix up call in test --- test/Control/Abstract/Evaluator/Spec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 1f476971c..7599dede1 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -24,7 +24,8 @@ spec = parallel $ do it "calls functions" $ do (_, expected) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) - call identity [box (integer 123)] + recv <- box unit + call identity recv [box (integer 123)] expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate From b5f6edb942cd8835bc4678fb8bfc1e88a67f6718 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 1 Aug 2018 15:01:12 +1000 Subject: [PATCH 10/16] fix self in ruby assignment --- src/Language/Ruby/Assignment.hs | 2 +- test/fixtures/ruby/corpus/literals.parseA.txt | 2 +- test/fixtures/ruby/corpus/methods.parseA.txt | 4 ++-- test/fixtures/ruby/corpus/pseudo-variables.parseA.txt | 2 +- test/fixtures/ruby/corpus/pseudo-variables.parseB.txt | 2 +- test/fixtures/ruby/corpus/singleton-class.parseA.txt | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 69900ffab..2120be3c2 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -242,7 +242,7 @@ identifier = else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing) self :: Assignment Term -self = makeTerm <$> symbol Self <*> pure Expression.This +self = makeTerm <$> symbol Self <*> (const Expression.This <$> source) -- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc). literal :: Assignment Term diff --git a/test/fixtures/ruby/corpus/literals.parseA.txt b/test/fixtures/ruby/corpus/literals.parseA.txt index 315f8e628..c7b28cb16 100644 --- a/test/fixtures/ruby/corpus/literals.parseA.txt +++ b/test/fixtures/ruby/corpus/literals.parseA.txt @@ -4,7 +4,7 @@ (Null) (SymbolElement) (Integer) - (Identifier) + (This) (Identifier) (Enumeration (Integer) diff --git a/test/fixtures/ruby/corpus/methods.parseA.txt b/test/fixtures/ruby/corpus/methods.parseA.txt index a5db758c8..886b1c1ca 100644 --- a/test/fixtures/ruby/corpus/methods.parseA.txt +++ b/test/fixtures/ruby/corpus/methods.parseA.txt @@ -31,11 +31,11 @@ (Identifier) (Statements)) (Method - (Identifier) + (This) (Identifier) (Statements)) (Method - (Identifier) + (This) (Identifier) (Identifier) (Identifier) diff --git a/test/fixtures/ruby/corpus/pseudo-variables.parseA.txt b/test/fixtures/ruby/corpus/pseudo-variables.parseA.txt index d2b965f23..9c12ea12a 100644 --- a/test/fixtures/ruby/corpus/pseudo-variables.parseA.txt +++ b/test/fixtures/ruby/corpus/pseudo-variables.parseA.txt @@ -1,5 +1,5 @@ (Statements (Null) - (Identifier) + (This) (Boolean) (Boolean)) diff --git a/test/fixtures/ruby/corpus/pseudo-variables.parseB.txt b/test/fixtures/ruby/corpus/pseudo-variables.parseB.txt index 829db3af5..53598286c 100644 --- a/test/fixtures/ruby/corpus/pseudo-variables.parseB.txt +++ b/test/fixtures/ruby/corpus/pseudo-variables.parseB.txt @@ -1,5 +1,5 @@ (Statements - (Identifier) + (This) (Null) (Boolean) (Boolean)) diff --git a/test/fixtures/ruby/corpus/singleton-class.parseA.txt b/test/fixtures/ruby/corpus/singleton-class.parseA.txt index 8a706957e..0c1ba3aa4 100644 --- a/test/fixtures/ruby/corpus/singleton-class.parseA.txt +++ b/test/fixtures/ruby/corpus/singleton-class.parseA.txt @@ -1,6 +1,6 @@ (Statements (Class - (Identifier) + (This) (Statements)) (Class (ScopeResolution From 72ba35dd1dcf4dc95760c87fc81e0c23c05edd3d Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 2 Aug 2018 14:15:50 +1000 Subject: [PATCH 11/16] regenerate diff fixtures --- src/Language/Ruby/Assignment.hs | 2 +- .../ruby/corpus/delimiter.diffA-B.txt | 12 +++--- .../ruby/corpus/delimiter.diffB-A.txt | 10 ++--- test/fixtures/ruby/corpus/for.diffB-A.txt | 37 +++++++++--------- test/fixtures/ruby/corpus/hash.diffA-B.txt | 11 +++--- test/fixtures/ruby/corpus/hash.diffB-A.txt | 10 ++--- .../corpus/multiple-assignments.diffA-B.txt | 27 +++++-------- .../corpus/multiple-assignments.diffB-A.txt | 39 +++++++++---------- test/fixtures/ruby/corpus/number.diffB-A.txt | 2 +- test/fixtures/ruby/corpus/symbol.diffA-B.txt | 8 ++-- test/fixtures/ruby/corpus/symbol.diffB-A.txt | 8 ++-- 11 files changed, 77 insertions(+), 89 deletions(-) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 2120be3c2..44b4e650b 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -80,8 +80,8 @@ type Syntax = '[ , Expression.MemberAccess , Expression.ScopeResolution , Expression.Subscript - , Expression.This , Expression.Member + , Expression.This , Literal.Array , Literal.Character , Literal.Complex diff --git a/test/fixtures/ruby/corpus/delimiter.diffA-B.txt b/test/fixtures/ruby/corpus/delimiter.diffA-B.txt index 1722836c4..0de8a4071 100644 --- a/test/fixtures/ruby/corpus/delimiter.diffA-B.txt +++ b/test/fixtures/ruby/corpus/delimiter.diffA-B.txt @@ -1,13 +1,13 @@ (Statements -{+(TextElement)+} -{+(TextElement)+} -{+(TextElement)+} { (TextElement) ->(TextElement) } {+(TextElement)+} +{ (TextElement) +->(TextElement) } +{ (TextElement) +->(TextElement) } {+(TextElement)+} -{-(TextElement)-} -{-(TextElement)-} -{-(TextElement)-} +{ (TextElement) +->(TextElement) } {-(TextElement)-} {-(TextElement)-}) diff --git a/test/fixtures/ruby/corpus/delimiter.diffB-A.txt b/test/fixtures/ruby/corpus/delimiter.diffB-A.txt index b29b1ec5a..b7ab7f322 100644 --- a/test/fixtures/ruby/corpus/delimiter.diffB-A.txt +++ b/test/fixtures/ruby/corpus/delimiter.diffB-A.txt @@ -1,11 +1,11 @@ (Statements -{+(TextElement)+} -{+(TextElement)+} -{+(TextElement)+} -{+(TextElement)+} -{+(TextElement)+} { (TextElement) ->(TextElement) } +{+(TextElement)+} +{+(TextElement)+} +{+(TextElement)+} +{+(TextElement)+} +{+(TextElement)+} {-(TextElement)-} {-(TextElement)-} {-(TextElement)-} diff --git a/test/fixtures/ruby/corpus/for.diffB-A.txt b/test/fixtures/ruby/corpus/for.diffB-A.txt index b3c1137f3..145df1768 100644 --- a/test/fixtures/ruby/corpus/for.diffB-A.txt +++ b/test/fixtures/ruby/corpus/for.diffB-A.txt @@ -7,34 +7,33 @@ {+(Identifier)+})+} {+(Send {+(Identifier)+})+})+} -{+(ForEach - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} (ForEach (Statements (Send { (Identifier) - ->(Identifier) })) + ->(Identifier) }) + {+(Send + {+(Identifier)+})+}) { (Array {-(Integer)-} {-(Integer)-} {-(Integer)-}) - ->(Enumeration - {+(Integer)+} - {+(Integer)+} - {+(Empty)+}) } - { (Send - {-(Identifier)-} + ->(Send + {+(Identifier)+}) } + (Send + { (Identifier) + ->(Identifier) } {-(Send - {-(Identifier)-})-}) - ->(Boolean) }) + {-(Identifier)-})-})) +{+(ForEach + {+(Statements + {+(Send + {+(Identifier)+})+})+} + {+(Enumeration + {+(Integer)+} + {+(Integer)+} + {+(Empty)+})+} + {+(Boolean)+})+} {+(ForEach {+(Statements {+(Send diff --git a/test/fixtures/ruby/corpus/hash.diffA-B.txt b/test/fixtures/ruby/corpus/hash.diffA-B.txt index dc50b70b8..00b56d1cc 100644 --- a/test/fixtures/ruby/corpus/hash.diffA-B.txt +++ b/test/fixtures/ruby/corpus/hash.diffA-B.txt @@ -5,15 +5,14 @@ ->(SymbolElement) } { (TextElement) ->(TextElement) }) - {+(KeyValue - {+(SymbolElement)+} - {+(Integer)+})+} + (KeyValue + { (SymbolElement) + ->(SymbolElement) } + { (Integer) + ->(Integer) }) {+(KeyValue {+(SymbolElement)+} {+(Boolean)+})+} - {-(KeyValue - {-(SymbolElement)-} - {-(Integer)-})-} {-(KeyValue {-(TextElement)-} {-(Boolean)-})-} diff --git a/test/fixtures/ruby/corpus/hash.diffB-A.txt b/test/fixtures/ruby/corpus/hash.diffB-A.txt index bd241d551..4df9d3665 100644 --- a/test/fixtures/ruby/corpus/hash.diffB-A.txt +++ b/test/fixtures/ruby/corpus/hash.diffB-A.txt @@ -5,14 +5,14 @@ ->(SymbolElement) } { (TextElement) ->(TextElement) }) - {+(KeyValue - {+(SymbolElement)+} - {+(Integer)+})+} (KeyValue { (SymbolElement) - ->(TextElement) } + ->(SymbolElement) } { (Integer) - ->(Boolean) }) + ->(Integer) }) + {+(KeyValue + {+(TextElement)+} + {+(Boolean)+})+} (KeyValue { (SymbolElement) ->(SymbolElement) } diff --git a/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt b/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt index a5b22cca0..169eb3dbc 100644 --- a/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt +++ b/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt @@ -1,21 +1,14 @@ (Statements -{+(Assignment - {+(Statements - {+(Identifier)+} - {+(Identifier)+})+} - {+(Array - {+(Integer)+} - {+(Integer)+} - {+(Integer)+})+})+} -{-(Assignment - {-(Statements - {-(Identifier)-} - {-(Identifier)-} - {-(Identifier)-})-} - {-(Array - {-(Integer)-} - {-(Integer)-} - {-(Integer)-})-})-} + (Assignment + (Statements + (Identifier) + { (Identifier) + ->(Identifier) } + {-(Identifier)-}) + (Array + (Integer) + (Integer) + (Integer))) {-(Assignment {-(Statements {-(Identifier)-} diff --git a/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt b/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt index 801d51f46..56b3b9ceb 100644 --- a/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt +++ b/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt @@ -1,31 +1,28 @@ (Statements -{+(Assignment - {+(Statements - {+(Identifier)+} - {+(Identifier)+} - {+(Identifier)+})+} - {+(Array - {+(Integer)+} - {+(Integer)+} - {+(Integer)+})+})+} -{+(Assignment - {+(Statements - {+(Identifier)+} - {+(Identifier)+})+} - {+(Array - {+(Integer)+} - {+(Integer)+})+})+} (Assignment (Statements (Identifier) { (Identifier) - ->(Identifier) }) + ->(Identifier) } + {+(Identifier)+}) (Array - { (Integer) - ->(Integer) } + (Integer) + (Integer) + (Integer))) +{+(Assignment + {+(Statements + {+(Identifier)+} + {+(Identifier)+})+} + {+(Array {+(Integer)+} - {-(Integer)-} - {-(Integer)-})) + {+(Integer)+})+})+} +{+(Assignment + {+(Statements + {+(Identifier)+} + {+(Identifier)+})+} + {+(Array + {+(Integer)+} + {+(Integer)+})+})+} {+(Assignment {+(Statements {+(Identifier)+} diff --git a/test/fixtures/ruby/corpus/number.diffB-A.txt b/test/fixtures/ruby/corpus/number.diffB-A.txt index 84113b626..ac0ba3351 100644 --- a/test/fixtures/ruby/corpus/number.diffB-A.txt +++ b/test/fixtures/ruby/corpus/number.diffB-A.txt @@ -1,11 +1,11 @@ (Statements {+(Integer)+} {+(Integer)+} -{+(Integer)+} { (Integer) ->(Integer) } {+(Integer)+} {+(Integer)+} +{+(Integer)+} {+(Float)+} {-(Integer)-} {-(Integer)-} diff --git a/test/fixtures/ruby/corpus/symbol.diffA-B.txt b/test/fixtures/ruby/corpus/symbol.diffA-B.txt index 0e9af52c4..3177e74ea 100644 --- a/test/fixtures/ruby/corpus/symbol.diffA-B.txt +++ b/test/fixtures/ruby/corpus/symbol.diffA-B.txt @@ -1,7 +1,7 @@ (Statements { (SymbolElement) ->(SymbolElement) } -{ (SymbolElement) -->(SymbolElement) } -{ (SymbolElement) -->(SymbolElement) }) +{+(SymbolElement)+} +{+(SymbolElement)+} +{-(SymbolElement)-} +{-(SymbolElement)-}) diff --git a/test/fixtures/ruby/corpus/symbol.diffB-A.txt b/test/fixtures/ruby/corpus/symbol.diffB-A.txt index 0e9af52c4..3177e74ea 100644 --- a/test/fixtures/ruby/corpus/symbol.diffB-A.txt +++ b/test/fixtures/ruby/corpus/symbol.diffB-A.txt @@ -1,7 +1,7 @@ (Statements { (SymbolElement) ->(SymbolElement) } -{ (SymbolElement) -->(SymbolElement) } -{ (SymbolElement) -->(SymbolElement) }) +{+(SymbolElement)+} +{+(SymbolElement)+} +{-(SymbolElement)-} +{-(SymbolElement)-}) From 7cc858acf06909121ff6a7b23f6e7b50ccb34552 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 2 Aug 2018 14:21:40 +1000 Subject: [PATCH 12/16] Identifier -> This in test fixtures --- test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt | 4 ++-- test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt | 4 ++-- test/fixtures/ruby/corpus/multiple-assignments.parseA.txt | 4 ++-- test/fixtures/ruby/corpus/pseudo-variables.diffA-B.txt | 2 +- test/fixtures/ruby/corpus/pseudo-variables.diffB-A.txt | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt b/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt index 169eb3dbc..7c12ce139 100644 --- a/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt +++ b/test/fixtures/ruby/corpus/multiple-assignments.diffA-B.txt @@ -38,10 +38,10 @@ {-(Assignment {-(Statements {-(Send - {-(Identifier)-} + {-(This)-} {-(Identifier)-})-} {-(Send - {-(Identifier)-} + {-(This)-} {-(Identifier)-})-})-} {-(Statements {-(Send diff --git a/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt b/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt index 56b3b9ceb..81cf76179 100644 --- a/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt +++ b/test/fixtures/ruby/corpus/multiple-assignments.diffB-A.txt @@ -38,10 +38,10 @@ {+(Assignment {+(Statements {+(Send - {+(Identifier)+} + {+(This)+} {+(Identifier)+})+} {+(Send - {+(Identifier)+} + {+(This)+} {+(Identifier)+})+})+} {+(Statements {+(Send diff --git a/test/fixtures/ruby/corpus/multiple-assignments.parseA.txt b/test/fixtures/ruby/corpus/multiple-assignments.parseA.txt index 5fb6f2e6d..9e5c76e94 100644 --- a/test/fixtures/ruby/corpus/multiple-assignments.parseA.txt +++ b/test/fixtures/ruby/corpus/multiple-assignments.parseA.txt @@ -37,10 +37,10 @@ (Assignment (Statements (Send - (Identifier) + (This) (Identifier)) (Send - (Identifier) + (This) (Identifier))) (Statements (Send diff --git a/test/fixtures/ruby/corpus/pseudo-variables.diffA-B.txt b/test/fixtures/ruby/corpus/pseudo-variables.diffA-B.txt index 1d600d137..efc2780ac 100644 --- a/test/fixtures/ruby/corpus/pseudo-variables.diffA-B.txt +++ b/test/fixtures/ruby/corpus/pseudo-variables.diffA-B.txt @@ -1,6 +1,6 @@ (Statements {-(Null)-} - (Identifier) + (This) {+(Null)+} {-(Boolean)-} (Boolean) diff --git a/test/fixtures/ruby/corpus/pseudo-variables.diffB-A.txt b/test/fixtures/ruby/corpus/pseudo-variables.diffB-A.txt index af9ea6f01..1d877d77b 100644 --- a/test/fixtures/ruby/corpus/pseudo-variables.diffB-A.txt +++ b/test/fixtures/ruby/corpus/pseudo-variables.diffB-A.txt @@ -1,7 +1,7 @@ (Statements -{-(Identifier)-} +{-(This)-} (Null) -{+(Identifier)+} +{+(This)+} {-(Boolean)-} (Boolean) {+(Boolean)+}) From 4e98573a28d4c5f92d7099ceea1e9896f64d0d57 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 2 Aug 2018 15:03:46 +1000 Subject: [PATCH 13/16] ensure modules are evaluated in empty bindings context --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index cb50d5162..e97c0ba31 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -127,7 +127,7 @@ evaluate lang analyzeModule analyzeTerm runValue modules = do = runReader info . runAllocator . runDeref - . runEnv (EvalContext Nothing (newEnv preludeBinds)) + . runEnv (EvalContext Nothing (X.push (newEnv preludeBinds))) . runReturn . runLoopControl From 9129494ac2da60ed7303edd8d6627b22eab36bc8 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 2 Aug 2018 15:30:36 +1000 Subject: [PATCH 14/16] use <$ rather than const <$> --- src/Language/Ruby/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 44b4e650b..d1e3b381c 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -242,7 +242,7 @@ identifier = else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing) self :: Assignment Term -self = makeTerm <$> symbol Self <*> (const Expression.This <$> source) +self = makeTerm <$> symbol Self <*> (Expression.This <$ source) -- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc). literal :: Assignment Term From 6c7df4e5bccb20f3d3e468dbbbfdec62921cfff0 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 2 Aug 2018 16:00:21 +1000 Subject: [PATCH 15/16] remove TypeScript specific This syntax type --- src/Language/TypeScript/Assignment.hs | 4 +- src/Language/TypeScript/Syntax/JavaScript.hs | 8 --- .../typescript/corpus/import.diffB-A.txt | 6 +- .../public-field-definition.diffA-B.txt | 23 +++---- .../public-field-definition.diffB-A.txt | 60 ++++++++++--------- 5 files changed, 52 insertions(+), 49 deletions(-) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index aa1377c76..a517cf007 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -92,6 +92,7 @@ type Syntax = '[ , Expression.InstanceOf , Expression.New , Expression.Await + , Expression.This , Literal.Array , Literal.Boolean , Literal.Float @@ -193,7 +194,6 @@ type Syntax = '[ , TypeScript.Syntax.Annotation , TypeScript.Syntax.With , TypeScript.Syntax.ForOf - , TypeScript.Syntax.This , TypeScript.Syntax.Update , TypeScript.Syntax.ComputedPropertyName , TypeScript.Syntax.Decorator @@ -317,7 +317,7 @@ yieldExpression :: Assignment Term yieldExpression = makeTerm <$> symbol Grammar.YieldExpression <*> children (Statement.Yield <$> term (expression <|> emptyTerm)) this :: Assignment Term -this = makeTerm <$> symbol Grammar.This <*> (TypeScript.Syntax.This <$ rawSource) +this = makeTerm <$> symbol Grammar.This <*> (Expression.This <$ rawSource) regex :: Assignment Term regex = makeTerm <$> symbol Grammar.Regex <*> (Literal.Regex <$> source) diff --git a/src/Language/TypeScript/Syntax/JavaScript.hs b/src/Language/TypeScript/Syntax/JavaScript.hs index 5858b21af..0a0701527 100644 --- a/src/Language/TypeScript/Syntax/JavaScript.hs +++ b/src/Language/TypeScript/Syntax/JavaScript.hs @@ -32,14 +32,6 @@ instance Ord1 Debugger where liftCompare = genericLiftCompare instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Debugger -data This a = This - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) - -instance Eq1 This where liftEq = genericLiftEq -instance Ord1 This where liftCompare = genericLiftCompare -instance Show1 This where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable This - data Super a = Super deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) diff --git a/test/fixtures/typescript/corpus/import.diffB-A.txt b/test/fixtures/typescript/corpus/import.diffB-A.txt index e7f961a71..b19df5534 100644 --- a/test/fixtures/typescript/corpus/import.diffB-A.txt +++ b/test/fixtures/typescript/corpus/import.diffB-A.txt @@ -13,9 +13,11 @@ {+(QualifiedAliasedImport {+(Identifier)+})+})+} {+(SideEffectImport)+} -{+(QualifiedAliasedImport{+(Identifier)+})+} +{+(QualifiedAliasedImport + {+(Identifier)+})+} {-(Import)-} -{-(QualifiedAliasedImport{-(Identifier)-})-} +{-(QualifiedAliasedImport + {-(Identifier)-})-} {-(Import)-} {-(Import)-} {-(Import)-} diff --git a/test/fixtures/typescript/corpus/public-field-definition.diffA-B.txt b/test/fixtures/typescript/corpus/public-field-definition.diffA-B.txt index a183f7984..ade4f7f13 100644 --- a/test/fixtures/typescript/corpus/public-field-definition.diffA-B.txt +++ b/test/fixtures/typescript/corpus/public-field-definition.diffA-B.txt @@ -51,21 +51,24 @@ (TypeIdentifier)) (Identifier) (Float)) - (PublicFieldDefinition - {+(Identifier)+} - (Empty) - {-(Readonly)-} - (Annotation - (TypeIdentifier)) - (Identifier) - (Float)) {+(PublicFieldDefinition {+(Identifier)+} - {+(Readonly)+} + {+(Empty)+} {+(Annotation {+(TypeIdentifier)+})+} {+(Identifier)+} - {+(TextElement)+})+} + {+(Float)+})+} + (PublicFieldDefinition + {+(Identifier)+} + {-(Empty)-} + (Readonly) + (Annotation + { (TypeIdentifier) + ->(TypeIdentifier) }) + { (Identifier) + ->(Identifier) } + { (Float) + ->(TextElement) }) {+(PublicFieldDefinition {+(Empty)+} {+(Empty)+} diff --git a/test/fixtures/typescript/corpus/public-field-definition.diffB-A.txt b/test/fixtures/typescript/corpus/public-field-definition.diffB-A.txt index 664aca00b..be620477a 100644 --- a/test/fixtures/typescript/corpus/public-field-definition.diffB-A.txt +++ b/test/fixtures/typescript/corpus/public-field-definition.diffB-A.txt @@ -51,34 +51,40 @@ (TypeIdentifier)) (Identifier) (Float)) - (PublicFieldDefinition + {+(PublicFieldDefinition + {+(Empty)+} + {+(Readonly)+} + {+(Annotation + {+(TypeIdentifier)+})+} + {+(Identifier)+} + {+(Float)+})+} + {+(PublicFieldDefinition + {+(Empty)+} + {+(Readonly)+} + {+(Annotation + {+(TypeIdentifier)+})+} + {+(Identifier)+} + {+(Float)+})+} + {+(PublicFieldDefinition + {+(Empty)+} + {+(Empty)+} + {+(Annotation + {+(TypeIdentifier)+})+} + {+(Identifier)+} + {+(Float)+})+} + {+(PublicFieldDefinition + {+(Empty)+} + {+(Empty)+} + {+(Empty)+} + {+(Identifier)+} + {+(Float)+})+} + {-(PublicFieldDefinition {-(Identifier)-} - (Empty) - {+(Readonly)+} - (Annotation - (TypeIdentifier)) - (Identifier) - (Float)) - {+(PublicFieldDefinition - {+(Empty)+} - {+(Readonly)+} - {+(Annotation - {+(TypeIdentifier)+})+} - {+(Identifier)+} - {+(Float)+})+} - {+(PublicFieldDefinition - {+(Empty)+} - {+(Empty)+} - {+(Annotation - {+(TypeIdentifier)+})+} - {+(Identifier)+} - {+(Float)+})+} - {+(PublicFieldDefinition - {+(Empty)+} - {+(Empty)+} - {+(Empty)+} - {+(Identifier)+} - {+(Float)+})+} + {-(Empty)-} + {-(Annotation + {-(TypeIdentifier)-})-} + {-(Identifier)-} + {-(Float)-})-} {-(PublicFieldDefinition {-(Identifier)-} {-(Readonly)-} From e92846c518829df368b4c32f11cb920313c5d766 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 8 Aug 2018 12:21:48 +1000 Subject: [PATCH 16/16] expand Ctx to EvalContext in get, put, and with function names --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Control/Abstract/Environment.hs | 34 ++++++++++++++--------------- src/Control/Abstract/Heap.hs | 2 +- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- 5 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index bb2131aa1..2175fe741 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -93,8 +93,8 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ do - TermEvaluator (putHeap (configurationHeap c)) - TermEvaluator (putCtx (configurationContext c)) + TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putEvalContext (configurationContext c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f9a783d5c..15c17bf7a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -2,9 +2,9 @@ module Control.Abstract.Environment ( Environment , Exports -, getCtx -, putCtx -, withCtx +, getEvalContext +, putEvalContext +, withEvalContext , getEnv , export , lookupEnv @@ -30,26 +30,26 @@ import Data.Abstract.Name import Prologue -- | Retrieve the current execution context -getCtx :: Member (Env address) effects => Evaluator address value effects (EvalContext address) -getCtx = send GetCtx +getEvalContext :: Member (Env address) effects => Evaluator address value effects (EvalContext address) +getEvalContext = send GetCtx -- | Retrieve the current environment getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) -getEnv = ctxEnvironment <$> getCtx +getEnv = ctxEnvironment <$> getEvalContext -- | Replace the execution context. This is only for use in Analysis.Abstract.Caching. -putCtx :: Member (Env address) effects => EvalContext address -> Evaluator address value effects () -putCtx = send . PutCtx +putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator address value effects () +putEvalContext = send . PutCtx -withCtx :: Member (Env address) effects - => EvalContext address - -> Evaluator address value effects a - -> Evaluator address value effects a -withCtx ctx comp = do - oldCtx <- getCtx - putCtx ctx +withEvalContext :: Member (Env address) effects + => EvalContext address + -> Evaluator address value effects a + -> Evaluator address value effects a +withEvalContext ctx comp = do + oldCtx <- getEvalContext + putEvalContext ctx value <- comp - putCtx oldCtx + putEvalContext oldCtx pure value -- | Add an export to the global export state. @@ -77,7 +77,7 @@ close :: Member (Env address) effects => Set Name -> Evaluator address value eff close = send . Close self :: Member (Env address) effects => Evaluator address value effects (Maybe address) -self = ctxSelf <$> getCtx +self = ctxSelf <$> getEvalContext -- Effects diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index cb76f5fa7..30adce7fa 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -39,7 +39,7 @@ import Prologue -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) -getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getCtx <*> TermEvaluator getHeap +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap -- | Retrieve the heap. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2c43f3134..559869aa3 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -219,7 +219,7 @@ evaluateInScopedEnv :: ( AbstractValue address value effects evaluateInScopedEnv receiver term = do scopedEnv <- scopedEnvironment receiver env <- maybeM getEnv scopedEnv - withCtx (EvalContext (Just receiver) env) term + withEvalContext (EvalContext (Just receiver) env) term -- | Evaluates a 'Value' returning the referenced value diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 6ec6bd69a..b96ecc5d8 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -87,7 +87,7 @@ runFunction toEvaluator fromEvaluator = interpret $ \case withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params) let fnCtx = EvalContext (Just self) (Env.push env) - withCtx fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body))) + withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body))) _ -> throwValueError (CallError op) >>= box