Merge remote-tracking branch 'origin/function-scopes' into the-locative-case

semantic-python/semantic-python.cabal

@@ -33,7 +33,7 @@ common haskell
                      , text ^>= 1.2.3
                      , tree-sitter ^>= 0.8
                      , tree-sitter-python ^>= 0.8.1
-
+                     , containers
   ghc-options:
     -Weverything
     -Wno-missing-local-signatures

semantic-python/src/Language/Python/ScopeGraph.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -21,12 +22,16 @@ module Language.Python.ScopeGraph
   ( scopeGraphModule
   ) where
 
-import           Analysis.Name
+import qualified Analysis.Name as Name
+import           AST.Element
 import           Control.Algebra (Algebra (..), handleCoercible)
+import           Control.Effect.Fresh
 import           Control.Effect.Sketch
 import           Data.Foldable
+import           Data.Maybe
 import           Data.Monoid
-import           GHC.Generics
+import qualified Data.ScopeGraph as ScopeGraph
+import           Data.Traversable
 import           GHC.Records
 import           GHC.TypeLits
 import           Language.Python.Patterns
@@ -44,7 +49,7 @@ instance Algebra sig m => Algebra sig (Ap m) where
 -- every single Python AST type.
 class (forall a . Show a => Show (t a)) => ToScopeGraph t where
   scopeGraph ::
