From 7715fd46a9ed3baa40cdb76ff965590926f7ee24 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 11 Feb 2020 12:30:19 -0500 Subject: [PATCH] Remove the ScopeGraph effect and define it with a constraint kind. --- .../src/Language/Python/ScopeGraph.hs | 11 +- semantic-python/test-graphing/GraphTest.hs | 12 +- .../src/Control/Carrier/Sketch/ScopeGraph.hs | 105 +++-------------- .../src/Control/Effect/ScopeGraph.hs | 106 ++++++++++++------ .../src/Scope/Graph/Convert.hs | 14 +-- 5 files changed, 103 insertions(+), 145 deletions(-) diff --git a/semantic-python/src/Language/Python/ScopeGraph.hs b/semantic-python/src/Language/Python/ScopeGraph.hs index 12036cfcd..529649078 100644 --- a/semantic-python/src/Language/Python/ScopeGraph.hs +++ b/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 diff --git a/semantic-python/test-graphing/GraphTest.hs b/semantic-python/test-graphing/GraphTest.hs index 0921108d2..dd7b225a8 100644 --- a/semantic-python/test-graphing/GraphTest.hs +++ b/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)) diff --git a/semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs b/semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs index a5b11cbb5..3be65336d 100644 --- a/semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs +++ b/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 diff --git a/semantic-scope-graph/src/Control/Effect/ScopeGraph.hs b/semantic-scope-graph/src/Control/Effect/ScopeGraph.hs index 433fd5581..17a59b0a5 100644 --- a/semantic-scope-graph/src/Control/Effect/ScopeGraph.hs +++ b/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) diff --git a/semantic-scope-graph/src/Scope/Graph/Convert.hs b/semantic-scope-graph/src/Scope/Graph/Convert.hs index 5706b19f5..96b5dceaa 100644 --- a/semantic-scope-graph/src/Scope/Graph/Convert.hs +++ b/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