mirror of
https://github.com/github/semantic.git
synced 2024-12-27 00:44:57 +03:00
Remove the ScopeGraph effect and define it with a constraint kind.
This commit is contained in:
Patrick Thomson
parent
a572f05494
commit
7715fd46a9
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user