Merge pull request #475 from github/no-more-sketches

Remove the ScopeGraph effect and define it with a constraint kind.

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

@@ -51,8 +51,7 @@ import           Source.Span (Span, span_)
 -- every single Python AST type.
 class (forall a . Show a => Show (t a)) => ToScopeGraph t where
   scopeGraph ::
-    ( Has ScopeGraph sig m
-    , Has (State (ScopeGraph.ScopeGraph Name)) sig m
+    ( ScopeGraphEff sig m
     , Monoid (m Result)
     )
     => t Loc
@@ -64,8 +63,7 @@ instance (ToScopeGraph l, ToScopeGraph r) => ToScopeGraph (l :+: r) where
 
 onField ::
   forall (field :: Symbol) syn sig m r .
-  ( Has ScopeGraph sig m
-  , Has (State (ScopeGraph.ScopeGraph Name)) sig m
+  ( ScopeGraphEff sig m
   , HasField field (r Loc) (syn Loc)
   , ToScopeGraph syn
   , Monoid (m Result)
@@ -79,8 +77,7 @@ onField
 onChildren ::
   ( Traversable t
   , ToScopeGraph syn
-  , Has ScopeGraph sig m
-  , Has (State (ScopeGraph.ScopeGraph Name)) sig m
+  , ScopeGraphEff sig m
   , HasField "extraChildren" (r Loc) (t (syn Loc))
   , Monoid (m Result)
   )
@@ -91,7 +88,7 @@ onChildren
   . traverse scopeGraph
   . getField @"extraChildren"
 
-scopeGraphModule :: (Has (State (ScopeGraph.ScopeGraph Name)) sig m, Has ScopeGraph sig m) => Py.Module Loc -> m Result
+scopeGraphModule :: ScopeGraphEff sig m => Py.Module Loc -> m Result
 scopeGraphModule = getAp . scopeGraph
 
 instance ToScopeGraph Py.AssertStatement where scopeGraph = onChildren

semantic-python/test-graphing/GraphTest.hs

@@ -62,7 +62,7 @@ The graph should be
 runScopeGraph :: ToScopeGraph t => Path.AbsRelFile -> Source.Source -> t Loc -> (ScopeGraph.ScopeGraph Name, Result)
 runScopeGraph p _src item = run . evalFresh 1 . fmap (first sGraph) . runState lowerBound $ scopeGraph item
 
-sampleGraphThing :: (Has ScopeGraph sig m) => m Result
+sampleGraphThing :: ScopeGraphEff sig m => m Result
 sampleGraphThing = do
   declare "hello" (Props.Declaration ScopeGraph.Assignment ScopeGraph.Default Nothing (Span (Pos 2 0) (Pos 2 10)))
   declare "goodbye" (Props.Declaration ScopeGraph.Assignment ScopeGraph.Default Nothing (Span (Pos 3 0) (Pos 3 12)))
@@ -91,7 +91,7 @@ assertSimpleReference = do
 
   HUnit.assertEqual "Should work for simple case" expecto result
 
-expectedReference :: (Has ScopeGraph sig m) => m Result
+expectedReference :: ScopeGraphEff sig m => m Result
 expectedReference = do
   declare "x" (Props.Declaration ScopeGraph.Assignment ScopeGraph.Default Nothing (Span (Pos 0 0) (Pos 0 5)))
   let refProperties = Props.Reference ScopeGraph.Assignment ScopeGraph.Default (Span (Pos 0 0) (Pos 0 1))
@@ -99,7 +99,7 @@ expectedReference = do
   newReference "x" refProperties
   pure Complete
 
-expectedQualifiedImport :: Has ScopeGraph sig m => m Result
+expectedQualifiedImport :: ScopeGraphEff sig m => m Result
 expectedQualifiedImport = do
   let refProperties = Props.Reference ScopeGraph.Identifier ScopeGraph.Default (Span (Pos 0 0) (Pos 0 3))
   newReference (Name.name "cheese") refProperties
@@ -107,7 +107,7 @@ expectedQualifiedImport = do
     newReference (Name.name "ints") refProperties
   pure Complete
 
-expectedFunctionArg :: (Has ScopeGraph sig m) => m Result
+expectedFunctionArg :: ScopeGraphEff sig m => m Result
 expectedFunctionArg = do
   (_, associatedScope) <- declareFunction (Just $ Name.name "foo") (Props.Function ScopeGraph.Function (Span (Pos 0 0) (Pos 1 12)))
   withScope associatedScope $ do
@@ -119,7 +119,7 @@ expectedFunctionArg = do
   newReference "foo" refProperties
   pure Complete
 
-expectedImportHole :: (Has ScopeGraph sig m) => m Result
+expectedImportHole :: ScopeGraphEff sig m => m Result
 expectedImportHole = do
   newEdge ScopeGraph.Import (NonEmpty.fromList ["cheese", "ints"])
   pure Complete
@@ -132,7 +132,7 @@ assertLexicalScope = do
     (expecto, Complete) -> HUnit.assertEqual "Should work for simple case" expecto graph
     (_, Todo msg)       -> HUnit.assertFailure ("Failed to complete:" <> show msg)
 
-expectedLexicalScope :: (Has ScopeGraph sig m) => m Result
+expectedLexicalScope :: ScopeGraphEff sig m => m Result
 expectedLexicalScope = do
   _ <- declareFunction (Just $ Name.name "foo") (Props.Function ScopeGraph.Function (Span (Pos 0 0) (Pos 1 24)))
   let refProperties = Props.Reference ScopeGraph.Identifier ScopeGraph.Default (Span (Pos 0 0) (Pos 0 3))

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

@@ -10,115 +10,44 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fprint-expanded-synonyms #-}
 
 -- | This carrier interprets the Sketch effect, keeping track of
 -- the current scope and in-progress graph internally.
 module Control.Carrier.Sketch.ScopeGraph
-  ( SketchC (..)
+  ( SketchC
   , runSketch
   , module Control.Effect.ScopeGraph
   ) where
 
 import           Analysis.Name (Name)
 import qualified Analysis.Name as Name
-import           Control.Algebra
 import           Control.Carrier.Fresh.Strict
 import           Control.Carrier.Reader
 import           Control.Carrier.State.Strict
-import           Control.Effect.ScopeGraph (ScopeGraphEff (..))
-import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props
-import           Control.Monad.IO.Class
-import           Data.Bifunctor
-import qualified Data.List.NonEmpty as NonEmpty
-import           Data.Module
-import           Data.ScopeGraph (ScopeGraph)
+import           Control.Effect.ScopeGraph
 import qualified Data.ScopeGraph as ScopeGraph
 import           Data.Semilattice.Lower
-import           Source.Span
 import qualified System.Path as Path
 
--- | The state type used to keep track of the in-progress graph and
--- 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 = Sketchbook
-  { sGraph        :: ScopeGraph Name
-  , sCurrentScope :: Name
-  } deriving (Eq, Show)
-
-instance Lower Sketchbook where
-  lowerBound =
-    let
-      initialGraph = ScopeGraph.insertScope n lowerBound lowerBound
-      n = Name.nameI 0
-    in
-      Sketchbook initialGraph n
-
-newtype SketchC address m a = SketchC (StateC Sketchbook (FreshC m) a)
-  deriving (Applicative, Functor, Monad, MonadIO)
-
-instance (Effect sig, Algebra sig m) => Algebra (ScopeGraphEff :+: Reader Name :+: Fresh :+: sig) (SketchC Name m) where
-  alg (L (Declare n props k)) = do
-    Sketchbook old current <- SketchC (get @Sketchbook)
-    let Props.Declaration kind relation associatedScope span = props
-    let (new, _pos) =
-          ScopeGraph.declare
-          (ScopeGraph.Declaration n)
-          (lowerBound @ModuleInfo)
-          relation
-          ScopeGraph.Public
-          span
-          kind
-          associatedScope
-          current
-          old
-    SketchC (put (Sketchbook new current))
-    k ()
-  alg (L (Reference n decl _props k)) = do
-    Sketchbook old current <- SketchC (get @Sketchbook)
-    let new =
-          ScopeGraph.reference
-          (ScopeGraph.Reference (Name.name n))
-          (lowerBound @ModuleInfo)
-          (lowerBound @Span)
-          ScopeGraph.Identifier
-          (ScopeGraph.Declaration (Name.name decl))
-          current
-          old
-    SketchC (put (Sketchbook new current))
-    k ()
-  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 (L (InsertEdge label address k)) = do
-    Sketchbook old current <- SketchC get
-    let new = ScopeGraph.addImportEdge label (NonEmpty.toList address) current old
-    SketchC (put (Sketchbook new current))
-    k ()
-
-  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)
+type SketchC addr m
+  = StateC (ScopeGraph Name)
+  ( StateC Name
+  ( ReaderC Name
+  ( FreshC m
+  )))
 
 runSketch ::
   (Functor m)
   => Maybe Path.AbsRelFile
   -> SketchC Name m a
   -> m (ScopeGraph Name, a)
-runSketch _rootpath (SketchC go)
-  = evalFresh 1
-  . fmap (first sGraph)
-  . runState lowerBound
+runSketch _rootpath go
+  = evalFresh 0
+  . runReader @Name rootname
+  . evalState @Name rootname
+  . runState @(ScopeGraph Name) initialGraph
   $ go
+  where
+    rootname = Name.nameI 0
+    initialGraph = ScopeGraph.insertScope rootname lowerBound lowerBound

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

@@ -1,8 +1,10 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -47,6 +49,7 @@ import           GHC.Records
 import qualified Scope.Reference as Reference
 import           Source.Span
 
+import           Scope.Graph.AdjacencyList (ScopeGraph)
 import qualified Scope.Graph.AdjacencyList as AdjacencyList
 import qualified Scope.Path as Scope
 
@@ -61,42 +64,81 @@ maybeM :: Applicative f => f a -> Maybe a -> f a
 maybeM f = maybe f pure
 {-# INLINE maybeM #-}
 
-type ScopeGraph
-  = ScopeGraphEff
-  :+: Reader (CurrentScope Name)
-  :+: Fresh
-  :+: Reader Name
+type ScopeGraphEff sig m
+  = ( Has (State (ScopeGraph Name)) sig m
+    , Has (State Name) sig m
+    , Has (Reader Name) sig m
+    , Has Fresh sig m
+    )
 
-data ScopeGraphEff m k =
-    Declare Name Props.Declaration (() -> m k)
-  | Reference Text Text Props.Reference (() -> m k)
-  | NewScope (Map ScopeGraph.EdgeLabel [Name]) (Name -> m k)
-  | InsertEdge ScopeGraph.EdgeLabel (NonEmpty Name) (() -> m k)
-  deriving (Generic, Generic1, HFunctor, Effect)
+graphInProgress :: ScopeGraphEff sig m => m (ScopeGraph Name)
+graphInProgress = get
 
-declare :: forall sig m . (Has ScopeGraph sig m) => Name -> Props.Declaration -> m ()
-declare n props = send (Declare n props pure)
+currentScope :: ScopeGraphEff sig m => m Name
+currentScope = ask
+
+withScope :: ScopeGraphEff sig m
+          => Name
+          -> m a
+          -> m a
+withScope scope = local (const scope)
+
+
+declare :: ScopeGraphEff sig m => Name -> Props.Declaration -> m ()
+declare n props = do
+  current <- currentScope
+  old <- graphInProgress
+  let Props.Declaration kind relation associatedScope span = props
+  let (new, _pos) =
+         ScopeGraph.declare
+         (ScopeGraph.Declaration n)
+         (lowerBound @Module.ModuleInfo)
+         relation
+         ScopeGraph.Public
+         span
+         kind
+         associatedScope
+         current
+         old
+  put new
 
 -- | Establish a reference to a prior declaration.
-reference :: forall sig m . (Has ScopeGraph sig m) => Text -> Text -> Props.Reference -> m ()
-reference n decl props = send (Reference n decl props pure)
+reference :: forall sig m . ScopeGraphEff sig m => Text -> Text -> Props.Reference -> m ()
+reference n decl props = do
+  current <- currentScope
+  old <- graphInProgress
+  let new =
+         ScopeGraph.reference
+         (ScopeGraph.Reference (Name.name n))
+         (lowerBound @Module.ModuleInfo)
+         (lowerBound @Span)
+         ScopeGraph.Identifier
+         (ScopeGraph.Declaration (Name.name decl))
+         current
+         old
+  put new
 
-newScope :: forall sig m . Has ScopeGraph sig m => Map ScopeGraph.EdgeLabel [Name] -> m Name
-newScope edges = send (NewScope edges pure)
+newScope :: forall sig m . ScopeGraphEff sig m => Map ScopeGraph.EdgeLabel [Name] -> m Name
+newScope edges = do
+  current <- currentScope
+  old <- graphInProgress
+  name <- Name.gensym
+  let new = ScopeGraph.newScope name edges old
+  name <$ put new
 
 -- | Takes an edge label and a list of names and inserts an import edge to a hole.
-newEdge :: Has ScopeGraph sig m => ScopeGraph.EdgeLabel -> NonEmpty Name -> m ()
-newEdge label targets = send (InsertEdge label targets pure)
+newEdge :: ScopeGraphEff sig m => ScopeGraph.EdgeLabel -> NonEmpty Name -> m ()
+newEdge label address = do
+  current <- currentScope
+  old <- graphInProgress
+  let new = ScopeGraph.addImportEdge label (toList address) current old
+  put new
 
-
-currentScope :: (Has ScopeGraph sig m) => m Name
-currentScope = asks unCurrentScope
-
-lookupScope :: Has (State (ScopeGraph.ScopeGraph Name)) sig m => Name -> m (ScopeGraph.Scope Name)
+lookupScope :: ScopeGraphEff sig m => Name -> m (ScopeGraph.Scope Name)
 lookupScope address = maybeM undefined . ScopeGraph.lookupScope address =<< get
 
 -- | Inserts a reference.
-newReference :: (Has (State (ScopeGraph.ScopeGraph Name)) sig m, Has ScopeGraph sig m) => Name -> Props.Reference -> m ()
+newReference :: ScopeGraphEff sig m => Name -> Props.Reference -> m ()
 newReference name props = do
   currentAddress <- currentScope
   scope <- lookupScope currentAddress
@@ -111,12 +153,12 @@ newReference name props = do
   case ((AdjacencyList.findPath (const Nothing) (ScopeGraph.Declaration name) currentAddress scopeGraph) :: Maybe (Scope.Path Name)) of
     Just path -> modify (\scopeGraph -> insertRef' path scopeGraph)
     Nothing   -> undefined
-  -- maybe
-  --   (modify (const (ScopeGraph.insertScope currentAddress (ScopeGraph.newReference (Reference.Reference name) refProps scope))))
+    -- maybe
+    -- modify (const (ScopeGraph.insertScope currentAddress (ScopeGraph.newReference (Reference.Reference name) refProps scope)))
 
 
 
-declareFunction :: forall sig m . (Has ScopeGraph sig m) => Maybe Name -> Props.Function -> m (Name, Name)
+declareFunction :: forall sig m . ScopeGraphEff sig m => Maybe Name -> Props.Function -> m (Name, Name)
 declareFunction name (Props.Function kind span) = do
   currentScope' <- currentScope
   let lexicalEdges = Map.singleton ScopeGraph.Lexical [ currentScope' ]
@@ -129,7 +171,7 @@ declareFunction name (Props.Function kind span) = do
                                    }
   pure (name', associatedScope)
 
-declareMaybeName :: Has ScopeGraph sig m
+declareMaybeName :: ScopeGraphEff sig m
                  => Maybe Name
                  -> Props.Declaration
                  -> m Name
@@ -139,9 +181,3 @@ declareMaybeName maybeName props = do
     _         -> do
       name <- Name.gensym
       name <$ declare name (props { Props.relation = ScopeGraph.Gensym })
-
-withScope :: Has ScopeGraph sig m
-          => Name
-          -> m a
-          -> m a
-withScope scope = local (const scope)

semantic-scope-graph/src/Scope/Graph/Convert.hs

@@ -13,18 +13,14 @@ module Scope.Graph.Convert
   , complete
   ) where
 
-import           Analysis.Name (Name)
-import           Control.Effect.ScopeGraph
-import           Control.Effect.State
-import           Data.List.NonEmpty
-import qualified Data.ScopeGraph as ScopeGraph
-import           Data.Typeable
-import           Source.Loc
+import Control.Effect.ScopeGraph
+import Data.List.NonEmpty
+import Data.Typeable
+import Source.Loc
 
 class Typeable t => ToScopeGraph t where
   scopeGraph ::
-    ( Has ScopeGraph sig m
-    , Has (State (ScopeGraph.ScopeGraph Name)) sig m
+    ( ScopeGraphEff sig m
     )
     => t Loc
     -> m Result