Set a declaration's scope on assignment

src/Control/Abstract/ScopeGraph.hs

@@ -10,9 +10,12 @@ module Control.Abstract.ScopeGraph
   , Reference(..)
   , EdgeLabel(..)
   , currentScope
+  , withScope
+  , associatedScope
+  , putDeclarationScope
   ) where
 
-import           Control.Abstract.Evaluator
+import           Control.Abstract.Evaluator hiding (Local)
 import           Control.Abstract.Heap
 import           Data.Abstract.Name
 import           Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph)
@@ -23,33 +26,49 @@ import           Prologue
 
 data ScopeEnv address (m :: * -> *) a where
     Lookup :: Reference -> ScopeEnv address m (Maybe address)
-    Declare :: Declaration -> Span -> ScopeEnv address m ()
+    Declare :: Declaration -> Span -> Maybe address -> ScopeEnv address m ()
+    PutDeclarationScope :: Declaration -> address -> ScopeEnv address m ()
     Reference :: Reference -> Declaration -> ScopeEnv address m ()
-    Create :: Map EdgeLabel [address] -> m a -> ScopeEnv address m a
+    NewScope :: Map EdgeLabel [address] -> ScopeEnv address m address
     CurrentScope :: ScopeEnv address m (Maybe address)
+    Local :: address -> m a -> ScopeEnv address m a
+    AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address)
 
 lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address)
 lookup = send . Lookup @address
 
-declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Evaluator address value effects ()
-declare = (send .) . Declare @address
+declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator address value effects ()
+declare = ((send .) .) . Declare @address
+
+putDeclarationScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator address value effects ()
+putDeclarationScope = (send .) . PutDeclarationScope @address
 
 reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects ()
 reference = (send .) . Reference @address
 
-newScope :: forall address value effects m a. (Effectful m, Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> m effects a -> Evaluator address value effects a
-newScope map action= send (Create map (lowerEff action))
+newScope :: forall address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address]  -> Evaluator address value effects address
+newScope map = send (NewScope map)
 
 currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects (Maybe address)
 currentScope = send CurrentScope
 
+associatedScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator address value effects (Maybe address)
+associatedScope = send . AssociatedScope
+
+withScope :: forall address value effects m a. (Effectful (m address value), Member (ScopeEnv address) effects) => address -> m address value effects a -> m address value effects a
+withScope scope action = send (Local scope (lowerEff action))
+
 instance PureEffect (ScopeEnv address)
 instance Effect (ScopeEnv address) where
   handleState c dist (Request (Lookup ref) k)         = Request (Lookup ref) (dist . (<$ c) . k)
-  handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k)
+  handleState c dist (Request (Declare decl span assocScope) k) = Request (Declare decl span assocScope) (dist . (<$ c) . k)
+  handleState c dist (Request (PutDeclarationScope decl assocScope) k) = Request (PutDeclarationScope decl assocScope) (dist . (<$ c) . k)
   handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k)
-  handleState c dist (Request (Create edges action) k) = Request (Create edges (dist (action <$ c))) (dist . fmap k)
+  handleState c dist (Request (NewScope edges) k)       = Request (NewScope edges) (dist . (<$ c) . k)
   handleState c dist (Request CurrentScope k)         = Request CurrentScope (dist . (<$ c) . k)
+  handleState c dist (Request (AssociatedScope decl) k)         = Request (AssociatedScope decl) (dist . (<$ c) . k)
+  handleState c dist (Request (Local scope action) k) = Request (Local scope (dist (action <$ c))) (dist . fmap k)
+
 
 runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects)
             => Evaluator address value (ScopeEnv address ': effects) a
@@ -61,15 +80,19 @@ handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh eff
           -> Evaluator address value (State (ScopeGraph address) ': effects) a
 handleScopeEnv = \case
     Lookup ref -> ScopeGraph.scopeOfRef ref <$> get
-    Declare decl ddata -> modify @(ScopeGraph address) (ScopeGraph.declare decl ddata)
+    Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope)
+    PutDeclarationScope decl scope -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope)
     Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl)
-    Create edges action -> do
+    NewScope edges -> do
         -- Take the edges and construct a new scope, update the current scope to the new scope