-    ( Has (Sketch Name) sig m
+    ( Has Sketch sig m
     , Monoid (m Result)
     )
     => t Loc
@@ -56,7 +61,7 @@ instance (ToScopeGraph l, ToScopeGraph r) => ToScopeGraph (l :+: r) where
 
 onField ::
   forall (field :: Symbol) syn sig m r .
-  ( Has (Sketch Name) sig m
+  ( Has Sketch sig m
   , HasField field (r Loc) (syn Loc)
   , ToScopeGraph syn
   , Monoid (m Result)
@@ -70,7 +75,7 @@ onField
 onChildren ::
   ( Traversable t
   , ToScopeGraph syn
-  , Has (Sketch Name) sig m
+  , Has Sketch sig m
   , HasField "extraChildren" (r Loc) (t (syn Loc))
   , Monoid (m Result)
   )
@@ -81,16 +86,16 @@ onChildren
   . traverse scopeGraph
   . getField @"extraChildren"
 
-scopeGraphModule :: Has (Sketch Name) sig m => Py.Module Loc -> m Result
+scopeGraphModule :: Has Sketch sig m => Py.Module Loc -> m Result
 scopeGraphModule = getAp . scopeGraph
 
 instance ToScopeGraph Py.AssertStatement where scopeGraph = onChildren
 
 instance ToScopeGraph Py.Assignment where
-  scopeGraph (Py.Assignment _ (SingleIdentifier t) val _typ) = do
-    declare @Name (formatName t) DeclProperties
-    maybe complete scopeGraph val
-  scopeGraph x = todo x
+  scopeGraph (Py.Assignment _ (SingleIdentifier t) _val _typ) = do
+    let declProps = (DeclProperties ScopeGraph.Assignment ScopeGraph.Default Nothing)
+    maybe complete scopeGraph val <* declare t declProps
+  scopeGraph x                                                = todo x
 
 instance ToScopeGraph Py.Await where
   scopeGraph (Py.Await _ a) = scopeGraph a
@@ -109,7 +114,19 @@ instance ToScopeGraph Py.Block where scopeGraph = onChildren
 
 instance ToScopeGraph Py.BreakStatement where scopeGraph = mempty
 
-instance ToScopeGraph Py.Call where scopeGraph = todo
+instance ToScopeGraph Py.Call where
+  scopeGraph Py.Call
+    { function
+    , arguments = L1 Py.ArgumentList { extraChildren = args }
+    } = do
+      result <- scopeGraph function
+      let scopeGraphArg = \case
+            Prj expr -> scopeGraph @Py.Expression expr
+            other    -> todo other
+      args <- traverse scopeGraphArg args
+      pure (result <> mconcat args)
+  scopeGraph it = todo it
+
 
 instance ToScopeGraph Py.ClassDefinition where scopeGraph = todo
 
@@ -158,7 +175,27 @@ instance ToScopeGraph Py.Float where scopeGraph = mempty
 
 instance ToScopeGraph Py.ForStatement where scopeGraph = todo
 
-instance ToScopeGraph Py.FunctionDefinition where scopeGraph = todo
+instance ToScopeGraph Py.FunctionDefinition where
+  scopeGraph Py.FunctionDefinition
+    { name       = Py.Identifier _ann1 name
+    , parameters = Py.Parameters _ann2 parameters
+    , body
+    } = do
+    let funProps = FunProperties ScopeGraph.Function
+    (_, associatedScope) <- declareFunction (Just $ Name.name name) funProps
+    withScope associatedScope $ do
+      let declProps = DeclProperties ScopeGraph.Parameter ScopeGraph.Default Nothing
+      let param (Py.Parameter (Prj (Py.Identifier _pann pname))) = Just (Name.name pname)
+          param _                                                = Nothing
+      let parameterMs = fmap param parameters
+      if any isNothing parameterMs
+        then todo parameterMs
+        else do
+          let parameters' = catMaybes parameterMs
+          paramDeclarations <- for parameters' $ \parameter ->
+            complete <* declare parameter declProps
+          bodyResult <- scopeGraph body
+          pure (mconcat paramDeclarations <> bodyResult)
 
 instance ToScopeGraph Py.FutureImportStatement where scopeGraph = todo
 
@@ -166,7 +203,7 @@ instance ToScopeGraph Py.GeneratorExpression where scopeGraph = todo
 
 instance ToScopeGraph Py.Identifier where
   scopeGraph (Py.Identifier _ name) = do
-    reference @Name name name RefProperties
+    reference name name RefProperties
     complete
 
 instance ToScopeGraph Py.IfStatement where

semantic-python/test-graphing/GraphTest.hs

@@ -6,6 +6,7 @@
 module Main (main) where
 
 import           Analysis.Name (Name)
+import qualified Analysis.Name as Name
 import           Control.Algebra
 import           Control.Carrier.Lift
 import           Control.Carrier.Sketch.Fresh
@@ -50,10 +51,10 @@ The graph should be
 runScopeGraph :: ToScopeGraph t => Path.AbsRelFile -> Source.Source -> t Loc -> (ScopeGraph.ScopeGraph Name, Result)
 runScopeGraph p _src item = run . runSketch (Just p) $ scopeGraph item
 
-sampleGraphThing :: (Has (Sketch Name) sig m) => m Result
+sampleGraphThing :: (Has Sketch sig m) => m Result
 sampleGraphThing = do
-  declare @Name "hello" DeclProperties
-  declare @Name "goodbye" DeclProperties
+  declare "hello" (DeclProperties ScopeGraph.Assignment ScopeGraph.Default Nothing)
+  declare "goodbye" (DeclProperties ScopeGraph.Assignment ScopeGraph.Default Nothing)
   pure Complete
 
 graphFile :: FilePath -> IO (ScopeGraph.ScopeGraph Name, Result)
@@ -71,10 +72,10 @@ assertSimpleAssignment = do
   (expecto, Complete) <- runM $ runSketch Nothing sampleGraphThing
   HUnit.assertEqual "Should work for simple case" expecto result
 
-expectedReference :: (Has (Sketch Name) sig m) => m Result
+expectedReference :: (Has Sketch sig m) => m Result
 expectedReference = do
-  declare @Name "x" DeclProperties
-  reference @Name "x" "x" RefProperties
+  declare "x" (DeclProperties ScopeGraph.Assignment ScopeGraph.Default Nothing)
+  reference "x" "x" RefProperties
   pure Complete
 
 assertSimpleReference :: HUnit.Assertion
@@ -85,6 +86,38 @@ assertSimpleReference = do
 
   HUnit.assertEqual "Should work for simple case" expecto result
 
+expectedLexicalScope :: (Has Sketch sig m) => m Result
+expectedLexicalScope = do
+  _ <- declareFunction (Just $ Name.name "foo") (FunProperties ScopeGraph.Function)
+  reference "foo" "foo" RefProperties {}
+  pure Complete
+
+expectedFunctionArg :: (Has Sketch sig m) => m Result
+expectedFunctionArg = do
+  (_, associatedScope) <- declareFunction (Just $ Name.name "foo") (FunProperties ScopeGraph.Function)
+  withScope associatedScope $ do
+    declare "x" (DeclProperties ScopeGraph.Identifier ScopeGraph.Default Nothing)
+    reference "x" "x" RefProperties
+    pure ()
+  reference "foo" "foo" RefProperties
+  pure Complete
+
+assertLexicalScope :: HUnit.Assertion
+assertLexicalScope = do
+  let path = "semantic-python/test/fixtures/5-02-simple-function.py"
+  (graph, _) <- graphFile path
+  case run (runSketch Nothing expectedLexicalScope) of
+    (expecto, Complete) -> HUnit.assertEqual "Should work for simple case" expecto graph
+    (_, Todo msg) -> HUnit.assertFailure ("Failed to complete:" <> show msg)
+
+assertFunctionArg :: HUnit.Assertion
+assertFunctionArg = do
+  let path = "semantic-python/test/fixtures/5-03-function-argument.py"
+  (graph, _) <- graphFile path
+  case run (runSketch Nothing expectedFunctionArg) of
+    (expecto, Complete) -> HUnit.assertEqual "Should work for simple case" expecto graph
+    (_, Todo msg) -> HUnit.assertFailure ("Failed to complete:" <>  show msg)
+
 main :: IO ()
 main = do
   -- make sure we're in the root directory so the paths resolve properly
@@ -99,5 +132,9 @@ main = do
       ],
       Tasty.testGroup "reference" [
         HUnit.testCase "simple reference" assertSimpleReference
+      ],
+      Tasty.testGroup "lexical scopes" [
+        HUnit.testCase "simple function scope" assertLexicalScope
+      , HUnit.testCase "simple function argument" assertFunctionArg
       ]
     ]

semantic-python/test/fixtures/5-02-simple-function.py

@@ -0,0 +1,4 @@
+def foo():
+    return "hello world"
+
+foo()

semantic-python/test/fixtures/5-03-function-argument.py

@@ -0,0 +1,4 @@
+def foo(x):
+    return x
+
+foo(1)

semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
@@ -19,10 +20,11 @@ module Control.Carrier.Sketch.Fresh
   ) where
 
 import           Analysis.Name (Name)
