Failing reference test

semantic-python/test-graphing/GraphTest.hs

@@ -63,6 +63,22 @@ assertSimpleAssignment = do
   let (result, Complete) = runScopeGraph (Path.absRel path) (Source.fromUTF8 file) pyModule
   HUnit.assertEqual "Should work for simple case" expecto result
 
+expectedReference :: (Has (Sketch Name) sig m) => m Result
+expectedReference = do
+  declare @Name "x" DeclProperties
+  reference @Name "x" "x" RefProperties
+  pure Complete
+
+assertSimpleReference :: HUnit.Assertion
+assertSimpleReference = do
+  let path = "../semantic-python/test/fixtures/5-01-simple-reference.py"
+  file <- ByteString.readFile path
+  tree <- TS.parseByteString @Py.Module @Loc TSP.tree_sitter_python file
+  pyModule <- either die pure tree
+  let (expecto, Complete) = run $ runSketch Nothing expectedReference
+  let (result, Complete) = runScopeGraph (Path.absRel path) (Source.fromUTF8 file) pyModule
+  HUnit.assertEqual "Should work for simple case" expecto result
+
 main :: IO ()
 main = Tasty.defaultMain $
   Tasty.testGroup "Tests" [
@@ -70,5 +86,6 @@ main = Tasty.defaultMain $
       HUnit.testCase "toplevel assignment" assertSimpleAssignment
     ],
     Tasty.testGroup "reference" [
+      HUnit.testCase "simple reference" assertSimpleReference
     ]
   ]

semantic-python/test/fixtures/5-01-simple-reference.py

@@ -0,0 +1,2 @@
+x = 5
+x

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

@@ -66,6 +66,19 @@ instance forall address sig m . (address ~ Name, Effect sig, Algebra sig m) => A
           old
     SketchC (put @(Sketchbook Name) (Sketchbook new current))
     k ()
+  alg (L (Reference n decl _props k)) = do
+    Sketchbook old current <- SketchC (get @(Sketchbook Name))
+    let new =
+          ScopeGraph.reference
+          (ScopeGraph.Reference (Data.Name.name n))
+          (lowerBound @ModuleInfo)
+          (lowerBound @Span)
+          ScopeGraph.Identifier
+          (ScopeGraph.Declaration (Data.Name.name decl))
+          current
+          old
+    SketchC (put @(Sketchbook Name) (Sketchbook new current))
+    k ()
   alg (R other) = SketchC (alg (R (R (handleCoercible other))))
 
 runSketch ::
@@ -78,4 +91,3 @@ runSketch _rootpath (SketchC go)
   . fmap (first sGraph)
   . runState lowerBound
   $ go
-

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

@@ -8,7 +8,9 @@
 module Control.Effect.Sketch
   ( Sketch (..)
   , DeclProperties (..)
+  , RefProperties (..)
   , declare
+  , reference
   , Has
   ) where
 
@@ -19,9 +21,15 @@ import GHC.Generics
 
 data DeclProperties = DeclProperties
 
+data RefProperties = RefProperties
+
 data Sketch address m k =
     Declare Text DeclProperties (() -> m k)
+  | Reference Text Text RefProperties (() -> m k)
   deriving (Generic, Generic1, HFunctor, Effect)
 
 declare :: forall a sig m . (Has (Sketch a) sig m) => Text -> DeclProperties -> m ()
 declare n props = send @(Sketch a) (Declare n props pure)
+
+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)