-        currentScope' <- ScopeGraph.currentScope <$> get
         name <- gensym
         address <- alloc name
-        modify @(ScopeGraph address) (ScopeGraph.create address edges)
-        value <- reinterpret handleScopeEnv (raiseEff action)
-        modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = currentScope' })
-        pure value
+        address <$ modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
     CurrentScope -> ScopeGraph.currentScope <$> get
+    AssociatedScope decl -> ScopeGraph.associatedScope decl <$> get
+    Local scope action -> do
+        prevScope <- ScopeGraph.currentScope <$> get
+        modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
+        value <- reinterpret handleScopeEnv (raiseEff action)
+        modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
+        pure value

src/Data/Abstract/ScopeGraph.hs

@@ -17,7 +17,9 @@ module Data.Abstract.ScopeGraph
   , declare
   , emptyGraph
   , reference
-  , create
+  , newScope
+  , associatedScope
+  , insertDeclarationScope
   ) where
 
 import           Data.Abstract.Live
@@ -31,7 +33,7 @@ import           Prologue
 data Scope scopeAddress = Scope {
     edges        :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]?
   , references   :: Map Reference (Path scopeAddress)
-  , declarations :: Map Declaration Span
+  , declarations :: Map Declaration (Span, Maybe scopeAddress)
   } deriving (Eq, Show, Ord)
 
 
@@ -59,7 +61,7 @@ pathDeclaration (EPath _ _ p) = pathDeclaration p
 pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope))
 pathsOfScope scope = fmap references . Map.lookup scope . graph
 
-ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration Span)
+ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration (Span, Maybe scope))
 ddataOfScope scope = fmap declarations . Map.lookup scope . graph
 
 linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope])
@@ -68,11 +70,11 @@ linksOfScope scope = fmap edges . Map.lookup scope . graph
 lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope)
 lookupScope scope = Map.lookup scope . graph
 
-declare :: Ord scope => Declaration -> Span -> ScopeGraph scope -> ScopeGraph scope
-declare declaration ddata g@ScopeGraph{..} = fromMaybe g $ do
+declare :: Ord scope => Declaration -> Span -> Maybe scope -> ScopeGraph scope -> ScopeGraph scope
+declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do
   scopeKey <- currentScope
   scope <- lookupScope scopeKey g
-  let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) }
+  let newScope = scope { declarations = Map.insert declaration (ddata, assocScope) (declarations scope) }
   pure $ g { graph = (Map.insert scopeKey newScope graph) }
 
 reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope
@@ -97,8 +99,15 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do
               getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes)
             in traverseEdges I <|> traverseEdges P
 
-create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
-create address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph, currentScope = Just address }
+insertDeclarationScope :: Ord address => Declaration -> address -> ScopeGraph address -> ScopeGraph address
+insertDeclarationScope decl address g@ScopeGraph{..} = fromMaybe g $ do
+  declScope <- scopeOfDeclaration decl g
+  scope <- lookupScope declScope g
+  (span, _) <- Map.lookup decl (declarations scope)
+  pure $ g { graph = Map.insert declScope (scope { declarations = Map.insert decl (span, Just address) (declarations scope) }) graph }
+
+newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
+newScope address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph }
   where
     newScope = Scope edges mempty mempty
 
@@ -117,6 +126,7 @@ pathOfRef ref graph = do
   pathsMap <- pathsOfScope scope graph
   Map.lookup ref pathsMap
 
+-- Returns the scope the declaration was declared in.
 scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope
 scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph)
   where
@@ -126,6 +136,15 @@ scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph)
       pure (Just s)
     go [] = Nothing
 
+associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope
+associatedScope declaration g@ScopeGraph{..} = go (Map.keys graph)
+  where
+    go (s : scopes') = fromMaybe (go scopes') $ do
+      ddataMap <- ddataOfScope s g
+      (_, assocScope) <- Map.lookup declaration ddataMap
+      pure assocScope
+    go [] = Nothing
+
 newtype Reference = Reference Name
   deriving (Eq, Ord, Show)
 

src/Data/Syntax/Declaration.hs

