From 5ea07633d21a7de0a958140dcd85811cdef6e114 Mon Sep 17 00:00:00 2001
From: joshvera <josh@joshvera.com>
Date: Tue, 14 Jan 2020 18:08:10 -0500
Subject: [PATCH] Failing reference test

---
 semantic-python/test-graphing/GraphTest.hs      | 17 +++++++++++++++++
 .../test/fixtures/5-01-simple-reference.py      |  2 ++
 .../src/Control/Carrier/Sketch/Fresh.hs         | 14 +++++++++++++-
 .../src/Control/Effect/Sketch.hs                | 10 +++++++++-
 4 files changed, 41 insertions(+), 2 deletions(-)
 create mode 100644 semantic-python/test/fixtures/5-01-simple-reference.py

diff --git a/semantic-python/test-graphing/GraphTest.hs b/semantic-python/test-graphing/GraphTest.hs
index 75a632770..f5b028126 100644
--- a/semantic-python/test-graphing/GraphTest.hs
+++ b/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
     ]
   ]
diff --git a/semantic-python/test/fixtures/5-01-simple-reference.py b/semantic-python/test/fixtures/5-01-simple-reference.py
new file mode 100644
index 000000000..f5d88f2f0
--- /dev/null
+++ b/semantic-python/test/fixtures/5-01-simple-reference.py
@@ -0,0 +1,2 @@
+x = 5
+x
diff --git a/semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs b/semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs
index 787131e37..d02d6ed57 100644
--- a/semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs
+++ b/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
-
diff --git a/semantic-scope-graph/src/Control/Effect/Sketch.hs b/semantic-scope-graph/src/Control/Effect/Sketch.hs
index b785ebba6..397c05e99 100644
--- a/semantic-scope-graph/src/Control/Effect/Sketch.hs
+++ b/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)
+    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)