-import qualified Analysis.Name
+import qualified Analysis.Name as Name
 import           Control.Algebra
 import           Control.Carrier.Fresh.Strict
 import           Control.Carrier.State.Strict
+import           Control.Carrier.Reader
 import           Control.Effect.Sketch
 import           Control.Monad.IO.Class
 import           Data.Bifunctor
@@ -30,6 +32,7 @@ import           Data.Module
 import           Data.ScopeGraph (ScopeGraph)
 import qualified Data.ScopeGraph as ScopeGraph
 import           Data.Semilattice.Lower
+import           GHC.Records
 import           Source.Span
 import qualified System.Path as Path
 
@@ -37,52 +40,69 @@ import qualified System.Path as Path
 -- positional/contextual information. The name "sketchbook" is meant
 -- to invoke an in-progress, concealed work, as well as the
 -- "sketching" of a graph.
-data Sketchbook address = Sketchbook
-  { sGraph        :: ScopeGraph address
-  , sCurrentScope :: address
+data Sketchbook = Sketchbook
+  { sGraph        :: ScopeGraph Name
+  , sCurrentScope :: Name
   } deriving (Eq, Show)
 
-instance Lower (Sketchbook Name) where
+instance Lower Sketchbook where
   lowerBound =
     let
       initialGraph = ScopeGraph.insertScope n lowerBound lowerBound
-      n = Analysis.Name.nameI 0
+      n = Name.nameI 0
     in
       Sketchbook initialGraph n
 
-newtype SketchC address m a = SketchC (StateC (Sketchbook address) (FreshC m) a)
+newtype SketchC address m a = SketchC (StateC Sketchbook (FreshC m) a)
   deriving (Applicative, Functor, Monad, MonadIO)
 
-instance (Effect sig, Algebra sig m) => Algebra (Sketch Name :+: sig) (SketchC Name m) where
-  alg (L (Declare n _props k)) = do
-    Sketchbook old current <- SketchC (get @(Sketchbook Name))
+instance (Effect sig, Algebra sig m) => Algebra (SketchEff :+: Reader Name :+: Fresh :+: sig) (SketchC Name m) where
+  alg (L (Declare n props k)) = do
+    Sketchbook old current <- SketchC (get @Sketchbook)
     let (new, _pos) =
           ScopeGraph.declare
-          (ScopeGraph.Declaration (Analysis.Name.name n))
+          (ScopeGraph.Declaration n)
           (lowerBound @ModuleInfo)
-          ScopeGraph.Default
+          (relation props)
           ScopeGraph.Public
           (lowerBound @Span)
-          ScopeGraph.Identifier
-          Nothing
+          (getField @"kind" @DeclProperties props)
+          (associatedScope props)
           current
           old
-    SketchC (put @(Sketchbook Name) (Sketchbook new current))
+    SketchC (put (Sketchbook new current))
     k ()
   alg (L (Reference n decl _props k)) = do
-    Sketchbook old current <- SketchC (get @(Sketchbook Name))
+    Sketchbook old current <- SketchC (get @Sketchbook)
     let new =
           ScopeGraph.reference
-          (ScopeGraph.Reference (Analysis.Name.name n))
+          (ScopeGraph.Reference (Name.name n))
           (lowerBound @ModuleInfo)
           (lowerBound @Span)
           ScopeGraph.Identifier
-          (ScopeGraph.Declaration (Analysis.Name.name decl))
+          (ScopeGraph.Declaration (Name.name decl))
           current
           old
-    SketchC (put @(Sketchbook Name) (Sketchbook new current))
+    SketchC (put (Sketchbook new current))
     k ()
-  alg (R other) = SketchC (alg (R (R (handleCoercible other))))
+  alg (L (NewScope edges k)) = do
+    Sketchbook old current <- SketchC get
+    name <- SketchC Name.gensym
+    let new = ScopeGraph.newScope name edges old
+    SketchC (put (Sketchbook new current))
+    k name
+  alg (R (L a)) = case a of
+    Ask k -> SketchC (gets sCurrentScope) >>= k
+    Local fn go k -> do
+      initial@(Sketchbook s oldScope) <- SketchC get
+      let newScope = fn oldScope
+      SketchC (put (Sketchbook s newScope))
+      result <- go
+      SketchC (put initial)
+      k result
+
+  alg (R (R (L a))) = send (handleCoercible a)
+  alg (R (R (R a))) = send (handleCoercible a)
 
 runSketch ::
   (Functor m)
@@ -90,7 +110,7 @@ runSketch ::
   -> SketchC Name m a
   -> m (ScopeGraph Name, a)
 runSketch _rootpath (SketchC go)
-  = evalFresh 0
+  = evalFresh 1
   . fmap (first sGraph)
   . runState lowerBound
   $ go

semantic-scope-graph/src/Control/Effect/Sketch.hs

@@ -1,39 +1,117 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- | The Sketch effect is used to build up a scope graph over
 -- the lifetime of a monadic computation. The name is meant to evoke
 -- physically sketching the hierarchical outline of a graph.
 module Control.Effect.Sketch
-  ( Sketch (..)
+  ( Sketch
+  , SketchEff (..)
   , DeclProperties (..)
   , RefProperties (..)
+  , FunProperties (..)
   , declare
+  -- Scope Manipulation
+  , currentScope
+  , newScope
+  , withScope
+  , declareFunction
+  , declareMaybeName
   , reference
   , Has
   ) where
 
-import Control.Algebra
-import Data.Text (Text)
-import GHC.Generics
+import           Control.Algebra
+import           Control.Effect.Fresh
+import           Control.Effect.Reader
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import           Analysis.Name (Name)
+import qualified Analysis.Name as Name
+import qualified Data.ScopeGraph as ScopeGraph
+import           Data.Text (Text)
+import           GHC.Generics (Generic, Generic1)
+import           GHC.Records
 
-data DeclProperties = DeclProperties
+data DeclProperties = DeclProperties {
+    kind            :: ScopeGraph.Kind
+  , relation        :: ScopeGraph.Relation
+  , associatedScope :: Maybe Name
+}
 
 data RefProperties = RefProperties
+data FunProperties = FunProperties {
+  kind :: ScopeGraph.Kind
+}
 
-data Sketch address m k =
-    Declare Text DeclProperties (() -> m k)
+type Sketch
+  = SketchEff
+  :+: Fresh
+  :+: Reader Name
+
+data SketchEff m k =
+    Declare Name DeclProperties (() -> m k)
   | Reference Text Text RefProperties (() -> m k)
+  | NewScope (Map ScopeGraph.EdgeLabel [Name]) (Name -> m k)
   deriving (Generic, Generic1, HFunctor, Effect)
 
--- | Introduces a declaration into the scope.
-declare :: forall a sig m . (Has (Sketch a) sig m) => Text -> DeclProperties -> m ()
-declare n props = send @(Sketch a) (Declare n props pure)
+currentScope :: Has (Reader Name) sig m => m Name
+currentScope = ask
+
+declare :: forall sig m . (Has Sketch sig m) => Name -> DeclProperties -> m ()
+declare n props = send (Declare n props pure)
 
 -- | Establish a reference to a prior declaration.
-reference :: forall a sig m . (Has (Sketch a) sig m) => Text -> Text -> RefProperties -> m ()
-reference n decl props = send @(Sketch a) (Reference n decl props pure)
+reference :: forall sig m . (Has Sketch sig m) => Text -> Text -> RefProperties -> m ()
+reference n decl props = send (Reference n decl props pure)
+
+newScope :: forall sig m . (Has Sketch sig m) => Map ScopeGraph.EdgeLabel [Name] -> m Name
+newScope edges = send (NewScope edges pure)
+
+declareFunction :: forall sig m . (Has Sketch sig m) => Maybe Name -> FunProperties -> m (Name, Name)
+declareFunction name props = do
+  currentScope' <- currentScope
+  let lexicalEdges = Map.singleton ScopeGraph.Lexical [ currentScope' ]
+  associatedScope <- newScope lexicalEdges
+  name' <- declareMaybeName name (DeclProperties { relation = ScopeGraph.Default, kind = (getField @"kind" @FunProperties props), associatedScope = Just associatedScope })
+  pure (name', associatedScope)
+
+declareMaybeName :: Has Sketch sig m
+                 => Maybe Name
+                 -> DeclProperties
+                 -> m Name
+declareMaybeName maybeName props = do
+  case maybeName of
+    Just name -> name <$ declare name props
+    _         -> Name.gensym >>= \name -> declare name (props { relation = ScopeGraph.Gensym }) >> pure name -- TODO: Modify props and change Kind to Gensym
+
+withScope :: Has Sketch sig m
+          => Name
+          -> m a
+          -> m a
+withScope scope = local (const scope)
+-- declareFunction :: ( Has (State (ScopeGraph address)) sig m
+--                    , Has (Allocator address) sig m
+--                    , Has (Reader (CurrentScope address)) sig m
+--                    , Has (Reader ModuleInfo) sig m
+--                    , Has Fresh sig m
+--                    , Ord address
+--                    )
+--                 => Maybe Name
+--                 -> ScopeGraph.AccessControl
+--                 -> Span
+--                 -> ScopeGraph.Kind
+--                 -> Evaluator term address value m (Name, address)
+-- declareFunction name accessControl span kind = do
+--   currentScope' <- currentScope
+--   let lexicalEdges = Map.singleton Lexical [ currentScope' ]
+--   associatedScope <- newScope lexicalEdges
+--   name' <- declareMaybeName name Default accessControl span kind (Just associatedScope)
+--   pure (name', associatedScope)

semantic-scope-graph/src/ScopeGraph/Convert.hs

@@ -13,7 +13,6 @@ module ScopeGraph.Convert
   , complete
   ) where
 
-import Analysis.Name (Name)
 import Control.Effect.Sketch
 import Data.List.NonEmpty
 import Data.Typeable
@@ -21,7 +20,7 @@ import Source.Loc
 
 class Typeable t => ToScopeGraph t where
   scopeGraph ::
-    ( Has (Sketch Name) sig m
+    ( Has Sketch sig m
     )
     => t Loc
     -> m Result