@@ -135,7 +135,7 @@ instance Evaluatable VariableDeclaration where
         subtermSpan <- get @Span
         pure (subtermSpan, ref)
 
-      declare (Declaration name) span
+      declare (Declaration name) span Nothing -- TODO is it true that variable declarations never have an associated scope?
 
       address valueRef
     rvalBox =<< tuple addresses
@@ -175,7 +175,7 @@ instance Evaluatable PublicFieldDefinition where
   eval PublicFieldDefinition{..} = do
     span <- ask @Span
     propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName))
-    declare (Declaration propertyName) span
+    declare (Declaration propertyName) span Nothing
     rvalBox unit
 
 
@@ -207,12 +207,12 @@ instance Evaluatable Class where
   eval Class{..} = do
     name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
     span <- ask @Span
-    -- Add the class to the current scope.
-    declare (Declaration name) span
     -- Run the action within the class's scope.
     currentScope' <- currentScope
     let edges = maybe mempty (Map.singleton P . pure) currentScope'
-    newScope edges $ do
+    childScope <- newScope edges
+    declare (Declaration name) span (Just childScope)
+    withScope childScope $ do
       supers <- traverse subtermAddress classSuperclasses
       (_, addr) <- letrec name $ do
         void $ subtermValue classBody

src/Data/Syntax/Expression.hs

@@ -2,6 +2,8 @@
 {-# OPTIONS_GHC -Wno-missing-export-lists #-}
 module Data.Syntax.Expression where
 
+import qualified Data.Map.Strict as Map
+import Control.Abstract.ScopeGraph as ScopeGraph
 import Data.Abstract.Evaluatable hiding (Member)
 import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
 import Data.Bits
@@ -432,7 +434,17 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable MemberAccess where
   eval (MemberAccess obj propName) = do
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj))
+    reference (Reference name) (Declaration name)
+    childScope <- associatedScope (Declaration name)
+
     ptr <- subtermAddress obj
+    case childScope of
+      Just childScope -> withScope childScope $ reference (Reference propName) (Declaration propName)
+      Nothing ->
+        -- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`.
+        pure ()
+
     pure $! LvalMember ptr propName
 
 -- | Subscript (e.g a[1])
@@ -523,7 +535,11 @@ instance Evaluatable Await where
 
 -- | An object constructor call in Javascript, Java, etc.
 newtype New a = New { newSubject :: [a] }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
+  deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
+
+instance Declarations1 New where
+  liftDeclaredName _ (New []) = Nothing
+  liftDeclaredName declaredName (New (subject : _)) = declaredName subject
 
 instance Eq1 New where liftEq = genericLiftEq
 instance Ord1 New where liftCompare = genericLiftCompare
@@ -531,7 +547,9 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for New
 instance Evaluatable New where
-  eval (New a) =
+  eval (New [subject]) = do
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject))
+    reference (Reference name) (Declaration name)
     -- TODO: Traverse subterms and instantiate frames from the corresponding scope
     rvalBox unit
 

src/Data/Syntax/Statement.hs

@@ -32,7 +32,8 @@ instance Evaluatable Statements where
   eval (Statements xs) = do
     currentScope' <- currentScope
     let edges = maybe mempty (Map.singleton P . pure) currentScope'
-    newScope edges $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
+    scope <- newScope edges
+    withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
 
 instance Tokenize Statements where
   tokenize = imperative
@@ -141,8 +142,17 @@ instance Evaluatable Assignment where
     rhs <- subtermAddress assignmentValue
 
     case lhs of
-      LvalLocal nam -> do
-        bind nam rhs
+      LvalLocal name -> do
+        case (declaredName (subterm assignmentValue)) of
+          Just rhsName -> do
+            assocScope <- associatedScope (Declaration rhsName)
+            let edges = maybe mempty (Map.singleton I . pure) assocScope
+            objectScope <- newScope edges
+            putDeclarationScope (Declaration name) objectScope
+          Nothing ->
+            -- The rhs wasn't assigned to a reference/declaration.
+            pure ()
+        bind name rhs
       LvalMember _ _ ->
         -- we don't yet support mutable object properties:
         pure ()