Merge pull request #1792 from github/ruby-self-class

Fix infinite loop when evaluating scoped environment lookups

src/Analysis/Abstract/BadValues.hs

@@ -2,7 +2,6 @@
 module Analysis.Abstract.BadValues where
 
 import Control.Abstract.Analysis
-import Data.Abstract.Environment as Env
 import Data.ByteString.Char8 (pack)
 import Prologue
 
@@ -22,9 +21,6 @@ instance ( Interpreter effects result rest m
     = interpret
     . runBadValues
     . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ValueError" <> show err) *> case err of
-      ScopedEnvironmentError{} -> do
-        env <- lower @m getEnv
-        yield (Env.push env)
       CallError val     -> yield val
       StringError val   -> yield (pack (show val))
       BoolError{}       -> yield True

src/Analysis/Abstract/BadVariables.hs

@@ -18,6 +18,7 @@ deriving instance MonadAnalysis location term value effects m => MonadAnalysis l
 instance ( Interpreter effects (result, [Name]) rest m
          , MonadEvaluator location term value effects m
          , AbstractHole value
+         , Show value
          )
       => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where
   interpret
@@ -26,6 +27,7 @@ instance ( Interpreter effects (result, [Name]) rest m
     . raiseHandler
       ( flip runState []
       . relay pure (\ (Resumable err) yield -> traceM ("EvalError" <> show err) *> case err of
+        EnvironmentLookupError{}     -> yield hole
         DefaultExportError{}     -> yield ()
         ExportError{}            -> yield ()
         IntegerFormatError{}     -> yield 0

src/Control/Abstract/Value.hs

@@ -134,7 +134,7 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [
             -> m effects value
 
   -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
-  scopedEnvironment :: value -> m effects (Environment location value)
+  scopedEnvironment :: value -> m effects (Maybe (Environment location value))
 
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   lambda :: (FreeVariables term, MonadEvaluator location term value effects m) => [Name] -> Subterm term (m effects value) -> m effects value
@@ -185,9 +185,10 @@ makeNamespace :: ( MonadValue location value effects m
               -> Maybe value
               -> m effects value
 makeNamespace name addr super = do
-  superEnv <- maybe (pure Empty.empty) scopedEnvironment super
+  superEnv <- maybe (pure (Just Empty.empty)) scopedEnvironment super
+  let env' = fromMaybe Empty.empty superEnv
   namespaceEnv <- Env.head <$> getEnv
-  v <- namespace name (Env.mergeNewer superEnv namespaceEnv)
+  v <- namespace name (Env.mergeNewer env' namespaceEnv)
   v <$ assign addr v
 
 
@@ -203,7 +204,6 @@ data ValueError location value resume where
   BoolError              :: value          -> ValueError location value Bool
   IndexError             :: value -> value -> ValueError location value value
   NamespaceError         :: Prelude.String -> ValueError location value (Environment location value)
-  ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value)
   CallError              :: value          -> ValueError location value value
   NumericError           :: value          -> ValueError location value value
   Numeric2Error          :: value -> value -> ValueError location value value
@@ -221,7 +221,6 @@ data ValueError location value resume where
 instance Eq value => Eq1 (ValueError location value) where
   liftEq _ (StringError a) (StringError b)                       = a == b
   liftEq _ (NamespaceError a) (NamespaceError b)                 = a == b
-  liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
   liftEq _ (CallError a) (CallError b)                           = a == b
   liftEq _ (BoolError a) (BoolError c)                           = a == c
   liftEq _ (IndexError a b) (IndexError c d)                     = (a == c) && (b == d)

src/Data/Abstract/Evaluatable.hs

@@ -10,6 +10,7 @@ module Data.Abstract.Evaluatable
 , LoopThrow(..)
 , ResolutionError(..)
 , variable
+, evaluateInScopedEnv
 , evaluateTerm
 , evaluateModule
 , evaluatePackage
@@ -115,17 +116,28 @@ data EvalError value resume where
   RationalFormatError :: ByteString -> EvalError value Rational
   DefaultExportError  :: EvalError value ()
   ExportError         :: ModulePath -> Name -> EvalError value ()
+  EnvironmentLookupError :: value -> EvalError value value
 
+-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
+--   Throws an 'EnvironmentLookupError' if 'scopedEnvTerm' does not have an environment.
+evaluateInScopedEnv :: (MonadEvaluatable location term value effects m)
+                    => m effects value
+                    -> m effects value
+                    -> m effects value
+evaluateInScopedEnv scopedEnvTerm term = do
+  value <- scopedEnvTerm
+  scopedEnv <- scopedEnvironment value
+  maybe (throwEvalError $ EnvironmentLookupError value) (flip localEnv term . mergeEnvs) scopedEnv
 
 -- | Look up and dereference the given 'Name', throwing an exception for free variables.
 variable :: (Member (Resumable (AddressError location value)) effects, Member (Resumable (EvalError value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Name -> m effects value
 variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name))
 
-deriving instance Eq (EvalError a b)
-deriving instance Show (EvalError a b)
-instance Show1 (EvalError value) where
+deriving instance Eq a => Eq (EvalError a b)
+deriving instance Show a => Show (EvalError a b)
+instance Show value => Show1 (EvalError value) where
   liftShowsPrec _ _ = showsPrec
-instance Eq1 (EvalError term) where
+instance Eq term => Eq1 (EvalError term) where
   liftEq _ (FreeVariableError a) (FreeVariableError b)     = a == b
   liftEq _ (FreeVariablesError a) (FreeVariablesError b)   = a == b
   liftEq _ DefaultExportError DefaultExportError           = True
@@ -133,6 +145,7 @@ instance Eq1 (EvalError term) where
   liftEq _ (IntegerFormatError a) (IntegerFormatError b)   = a == b
   liftEq _ (FloatFormatError a) (FloatFormatError b)       = a == b
   liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b
+  liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b
   liftEq _ _ _                                             = False
 
 

src/Data/Abstract/Type.hs

@@ -114,7 +114,7 @@ instance ( Alternative (m effects)
   klass _ _ _   = pure Object
   namespace _ _ = pure Unit
 
-  scopedEnvironment _ = pure Empty.empty
+  scopedEnvironment _ = pure (Just Empty.empty)
 
   asString t = unify t String $> ""
   asPair t   = do

src/Data/Abstract/Value.hs

@@ -231,8 +231,8 @@ instance ( Monad (m effects)
 
   klass n [] env = pure . injValue $ Class n env
   klass n supers env = do
-    product <- foldl mergeEnvs emptyEnv <$> traverse scopedEnvironment supers
-    pure . injValue $ Class n (mergeEnvs (Env.push product) env)
+    product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers
+    pure . injValue $ Class n (mergeEnvs product env)
 
   namespace n env = do
     maybeAddr <- lookupEnv n
@@ -243,9 +243,9 @@ instance ( Monad (m effects)
             | otherwise                             = throwResumable $ NamespaceError ("expected " <> show v <> " to be a namespace")
 
   scopedEnvironment o
-    | Just (Class _ env) <- prjValue o = pure env
-    | Just (Namespace _ env) <- prjValue o = pure env
-    | otherwise = throwResumable $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
+    | Just (Class _ env) <- prjValue o = pure (Just env)
+    | Just (Namespace _ env) <- prjValue o = pure (Just env)
+    | otherwise = pure Nothing
 
   asString v
     | Just (String n) <- prjValue v = pure n

src/Data/Syntax/Expression.hs

@@ -193,9 +193,7 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare
 instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable MemberAccess where
-  eval (fmap subtermValue -> MemberAccess mem acc) = do
-    lhs <- mem >>= scopedEnvironment
-    localEnv (mergeEnvs lhs) acc
+  eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem acc
 
 -- | Subscript (e.g a[1])
 data Subscript a

src/Data/Syntax/Statement.hs

@@ -102,9 +102,7 @@ instance Evaluatable Assignment where
         addr <- lookupOrAlloc name
         assign addr v
         modifyEnv (Env.insert name addr) $> v
-      _ -> do
-        lhs <- subtermValue assignmentTarget >>= scopedEnvironment
-        localEnv (mergeEnvs lhs) (subtermValue assignmentValue)
+      _ -> evaluateInScopedEnv (subtermValue assignmentTarget) (subtermValue assignmentValue)
 
 -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
 newtype PostIncrement a = PostIncrement a

src/Language/PHP/Syntax.hs

@@ -188,10 +188,7 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
 instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedName where
-  eval (fmap subtermValue -> QualifiedName name iden) = do
-    lhs <- name >>= scopedEnvironment
-    localEnv (mergeEnvs lhs) iden
-
+  eval (fmap subtermValue -> QualifiedName name iden) = evaluateInScopedEnv name iden
 
 newtype NamespaceName a = NamespaceName (NonEmpty a)
   deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
@@ -201,11 +198,7 @@ instance Ord1 NamespaceName where liftCompare = genericLiftCompare
 instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable NamespaceName where
-  eval (NamespaceName xs) = foldl1 f $ fmap subtermValue xs
-    where
-      f ns nam = do
-        env <- ns >>= scopedEnvironment
-        localEnv (mergeEnvs env) nam
+  eval (NamespaceName xs) = foldl1 evaluateInScopedEnv $ fmap subtermValue xs
 
 newtype ConstDeclaration a = ConstDeclaration [a]
   deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)

src/Language/Ruby/Syntax.hs

@@ -46,13 +46,7 @@ instance Evaluatable Send where
     let sel = case sendSelector of
           Just sel -> subtermValue sel
           Nothing -> variable (name "call")
-
-    func <- case sendReceiver of
-      Just recv -> do
-        recvEnv <- subtermValue recv >>= scopedEnvironment
-        localEnv (mergeEnvs recvEnv) sel
-      Nothing -> sel -- TODO Does this require `localize` so we don't leak terms when resolving `sendSelector`?
-
+    func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
     call func (map subtermValue sendArgs) -- TODO pass through sendBlock
 
 data Require a = Require { requireRelative :: Bool, requirePath :: !a }