diff --git a/script/ghci-flags b/script/ghci-flags index 63521e45d..c706440f2 100755 --- a/script/ghci-flags +++ b/script/ghci-flags @@ -44,6 +44,8 @@ function flags { then add_autogen_includes "$build_dir/semantic-0.10.0.0/noopt/build/autogen" fi + echo "-optP-Wno-macro-redefined" + # .hs source dirs # TODO: would be nice to figure this out from cabal.project & the .cabal files echo "-isemantic-analysis/src" diff --git a/semantic-python/src/Language/Python.hs b/semantic-python/src/Language/Python.hs index 59abf0d09..54745db1d 100644 --- a/semantic-python/src/Language/Python.hs +++ b/semantic-python/src/Language/Python.hs @@ -4,14 +4,14 @@ module Language.Python , Language.Python.Grammar.tree_sitter_python ) where +import qualified AST.Unmarshal as TS import Data.Proxy import qualified Language.Python.AST as Py +import qualified Language.Python.Grammar (tree_sitter_python) import Language.Python.ScopeGraph import qualified Language.Python.Tags as PyTags -import ScopeGraph.Convert +import Scope.Graph.Convert import qualified Tags.Tagging.Precise as Tags -import qualified Language.Python.Grammar (tree_sitter_python) -import qualified AST.Unmarshal as TS newtype Term a = Term { getTerm :: Py.Module a } diff --git a/semantic-python/src/Language/Python/ScopeGraph.hs b/semantic-python/src/Language/Python/ScopeGraph.hs index 65fe931e3..f4e89a96e 100644 --- a/semantic-python/src/Language/Python/ScopeGraph.hs +++ b/semantic-python/src/Language/Python/ScopeGraph.hs @@ -24,7 +24,10 @@ module Language.Python.ScopeGraph import qualified Analysis.Name as Name import AST.Element import Control.Effect.Fresh -import Control.Effect.Sketch +import Control.Effect.ScopeGraph +import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props +import qualified Control.Effect.ScopeGraph.Properties.Function as Props +import qualified Control.Effect.ScopeGraph.Properties.Reference as Props import Control.Lens (set, (^.)) import Data.Foldable import Data.Maybe @@ -36,10 +39,7 @@ import GHC.Records import GHC.TypeLits import qualified Language.Python.AST as Py import Language.Python.Patterns -import ScopeGraph.Convert (Result (..), complete, todo) -import qualified ScopeGraph.Properties.Declaration as Props -import qualified ScopeGraph.Properties.Function as Props -import qualified ScopeGraph.Properties.Reference as Props +import Scope.Graph.Convert (Result (..), complete, todo) import Source.Loc import Source.Span (span_) @@ -49,7 +49,7 @@ import Source.Span (span_) -- every single Python AST type. class (forall a . Show a => Show (t a)) => ToScopeGraph t where scopeGraph :: - ( Has Sketch sig m + ( Has ScopeGraph sig m , Monoid (m Result) ) => t Loc @@ -61,7 +61,7 @@ instance (ToScopeGraph l, ToScopeGraph r) => ToScopeGraph (l :+: r) where onField :: forall (field :: Symbol) syn sig m r . - ( Has Sketch sig m + ( Has ScopeGraph sig m , HasField field (r Loc) (syn Loc) , ToScopeGraph syn , Monoid (m Result) @@ -75,7 +75,7 @@ onField onChildren :: ( Traversable t , ToScopeGraph syn - , Has Sketch sig m + , Has ScopeGraph sig m , HasField "extraChildren" (r Loc) (t (syn Loc)) , Monoid (m Result) ) @@ -86,7 +86,7 @@ onChildren . traverse scopeGraph . getField @"extraChildren" -scopeGraphModule :: Has Sketch sig m => Py.Module Loc -> m Result +scopeGraphModule :: Has ScopeGraph sig m => Py.Module Loc -> m Result scopeGraphModule = getAp . scopeGraph instance ToScopeGraph Py.AssertStatement where scopeGraph = onChildren @@ -231,7 +231,13 @@ instance ToScopeGraph Py.Integer where scopeGraph = mempty instance ToScopeGraph Py.ImportStatement where scopeGraph = todo -instance ToScopeGraph Py.ImportFromStatement where scopeGraph = todo +instance ToScopeGraph Py.ImportFromStatement where + scopeGraph (Py.ImportFromStatement _ [] (L1 (Py.DottedName _ names)) (Just (Py.WildcardImport _ _))) = do + let toName (Py.Identifier _ name) = Name.name name + complete <* insertEdge ScopeGraph.Import (toName <$> names) + scopeGraph term = todo (show term) + + instance ToScopeGraph Py.Lambda where scopeGraph = todo diff --git a/semantic-python/test-graphing/GraphTest.hs b/semantic-python/test-graphing/GraphTest.hs index 85567b641..38c3a0344 100644 --- a/semantic-python/test-graphing/GraphTest.hs +++ b/semantic-python/test-graphing/GraphTest.hs @@ -7,19 +7,23 @@ module Main (main) where import Analysis.Name (Name) import qualified Analysis.Name as Name +import qualified AST.Unmarshal as TS import Control.Algebra import Control.Carrier.Lift -import Control.Carrier.Sketch.Fresh +import Control.Carrier.Sketch.ScopeGraph +import Control.Effect.ScopeGraph +import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props +import qualified Control.Effect.ScopeGraph.Properties.Function as Props +import qualified Control.Effect.ScopeGraph.Properties.Reference as Props import Control.Monad import qualified Data.ByteString as ByteString +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.ScopeGraph as ScopeGraph import Data.Semilattice.Lower import qualified Language.Python () import qualified Language.Python as Py (Term) -import ScopeGraph.Convert -import qualified ScopeGraph.Properties.Declaration as Props -import qualified ScopeGraph.Properties.Function as Props -import qualified ScopeGraph.Properties.Reference as Props +import qualified Language.Python.Grammar as TSP +import Scope.Graph.Convert import Source.Loc import qualified Source.Source as Source import Source.Span @@ -29,8 +33,6 @@ import qualified System.Path as Path import qualified System.Path.Directory as Path import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as HUnit -import qualified Language.Python.Grammar as TSP -import qualified AST.Unmarshal as TS {- @@ -56,7 +58,7 @@ The graph should be runScopeGraph :: ToScopeGraph t => Path.AbsRelFile -> Source.Source -> t Loc -> (ScopeGraph.ScopeGraph Name, Result) runScopeGraph p _src item = run . runSketch (Just p) $ scopeGraph item -sampleGraphThing :: (Has Sketch sig m) => m Result +sampleGraphThing :: (Has ScopeGraph 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))) @@ -77,7 +79,7 @@ assertSimpleAssignment = do (expecto, Complete) <- runM $ runSketch Nothing sampleGraphThing HUnit.assertEqual "Should work for simple case" expecto result -expectedReference :: (Has Sketch sig m) => m Result +expectedReference :: (Has ScopeGraph sig m) => m Result expectedReference = do declare "x" (Props.Declaration ScopeGraph.Assignment ScopeGraph.Default Nothing (Span (Pos 0 0) (Pos 0 5))) reference "x" "x" Props.Reference @@ -91,13 +93,13 @@ assertSimpleReference = do HUnit.assertEqual "Should work for simple case" expecto result -expectedLexicalScope :: (Has Sketch sig m) => m Result +expectedLexicalScope :: (Has ScopeGraph sig m) => m Result expectedLexicalScope = do _ <- declareFunction (Just $ Name.name "foo") (Props.Function ScopeGraph.Function (Span (Pos 0 0) (Pos 1 24))) reference "foo" "foo" Props.Reference {} pure Complete -expectedFunctionArg :: (Has Sketch sig m) => m Result +expectedFunctionArg :: (Has ScopeGraph 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 @@ -107,6 +109,11 @@ expectedFunctionArg = do reference "foo" "foo" Props.Reference pure Complete +expectedImportHole :: (Has ScopeGraph sig m) => m Result +expectedImportHole = do + insertEdge ScopeGraph.Import (NonEmpty.fromList ["cheese", "ints"]) + pure Complete + assertLexicalScope :: HUnit.Assertion assertLexicalScope = do let path = "semantic-python/test/fixtures/5-02-simple-function.py" @@ -123,6 +130,14 @@ assertFunctionArg = do (expecto, Complete) -> HUnit.assertEqual "Should work for simple case" expecto graph (_, Todo msg) -> HUnit.assertFailure ("Failed to complete:" <> show msg) +assertImportHole :: HUnit.Assertion +assertImportHole = do + let path = "semantic-python/test/fixtures/cheese/6-01-imports.py" + (graph, _) <- graphFile path + case run (runSketch Nothing expectedImportHole) of + (expecto, Complete) -> HUnit.assertEqual "Should work for simple case" expecto graph + (_, Todo msg) -> HUnit.assertFailure ("Failed to complete:" <> show msg) + main :: IO () main = do -- make sure we're in the root directory so the paths resolve properly @@ -141,5 +156,8 @@ main = do Tasty.testGroup "lexical scopes" [ HUnit.testCase "simple function scope" assertLexicalScope , HUnit.testCase "simple function argument" assertFunctionArg + ], + Tasty.testGroup "imports" [ + HUnit.testCase "simple function argument" assertImportHole ] ] diff --git a/semantic-python/test/fixtures/cheese/6-01-imports.py b/semantic-python/test/fixtures/cheese/6-01-imports.py new file mode 100644 index 000000000..5ce8582d6 --- /dev/null +++ b/semantic-python/test/fixtures/cheese/6-01-imports.py @@ -0,0 +1 @@ +from cheese.ints import * diff --git a/semantic-python/test/fixtures/cheese/ints.py b/semantic-python/test/fixtures/cheese/ints.py new file mode 100644 index 000000000..cd81106f3 --- /dev/null +++ b/semantic-python/test/fixtures/cheese/ints.py @@ -0,0 +1,5 @@ +def one(): + return 1 + +def two(): + return 2 diff --git a/semantic-scope-graph/semantic-scope-graph.cabal b/semantic-scope-graph/semantic-scope-graph.cabal index 08d962bd1..51c9b908a 100644 --- a/semantic-scope-graph/semantic-scope-graph.cabal +++ b/semantic-scope-graph/semantic-scope-graph.cabal @@ -20,12 +20,18 @@ tested-with: GHC == 8.6.5 library exposed-modules: - Control.Carrier.Sketch.Fresh - Control.Effect.Sketch - ScopeGraph.Convert - ScopeGraph.Properties.Declaration - ScopeGraph.Properties.Function - ScopeGraph.Properties.Reference + Control.Carrier.Sketch.ScopeGraph + Control.Effect.ScopeGraph + Control.Effect.ScopeGraph.Properties.Declaration + Control.Effect.ScopeGraph.Properties.Function + Control.Effect.ScopeGraph.Properties.Reference + Scope.Graph.AdjacencyList + Scope.Graph.Convert + Scope.Info + Scope.Path + Scope.Reference + Scope.Scope + Scope.Types Data.Hole Data.Module Data.ScopeGraph diff --git a/semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs b/semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs similarity index 85% rename from semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs rename to semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs index a8d5c60ac..a5b11cbb5 100644 --- a/semantic-scope-graph/src/Control/Carrier/Sketch/Fresh.hs +++ b/semantic-scope-graph/src/Control/Carrier/Sketch/ScopeGraph.hs @@ -13,10 +13,10 @@ -- | This carrier interprets the Sketch effect, keeping track of -- the current scope and in-progress graph internally. -module Control.Carrier.Sketch.Fresh +module Control.Carrier.Sketch.ScopeGraph ( SketchC (..) , runSketch - , module Control.Effect.Sketch + , module Control.Effect.ScopeGraph ) where import Analysis.Name (Name) @@ -25,14 +25,15 @@ import Control.Algebra import Control.Carrier.Fresh.Strict import Control.Carrier.Reader import Control.Carrier.State.Strict -import Control.Effect.Sketch +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 qualified Data.ScopeGraph as ScopeGraph import Data.Semilattice.Lower -import qualified ScopeGraph.Properties.Declaration as Props import Source.Span import qualified System.Path as Path @@ -56,7 +57,7 @@ instance Lower Sketchbook where newtype SketchC address m a = SketchC (StateC Sketchbook (FreshC m) a) deriving (Applicative, Functor, Monad, MonadIO) -instance (Effect sig, Algebra sig m) => Algebra (SketchEff :+: Reader Name :+: Fresh :+: sig) (SketchC Name m) where +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 @@ -92,6 +93,12 @@ instance (Effect sig, Algebra sig m) => Algebra (SketchEff :+: Reader Name :+: F 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 diff --git a/semantic-scope-graph/src/Control/Effect/Sketch.hs b/semantic-scope-graph/src/Control/Effect/ScopeGraph.hs similarity index 67% rename from semantic-scope-graph/src/Control/Effect/Sketch.hs rename to semantic-scope-graph/src/Control/Effect/ScopeGraph.hs index c33d40e04..7774c9c0b 100644 --- a/semantic-scope-graph/src/Control/Effect/Sketch.hs +++ b/semantic-scope-graph/src/Control/Effect/ScopeGraph.hs @@ -8,15 +8,16 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | The Sketch effect is used to build up a scope graph over +-- | The ScopeGraph effect is used to build up a scope graph over -- the lifetime of a monadic computation. The name is meant to evoke -- physically sketching the hierarchical outline of a graph. -module Control.Effect.Sketch - ( Sketch - , SketchEff (..) +module Control.Effect.ScopeGraph + ( ScopeGraph + , ScopeGraphEff (..) , declare -- Scope Manipulation , currentScope + , insertEdge , newScope , withScope , declareFunction @@ -30,40 +31,47 @@ import qualified Analysis.Name as Name import Control.Algebra import Control.Effect.Fresh import Control.Effect.Reader +import Data.List.NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.ScopeGraph as ScopeGraph import Data.Text (Text) import GHC.Generics (Generic, Generic1) -import qualified ScopeGraph.Properties.Declaration as Props -import qualified ScopeGraph.Properties.Function as Props -import qualified ScopeGraph.Properties.Reference as Props -type Sketch - = SketchEff +import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props +import qualified Control.Effect.ScopeGraph.Properties.Function as Props +import qualified Control.Effect.ScopeGraph.Properties.Reference as Props + +type ScopeGraph + = ScopeGraphEff :+: Fresh :+: Reader Name -data SketchEff m k = +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) currentScope :: Has (Reader Name) sig m => m Name currentScope = ask -declare :: forall sig m . (Has Sketch sig m) => Name -> Props.Declaration -> m () +declare :: forall sig m . (Has ScopeGraph sig m) => Name -> Props.Declaration -> m () declare n props = send (Declare n props pure) -- | Establish a reference to a prior declaration. -reference :: forall sig m . (Has Sketch sig m) => Text -> Text -> Props.Reference -> m () +reference :: forall sig m . (Has ScopeGraph sig m) => Text -> Text -> Props.Reference -> m () reference n decl props = send (Reference n decl props pure) -newScope :: forall sig m . (Has Sketch sig m) => Map ScopeGraph.EdgeLabel [Name] -> m Name +newScope :: forall sig m . Has ScopeGraph sig m => Map ScopeGraph.EdgeLabel [Name] -> m Name newScope edges = send (NewScope edges pure) -declareFunction :: forall sig m . (Has Sketch sig m) => Maybe Name -> Props.Function -> m (Name, Name) +-- | Takes an edge label and a list of names and inserts an import edge to a hole. +insertEdge :: Has ScopeGraph sig m => ScopeGraph.EdgeLabel -> NonEmpty Name -> m () +insertEdge label targets = send (InsertEdge label targets pure) + +declareFunction :: forall sig m . (Has ScopeGraph 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' ] @@ -76,7 +84,7 @@ declareFunction name (Props.Function kind span) = do } pure (name', associatedScope) -declareMaybeName :: Has Sketch sig m +declareMaybeName :: Has ScopeGraph sig m => Maybe Name -> Props.Declaration -> m Name @@ -87,9 +95,8 @@ declareMaybeName maybeName props = do name <- Name.gensym name <$ declare name (props { Props.relation = ScopeGraph.Gensym }) -withScope :: Has Sketch sig m +withScope :: Has ScopeGraph sig m => Name -> m a -> m a withScope scope = local (const scope) - diff --git a/semantic-scope-graph/src/ScopeGraph/Properties/Declaration.hs b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Declaration.hs similarity index 93% rename from semantic-scope-graph/src/ScopeGraph/Properties/Declaration.hs rename to semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Declaration.hs index 3ea7aca37..96ac1bc1c 100644 --- a/semantic-scope-graph/src/ScopeGraph/Properties/Declaration.hs +++ b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Declaration.hs @@ -5,7 +5,7 @@ -- | The 'Declaration' record type is used by the 'Control.Effect.Sketch' module to keep -- track of the parameters that need to be passed when establishing a new declaration. -- That is to say, it is a record type primarily used for its selector names. -module ScopeGraph.Properties.Declaration +module Control.Effect.ScopeGraph.Properties.Declaration ( Declaration (..) ) where diff --git a/semantic-scope-graph/src/ScopeGraph/Properties/Function.hs b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Function.hs similarity index 92% rename from semantic-scope-graph/src/ScopeGraph/Properties/Function.hs rename to semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Function.hs index 9146455b8..50d56356b 100644 --- a/semantic-scope-graph/src/ScopeGraph/Properties/Function.hs +++ b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Function.hs @@ -5,7 +5,7 @@ -- | The 'Function' record type is used by the 'Control.Effect.Sketch' module to keep -- track of the parameters that need to be passed when establishing a new declaration. -- That is to say, it is a record type primarily used for its selector names. -module ScopeGraph.Properties.Function +module Control.Effect.ScopeGraph.Properties.Function ( Function (..) ) where diff --git a/semantic-scope-graph/src/ScopeGraph/Properties/Reference.hs b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Reference.hs similarity index 86% rename from semantic-scope-graph/src/ScopeGraph/Properties/Reference.hs rename to semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Reference.hs index 84f598efe..ab0b92e38 100644 --- a/semantic-scope-graph/src/ScopeGraph/Properties/Reference.hs +++ b/semantic-scope-graph/src/Control/Effect/ScopeGraph/Properties/Reference.hs @@ -2,7 +2,7 @@ -- track of the parameters that need to be passed when establishing a new reference. -- It is currently unused, but will possess more fields in the future as scope graph -- functionality is enhanced. -module ScopeGraph.Properties.Reference +module Control.Effect.ScopeGraph.Properties.Reference ( Reference (..) ) where diff --git a/semantic-scope-graph/src/Data/ScopeGraph.hs b/semantic-scope-graph/src/Data/ScopeGraph.hs index c4241702d..e85e3931b 100644 --- a/semantic-scope-graph/src/Data/ScopeGraph.hs +++ b/semantic-scope-graph/src/Data/ScopeGraph.hs @@ -1,432 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} module Data.ScopeGraph - ( Slot(..) - , Info(..) - , associatedScope - , lookupDeclaration - , declarationByName - , declarationsByAccessControl - , declarationsByRelation - , Declaration(..) -- TODO don't export these constructors - , declare - , formatDeclaration - , EdgeLabel(..) - , insertDeclarationScope - , insertDeclarationSpan - , insertImportReference - , newScope - , newPreludeScope - , insertScope - , insertEdge - , Path(..) - , pathDeclaration - , pathOfRef - , pathPosition - , Position(..) - , reference - , Reference(..) -- TODO don't export these constructors - , ReferenceInfo(..) - , Relation(..) - , ScopeGraph(..) - , Kind(..) - , lookupScope - , lookupScopePath - , Scope(..) - , scopeOfRef - , pathDeclarationScope - , putDeclarationScopeAtPosition - , declarationNames - , AccessControl(..) + ( module Scope.Info + , module Scope.Path + , module Scope.Scope + , module Scope.Types + , module Scope.Graph.AdjacencyList ) where -import Prelude hiding (lookup) - -import Analysis.Name -import Control.Applicative -import Control.Lens.Lens -import Control.Monad -import Data.Aeson -import Data.Bifunctor -import Data.Foldable -import Data.Hashable -import Data.Hole -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Module -import Data.Monoid -import Data.Semilattice.Lower -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import GHC.Generics -import Source.Span - --- A slot is a location in the heap where a value is stored. -data Slot address = Slot { frameAddress :: address, position :: Position } - deriving (Eq, Show, Ord) - - -data AccessControl = Public - | Protected - | Private - deriving (Bounded, Enum, Eq, Generic, Hashable, ToJSON, Show) - --- | The Ord AccessControl instance represents an order specification of AccessControls. --- AccessControls that are less than or equal to another AccessControl implies access. --- It is helpful to consider `Public <= Private` as saying "Can a Public syntax term access a Private syntax term?" --- In this way, Public AccessControl is the top of the order specification, and Private AccessControl is the bottom. -instance Ord AccessControl where - -- | Private AccessControl represents the least overlap or accessibility with other AccessControls. - -- When asking if the AccessControl "on the left" is less than the AccessControl "on the right", Private AccessControl on the left always implies access to the thing on the right. - (<=) Private _ = True - (<=) _ Private = False - - -- | Protected AccessControl is in between Private and Public in the order specification. - -- Protected AccessControl "on the left" has access to Protected or Public AccessControls "on the right". - (<=) Protected Public = True - (<=) Protected Protected = True - - -- | Public AccessControl "on the left" has access only to Public AccessControl "on the right". - (<=) Public Public = True - (<=) Public _ = False - - -data Relation = Default | Instance | Prelude | Gensym - deriving (Bounded, Enum, Eq, Show, Ord) - -instance Lower Relation where - lowerBound = Default - -data Info scopeAddress = Info - { infoDeclaration :: Declaration - , infoModule :: ModuleInfo - , infoRelation :: Relation - , infoAccessControl :: AccessControl - , infoSpan :: Span - , infoKind :: Kind - , infoAssociatedScope :: Maybe scopeAddress - } deriving (Eq, Show, Ord) - -instance HasSpan (Info scopeAddress) where - span_ = lens infoSpan (\i s -> i { infoSpan = s }) - {-# INLINE span_ #-} - -instance Lower (Info scopeAddress) where - lowerBound = Info lowerBound lowerBound lowerBound Public lowerBound lowerBound Nothing - -data ReferenceInfo = ReferenceInfo - { refSpan :: Span - , refKind :: Kind - , refModule :: ModuleInfo - } deriving (Eq, Show, Ord) - -instance HasSpan ReferenceInfo where - span_ = lens refSpan (\r s -> r { refSpan = s }) - {-# INLINE span_ #-} - -data Kind = AbstractClass - | Assignment - | Call - | Class - | DefaultExport - | Function - | Identifier - | Let - | MemberAccess - | Method - | Module - | New - | Parameter - | PublicField - | QualifiedAliasedImport - | QualifiedExport - | QualifiedImport - | RequiredParameter - | This - | TypeAlias - | TypeIdentifier - | Unknown - | UnqualifiedImport - | VariableDeclaration - deriving (Bounded, Enum, Eq, Show, Ord) - -instance Lower Kind where - lowerBound = Unknown - -data Domain - = Standard - | Preluded - deriving (Eq, Show, Ord) - --- Offsets and frame addresses in the heap should be addresses? -data Scope address = Scope - { edges :: Map EdgeLabel [address] - , references :: Map Reference ([ReferenceInfo], Path address) - , declarations :: Seq (Info address) - , domain :: Domain - } deriving (Eq, Show, Ord) - -instance Lower (Scope scopeAddress) where - lowerBound = Scope mempty mempty mempty Standard - -instance AbstractHole (Scope scopeAddress) where - hole = lowerBound - -instance AbstractHole address => AbstractHole (Slot address) where - hole = Slot hole (Position 0) - -instance AbstractHole (Info address) where - hole = lowerBound - -newtype Position = Position { unPosition :: Int } - deriving (Eq, Show, Ord) - -newtype ScopeGraph scope = ScopeGraph { unScopeGraph :: Map scope (Scope scope) } - deriving (Eq, Ord, Show) - -instance Ord scope => Lower (ScopeGraph scope) where - lowerBound = ScopeGraph mempty - -data Path scope - = Hole - -- | Construct a direct path to a declaration. - | DPath Declaration Position - -- | Construct an edge from a scope to another declaration path. - | EPath EdgeLabel scope (Path scope) - deriving (Eq, Functor, Ord, Show) - -instance AbstractHole (Path scope) where - hole = Hole - --- Returns the declaration of a path. -pathDeclaration :: Path scope -> Declaration -pathDeclaration (DPath d _) = d -pathDeclaration (EPath _ _ p) = pathDeclaration p -pathDeclaration Hole = undefined - --- TODO: Store the current scope closer _in_ the DPath? -pathDeclarationScope :: scope -> Path scope -> Maybe scope -pathDeclarationScope _ (EPath _ scope (DPath _ _)) = Just scope -pathDeclarationScope currentScope (EPath _ _ p) = pathDeclarationScope currentScope p -pathDeclarationScope currentScope (DPath _ _) = Just currentScope -pathDeclarationScope _ Hole = Nothing - --- TODO: Possibly return in Maybe since we can have Hole paths -pathPosition :: Path scope -> Position -pathPosition Hole = Position 0 -pathPosition (DPath _ p) = p -pathPosition (EPath _ _ p) = pathPosition p - --- Returns the reference paths of a scope in a scope graph. -pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference ([ReferenceInfo], Path scope)) -pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph - --- Returns the declaration data of a scope in a scope graph. -ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Seq (Info scope)) -ddataOfScope scope = fmap declarations . Map.lookup scope . unScopeGraph - --- Returns the edges of a scope in a scope graph. -linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) -linksOfScope scope = fmap edges . Map.lookup scope . unScopeGraph - -declarationsByAccessControl :: Ord scope => scope -> AccessControl -> ScopeGraph scope -> [ Info scope ] -declarationsByAccessControl scope accessControl g = fromMaybe mempty $ do - dataSeq <- ddataOfScope scope g - pure . toList $ Seq.filter (\Info{..} -> accessControl <= infoAccessControl) dataSeq - -declarationsByRelation :: Ord scope => scope -> Relation -> ScopeGraph scope -> [ Info scope ] -declarationsByRelation scope relation g = fromMaybe mempty $ do - dataSeq <- ddataOfScope scope g - pure . toList $ Seq.filter (\Info{..} -> infoRelation == relation) dataSeq - -declarationByName :: Ord scope => scope -> Declaration -> ScopeGraph scope -> Maybe (Info scope) -declarationByName scope name g = do - dataSeq <- ddataOfScope scope g - find (\Info{..} -> infoDeclaration == name) dataSeq - --- Lookup a scope in the scope graph. -lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) -lookupScope scope = Map.lookup scope . unScopeGraph - --- Declare a declaration with a span and an associated scope in the scope graph. --- TODO: Return the whole value in Maybe or Either. -declare :: Ord scope - => Declaration - -> ModuleInfo - -> Relation - -> AccessControl - -> Span - -> Kind - -> Maybe scope - -> scope - -> ScopeGraph scope - -> (ScopeGraph scope, Maybe Position) -declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do - scope <- lookupScope currentScope g - dataSeq <- ddataOfScope currentScope g - case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of - Just index -> pure (g, Just (Position index)) - Nothing -> do - let newScope = scope { declarations = declarations scope Seq.|> Info decl moduleInfo rel accessControl declSpan kind assocScope } - pure (insertScope currentScope newScope g, Just (Position (length (declarations newScope)))) - --- | Add a reference to a declaration in the scope graph. --- Returns the original scope graph if the declaration could not be found. -reference :: Ord scope => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> scope -> ScopeGraph scope -> ScopeGraph scope -reference ref moduleInfo span kind decl currentAddress g = fromMaybe g $ do - -- Start from the current address - currentScope' <- lookupScope currentAddress g - -- Build a path up to the declaration - flip (insertScope currentAddress) g . flip (insertReference ref moduleInfo span kind) currentScope' <$> findPath (const Nothing) decl currentAddress g - --- | Insert a reference into the given scope by constructing a resolution path to the declaration within the given scope graph. -insertImportReference :: Ord address => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> address -> ScopeGraph address -> Scope address -> Maybe (Scope address) -insertImportReference ref moduleInfo span kind decl currentAddress g scope = flip (insertReference ref moduleInfo span kind) scope . EPath Import currentAddress <$> findPath (const Nothing) decl currentAddress g - -lookupScopePath :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) -lookupScopePath declaration currentAddress g = findPath (flip (lookupReference declaration) g) (Declaration declaration) currentAddress g - -findPath :: Ord scopeAddress => (scopeAddress -> Maybe (Path scopeAddress)) -> Declaration -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) -findPath extra decl currentAddress g = snd <$> getFirst (foldGraph combine currentAddress g) - where combine address path = fmap (address, ) - $ First (pathToDeclaration decl address g) - <> First (extra address) - <> (uncurry (EPath Superclass) <$> path Superclass) - <> (uncurry (EPath Import) <$> path Import) - <> (uncurry (EPath Export) <$> path Export) - <> (uncurry (EPath Lexical) <$> path Lexical) - -foldGraph :: (Ord scopeAddress, Monoid a) => (scopeAddress -> (EdgeLabel -> a) -> a) -> scopeAddress -> ScopeGraph scopeAddress -> a -foldGraph combine address graph = go lowerBound address - where go visited address - | address `Set.notMember` visited - , Just edges <- linksOfScope address graph = combine address (recur edges) - | otherwise = mempty - where visited' = Set.insert address visited - recur edges edge = maybe mempty (foldMap (go visited')) (Map.lookup edge edges) - -pathToDeclaration :: Ord scopeAddress => Declaration -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) -pathToDeclaration decl address g = DPath decl . snd <$> lookupDeclaration (unDeclaration decl) address g - -insertReference :: Reference -> ModuleInfo -> Span -> Kind -> Path scopeAddress -> Scope scopeAddress -> Scope scopeAddress -insertReference ref moduleInfo span kind path scope = scope { references = Map.alter (\case - Nothing -> pure ([ ReferenceInfo span kind moduleInfo ], path) - Just (refInfos, path) -> pure (ReferenceInfo span kind moduleInfo : refInfos, path)) ref (references scope) } - -lookupDeclaration :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Info scopeAddress, Position) -lookupDeclaration name scope g = do - dataSeq <- ddataOfScope scope g - index <- Seq.findIndexR (\Info{..} -> Declaration name == infoDeclaration) dataSeq - (, Position index) <$> Seq.lookup index dataSeq - -declarationNames :: Ord address => [EdgeLabel] -> Scope address -> ScopeGraph address -> Set Declaration -declarationNames edgeLabels scope scopeGraph = localDeclarations <> edgeNames - where addresses = join (Map.elems $ Map.restrictKeys (edges scope) (Set.fromList edgeLabels)) - edgeNames = flip foldMap addresses $ \address -> maybe mempty (flip (declarationNames edgeLabels) scopeGraph) (lookupScope address scopeGraph) - localDeclarations = Set.fromList . toList . fmap infoDeclaration $ declarations scope - - -putDeclarationScopeAtPosition :: Ord scopeAddress => scopeAddress -> Position -> Maybe scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress -putDeclarationScopeAtPosition scope position assocScope g@(ScopeGraph graph) = fromMaybe g $ do - dataSeq <- ddataOfScope scope g - let seq = Seq.adjust' (\Info{..} -> Info { infoAssociatedScope = assocScope, .. }) (unPosition position) dataSeq - pure $ ScopeGraph (Map.adjust (\s -> s { declarations = seq }) scope graph) - -lookupReference :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) -lookupReference name scope g = fmap snd . Map.lookup (Reference name) =<< pathsOfScope scope g - -insertEdge :: Ord scopeAddress => EdgeLabel -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress -insertEdge label target currentAddress g@(ScopeGraph graph) = fromMaybe g $ do - currentScope' <- lookupScope currentAddress g - scopes <- maybe (Just mempty) pure (Map.lookup label (edges currentScope')) - let newScope = currentScope' { edges = Map.insert label (target : scopes) (edges currentScope') } - pure (ScopeGraph (Map.insert currentAddress newScope graph)) - - --- | Update the 'Scope' containing a 'Declaration' with an associated scope address. --- Returns an unmodified 'ScopeGraph' if the 'Declaration' cannot be found with the given scope address. -insertDeclarationScope :: Ord scopeAddress => Declaration -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress -insertDeclarationScope Declaration{..} associatedScopeAddress scopeAddress g = fromMaybe g $ do - declScopeAddress <- pathDeclarationScope scopeAddress =<< lookupScopePath unDeclaration scopeAddress g - scope <- lookupScope declScopeAddress g - (declInfo, position) <- second unPosition <$> lookupDeclaration unDeclaration declScopeAddress g - pure $ insertScope declScopeAddress (scope { declarations = Seq.update position (declInfo { infoAssociatedScope = Just associatedScopeAddress }) (declarations scope) }) g - --- | Insert a declaration span into the declaration in the scope graph. -insertDeclarationSpan :: Ord scopeAddress => Declaration -> Span -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress -insertDeclarationSpan decl@Declaration{..} span g = fromMaybe g $ do - declScopeAddress <- scopeOfDeclaration decl g - (declInfo, position) <- second unPosition <$> lookupDeclaration unDeclaration declScopeAddress g - scope <- lookupScope declScopeAddress g - pure $ insertScope declScopeAddress (scope { declarations = Seq.update position (declInfo { infoSpan = span }) (declarations scope) }) g - --- | Insert a new scope with the given address and edges into the scope graph. -newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address -newScope address edges = insertScope address (Scope edges mempty mempty Standard) - --- | Insert a new scope with the given address and edges into the scope graph. -newPreludeScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address -newPreludeScope address edges = insertScope address (Scope edges mempty mempty Preluded) - -insertScope :: Ord address => address -> Scope address -> ScopeGraph address -> ScopeGraph address -insertScope address scope = ScopeGraph . Map.insert address scope . unScopeGraph - --- | Returns the scope of a reference in the scope graph. -scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope -scopeOfRef ref g@(ScopeGraph graph) = go (Map.keys graph) - where - go (s : scopes') = fromMaybe (go scopes') $ do - pathMap <- pathsOfScope s g - _ <- Map.lookup ref pathMap - pure (Just s) - go [] = Nothing - --- | Returns the path of a reference in the scope graph. -pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope) -pathOfRef ref graph = do - scope <- scopeOfRef ref graph - pathsMap <- pathsOfScope scope graph - snd <$> Map.lookup ref pathsMap - --- Returns the scope the declaration was declared in. -scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope -scopeOfDeclaration Declaration{..} g@(ScopeGraph graph) = go (Map.keys graph) - where - go = foldr (\ scope -> (scope <$ lookupDeclaration unDeclaration scope g <|>)) Nothing - --- | Returns the scope associated with a declaration (the child scope if any exists). -associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope -associatedScope Declaration{..} g@(ScopeGraph graph) = go (Map.keys graph) - where - go = foldr lookupAssociatedScope Nothing - lookupAssociatedScope scope = ((lookupDeclaration unDeclaration scope g >>= infoAssociatedScope . fst) <|>) - -newtype Reference = Reference { unReference :: Name } - deriving (Eq, Ord, Show) - -instance Lower Reference where - lowerBound = Reference $ name "" - -newtype Declaration = Declaration { unDeclaration :: Name } - deriving (Eq, Ord, Show) - -instance Lower Declaration where - lowerBound = Declaration $ name "" - -formatDeclaration :: Declaration -> Text -formatDeclaration = formatName . unDeclaration - --- | The type of edge from a scope to its parent scopes. --- Either a lexical edge or an import edge in the case of non-lexical edges. -data EdgeLabel = Lexical | Import | Export | Superclass - deriving (Bounded, Enum, Eq, Ord, Show) +import Scope.Graph.AdjacencyList +import Scope.Info +import Scope.Path +import Scope.Scope +import Scope.Types diff --git a/semantic-scope-graph/src/Scope/Graph/AdjacencyList.hs b/semantic-scope-graph/src/Scope/Graph/AdjacencyList.hs new file mode 100644 index 000000000..a585ee5ec --- /dev/null +++ b/semantic-scope-graph/src/Scope/Graph/AdjacencyList.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Scope.Graph.AdjacencyList + ( module Scope.Graph.AdjacencyList + ) where + +import Analysis.Name +import Control.Applicative +import Control.Monad +import Data.Bifunctor +import Data.Foldable +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Module +import Data.Monoid +import Data.Semilattice.Lower +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Scope.Info +import Scope.Path +import Scope.Reference +import Scope.Scope +import Scope.Types +import Source.Span + +newtype ScopeGraph scope = ScopeGraph { unScopeGraph :: Map scope (Scope scope) } + deriving (Eq, Ord, Show) + +instance Ord scope => Lower (ScopeGraph scope) where + lowerBound = ScopeGraph mempty + +-- Returns the reference paths of a scope in a scope graph. +pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference ([ReferenceInfo], Path scope)) +pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph + +-- Returns the declaration data of a scope in a scope graph. +ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Seq (Info scope)) +ddataOfScope scope = fmap declarations . Map.lookup scope . unScopeGraph + +-- Returns the edges of a scope in a scope graph. +linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) +linksOfScope scope = fmap edges . Map.lookup scope . unScopeGraph + +declarationsByAccessControl :: Ord scope => scope -> AccessControl -> ScopeGraph scope -> [ Info scope ] +declarationsByAccessControl scope accessControl g = fromMaybe mempty $ do + dataSeq <- ddataOfScope scope g + pure . toList $ Seq.filter (\Info{..} -> accessControl <= infoAccessControl) dataSeq + +declarationsByRelation :: Ord scope => scope -> Relation -> ScopeGraph scope -> [ Info scope ] +declarationsByRelation scope relation g = fromMaybe mempty $ do + dataSeq <- ddataOfScope scope g + pure . toList $ Seq.filter (\Info{..} -> infoRelation == relation) dataSeq + +declarationByName :: Ord scope => scope -> Declaration -> ScopeGraph scope -> Maybe (Info scope) +declarationByName scope name g = do + dataSeq <- ddataOfScope scope g + find (\Info{..} -> infoDeclaration == name) dataSeq + +-- Lookup a scope in the scope graph. +lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) +lookupScope scope = Map.lookup scope . unScopeGraph + +-- Declare a declaration with a span and an associated scope in the scope graph. +-- TODO: Return the whole value in Maybe or Either. +declare :: Ord scope + => Declaration + -> ModuleInfo + -> Relation + -> AccessControl + -> Span + -> Kind + -> Maybe scope + -> scope + -> ScopeGraph scope + -> (ScopeGraph scope, Maybe Position) +declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do + scope <- lookupScope currentScope g + dataSeq <- ddataOfScope currentScope g + case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of + Just index -> pure (g, Just (Position index)) + Nothing -> do + let newScope = scope { declarations = declarations scope Seq.|> Info decl moduleInfo rel accessControl declSpan kind assocScope } + pure (insertScope currentScope newScope g, Just (Position (length (declarations newScope)))) + +-- | Add a reference to a declaration in the scope graph. +-- Returns the original scope graph if the declaration could not be found. +reference :: Ord scope => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> scope -> ScopeGraph scope -> ScopeGraph scope +reference ref moduleInfo span kind decl currentAddress g = fromMaybe g $ do + -- Start from the current address + currentScope' <- lookupScope currentAddress g + -- Build a path up to the declaration + flip (insertScope currentAddress) g . flip (insertReference ref moduleInfo span kind) currentScope' <$> findPath (const Nothing) decl currentAddress g + +-- | Insert a reference into the given scope by constructing a resolution path to the declaration within the given scope graph. +insertImportReference :: Ord address => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> address -> ScopeGraph address -> Scope address -> Maybe (Scope address) +insertImportReference ref moduleInfo span kind decl currentAddress g scope = flip (insertReference ref moduleInfo span kind) scope . EPath Import currentAddress <$> findPath (const Nothing) decl currentAddress g + +lookupScopePath :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) +lookupScopePath declaration currentAddress g = findPath (flip (lookupReference declaration) g) (Declaration declaration) currentAddress g + +findPath :: Ord scopeAddress => (scopeAddress -> Maybe (Path scopeAddress)) -> Declaration -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) +findPath extra decl currentAddress g = snd <$> getFirst (foldGraph combine currentAddress g) + where combine address path = fmap (address, ) + $ First (pathToDeclaration decl address g) + <> First (extra address) + <> (uncurry (EPath Superclass) <$> path Superclass) + <> (uncurry (EPath Import) <$> path Import) + <> (uncurry (EPath Export) <$> path Export) + <> (uncurry (EPath Lexical) <$> path Lexical) + +foldGraph :: (Ord scopeAddress, Monoid a) => (scopeAddress -> (EdgeLabel -> a) -> a) -> scopeAddress -> ScopeGraph scopeAddress -> a +foldGraph combine address graph = go lowerBound address + where go visited address + | address `Set.notMember` visited + , Just edges <- linksOfScope address graph = combine address (recur edges) + | otherwise = mempty + where visited' = Set.insert address visited + recur edges edge = maybe mempty (foldMap (go visited')) (Map.lookup edge edges) + +pathToDeclaration :: Ord scopeAddress => Declaration -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress) +pathToDeclaration decl address g = DPath decl . snd <$> lookupDeclaration (unDeclaration decl) address g + +insertReference :: Reference -> ModuleInfo -> Span -> Kind -> Path scopeAddress -> Scope scopeAddress -> Scope scopeAddress +insertReference ref moduleInfo span kind path scope = scope { references = Map.alter (\case + Nothing -> pure ([ ReferenceInfo span kind moduleInfo ], path) + Just (refInfos, path) -> pure (ReferenceInfo span kind moduleInfo : refInfos, path)) ref (references scope) } + +lookupDeclaration :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Info scopeAddress, Position) +lookupDeclaration name scope g = do + dataSeq <- ddataOfScope scope g + index <- Seq.findIndexR (\Info{..} -> Declaration name == infoDeclaration) dataSeq + (, Position index) <$> Seq.lookup index dataSeq + +declarationNames :: Ord address => [EdgeLabel] -> Scope address -> ScopeGraph address -> Set Declaration +declarationNames edgeLabels scope scopeGraph = localDeclarations <> edgeNames + where addresses = join (Map.elems $ Map.restrictKeys (edges scope) (Set.fromList edgeLabels)) + edgeNames = flip foldMap addresses $ \address -> maybe mempty (flip (declarationNames edgeLabels) scopeGraph) (lookupScope address scopeGraph) + localDeclarations = Set.fromList . toList . fmap infoDeclaration $ declarations scope + + +putDeclarationScopeAtPosition :: Ord scopeAddress => scopeAddress -> Position -> Maybe scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +putDeclarationScopeAtPosition scope position assocScope g@(ScopeGraph graph) = fromMaybe g $ do + dataSeq <- ddataOfScope scope g + let seq = Seq.adjust' (\Info{..} -> Info { infoAssociatedScope = assocScope, .. }) (unPosition position) dataSeq + pure $ ScopeGraph (Map.adjust (\s -> s { declarations = seq }) scope graph) + +-- | Lookup a reference by traversing the paths of a given scope and return a Maybe (Path address) +lookupReference :: Ord address => Name -> address -> ScopeGraph address -> Maybe (Path address) +lookupReference name scope g = fmap snd . Map.lookup (Reference name) =<< pathsOfScope scope g + +insertEdge :: Ord scopeAddress => EdgeLabel -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +insertEdge label target currentAddress g@(ScopeGraph graph) = fromMaybe g $ do + currentScope' <- lookupScope currentAddress g + scopes <- maybe (Just mempty) pure (Map.lookup label (edges currentScope')) + let newScope = currentScope' { edges = Map.insert label (target : scopes) (edges currentScope') } + pure (ScopeGraph (Map.insert currentAddress newScope graph)) + +insertEdges :: Ord scopeAddress => NonEmpty EdgeLabel -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +insertEdges labels target currentAddress g = + foldr (\label graph -> insertEdge label target currentAddress graph) g labels + +-- | Add an import edge of the form 'a -> Import -> b -> Import -> c' or creates intermediate void scopes of the form +-- 'a -> Void -> b -> Import -> c' if the given scopes cannot be found. +addImportEdge :: Ord scopeAddress => EdgeLabel -> [scopeAddress] -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +addImportEdge edge importEdge currentAddress g = do + case importEdge of + [] -> g + (name:[]) -> maybe + (addImportHole edge name currentAddress g) + (const (insertEdge edge name currentAddress g)) + (lookupScope name g) + (name:names) -> let + scopeGraph' = maybe + (addImportHole edge name currentAddress g) + (const (insertEdge edge name currentAddress g)) + (lookupScope name g) + in + addImportEdge edge names name scopeGraph' + +addImportHole :: Ord scopeAddress => EdgeLabel -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +addImportHole edge name currentAddress g = let + scopeGraph' = newScope name mempty g + in + insertEdges (NonEmpty.fromList [Void, edge]) name currentAddress scopeGraph' + + +-- | Update the 'Scope' containing a 'Declaration' with an associated scope address. +-- Returns an unmodified 'ScopeGraph' if the 'Declaration' cannot be found with the given scope address. +insertDeclarationScope :: Ord scopeAddress => Declaration -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +insertDeclarationScope Declaration{..} associatedScopeAddress scopeAddress g = fromMaybe g $ do + declScopeAddress <- pathDeclarationScope scopeAddress =<< lookupScopePath unDeclaration scopeAddress g + scope <- lookupScope declScopeAddress g + (declInfo, position) <- second unPosition <$> lookupDeclaration unDeclaration declScopeAddress g + pure $ insertScope declScopeAddress (scope { declarations = Seq.update position (declInfo { infoAssociatedScope = Just associatedScopeAddress }) (declarations scope) }) g + +-- | Insert a declaration span into the declaration in the scope graph. +insertDeclarationSpan :: Ord scopeAddress => Declaration -> Span -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress +insertDeclarationSpan decl@Declaration{..} span g = fromMaybe g $ do + declScopeAddress <- scopeOfDeclaration decl g + (declInfo, position) <- second unPosition <$> lookupDeclaration unDeclaration declScopeAddress g + scope <- lookupScope declScopeAddress g + pure $ insertScope declScopeAddress (scope { declarations = Seq.update position (declInfo { infoSpan = span }) (declarations scope) }) g + +-- | Insert a new scope with the given address and edges into the scope graph. +newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address +newScope address edges = insertScope address (Scope edges mempty mempty Standard) + +-- | Insert a new scope with the given address and edges into the scope graph. +newPreludeScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address +newPreludeScope address edges = insertScope address (Scope edges mempty mempty Preluded) + +insertScope :: Ord address => address -> Scope address -> ScopeGraph address -> ScopeGraph address +insertScope address scope = ScopeGraph . Map.insert address scope . unScopeGraph + +-- | Returns the scope of a reference in the scope graph. +scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope +scopeOfRef ref g@(ScopeGraph graph) = go (Map.keys graph) + where + go (s : scopes') = fromMaybe (go scopes') $ do + pathMap <- pathsOfScope s g + _ <- Map.lookup ref pathMap + pure (Just s) + go [] = Nothing + +-- | Returns the path of a reference in the scope graph. +pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope) +pathOfRef ref graph = do + scope <- scopeOfRef ref graph + pathsMap <- pathsOfScope scope graph + snd <$> Map.lookup ref pathsMap + +-- Returns the scope the declaration was declared in. +scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope +scopeOfDeclaration Declaration{..} g@(ScopeGraph graph) = go (Map.keys graph) + where + go = foldr (\ scope -> (scope <$ lookupDeclaration unDeclaration scope g <|>)) Nothing + +-- | Returns the scope associated with a declaration (the child scope if any exists). +associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope +associatedScope Declaration{..} g@(ScopeGraph graph) = go (Map.keys graph) + where + go = foldr lookupAssociatedScope Nothing + lookupAssociatedScope scope = ((lookupDeclaration unDeclaration scope g >>= infoAssociatedScope . fst) <|>) diff --git a/semantic-scope-graph/src/ScopeGraph/Convert.hs b/semantic-scope-graph/src/Scope/Graph/Convert.hs similarity index 91% rename from semantic-scope-graph/src/ScopeGraph/Convert.hs rename to semantic-scope-graph/src/Scope/Graph/Convert.hs index 4149cea9b..b0303518e 100644 --- a/semantic-scope-graph/src/ScopeGraph/Convert.hs +++ b/semantic-scope-graph/src/Scope/Graph/Convert.hs @@ -6,21 +6,21 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module ScopeGraph.Convert +module Scope.Graph.Convert ( ToScopeGraph (..) , Result (..) , todo , complete ) where -import Control.Effect.Sketch +import Control.Effect.ScopeGraph import Data.List.NonEmpty import Data.Typeable import Source.Loc class Typeable t => ToScopeGraph t where scopeGraph :: - ( Has Sketch sig m + ( Has ScopeGraph sig m ) => t Loc -> m Result diff --git a/semantic-scope-graph/src/Scope/Info.hs b/semantic-scope-graph/src/Scope/Info.hs new file mode 100644 index 000000000..c735b0ab9 --- /dev/null +++ b/semantic-scope-graph/src/Scope/Info.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Scope.Info + ( Info (..) + , Declaration (..) + , formatDeclaration + , Relation (..) + , Kind (..) + , AccessControl (..) + ) where + +import Analysis.Name +import Data.Generics.Product (field) +import Data.Hole +import Data.Module +import Data.Semilattice.Lower +import Data.Text (Text) +import GHC.Generics (Generic) +import Scope.Types +import Source.Span + +data Info scopeAddress = Info + { infoDeclaration :: Declaration + , infoModule :: ModuleInfo + , infoRelation :: Relation + , infoAccessControl :: AccessControl + , infoSpan :: Span + , infoKind :: Kind + , infoAssociatedScope :: Maybe scopeAddress + } deriving (Eq, Show, Ord, Generic) + +instance HasSpan (Info scopeAddress) where + span_ = field @"infoSpan" + {-# INLINE span_ #-} + +instance Lower (Info scopeAddress) where + lowerBound = Info lowerBound lowerBound lowerBound Public lowerBound lowerBound Nothing + +instance AbstractHole (Info address) where + hole = lowerBound + +newtype Declaration = Declaration { unDeclaration :: Name } + deriving (Eq, Ord, Show) + +instance Lower Declaration where + lowerBound = Declaration $ name "" + +formatDeclaration :: Declaration -> Text +formatDeclaration = formatName . unDeclaration + + +data Relation = Default | Instance | Prelude | Gensym + deriving (Bounded, Enum, Eq, Show, Ord) + +instance Lower Relation where + lowerBound = Default + + diff --git a/semantic-scope-graph/src/Scope/Path.hs b/semantic-scope-graph/src/Scope/Path.hs new file mode 100644 index 000000000..a39e0ae00 --- /dev/null +++ b/semantic-scope-graph/src/Scope/Path.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveFunctor #-} +module Scope.Path + ( Path (..) + , pathDeclaration + , pathDeclarationScope + , pathPosition + ) where + +import Data.Hole +import Scope.Info +import Scope.Types + +data Path scope + = Hole + -- | Construct a direct path to a declaration. + | DPath Declaration Position + -- | Construct an edge from a scope to another declaration path. + | EPath EdgeLabel scope (Path scope) + deriving (Eq, Functor, Ord, Show) + +instance AbstractHole (Path scope) where + hole = Hole + +-- Returns the declaration of a path. +pathDeclaration :: Path scope -> Declaration +pathDeclaration (DPath d _) = d +pathDeclaration (EPath _ _ p) = pathDeclaration p +pathDeclaration Hole = undefined + +-- TODO: Store the current scope closer _in_ the DPath? +pathDeclarationScope :: scope -> Path scope -> Maybe scope +pathDeclarationScope _ (EPath _ scope (DPath _ _)) = Just scope +pathDeclarationScope currentScope (EPath _ _ p) = pathDeclarationScope currentScope p +pathDeclarationScope currentScope (DPath _ _) = Just currentScope +pathDeclarationScope _ Hole = Nothing + +-- TODO: Possibly return in Maybe since we can have Hole paths +pathPosition :: Path scope -> Position +pathPosition Hole = Position 0 +pathPosition (DPath _ p) = p +pathPosition (EPath _ _ p) = pathPosition p diff --git a/semantic-scope-graph/src/Scope/Reference.hs b/semantic-scope-graph/src/Scope/Reference.hs new file mode 100644 index 000000000..2b267f9c3 --- /dev/null +++ b/semantic-scope-graph/src/Scope/Reference.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scope.Reference + ( ReferenceInfo (..) + , Reference (..) + ) where + +import Analysis.Name +import Control.Lens (lens) +import Data.Module +import Data.Semilattice.Lower +import Scope.Types +import Source.Span + +data ReferenceInfo = ReferenceInfo + { refSpan :: Span + , refKind :: Kind + , refModule :: ModuleInfo + } deriving (Eq, Show, Ord) + +instance HasSpan ReferenceInfo where + span_ = lens refSpan (\r s -> r { refSpan = s }) + {-# INLINE span_ #-} + +newtype Reference = Reference { unReference :: Name } + deriving (Eq, Ord, Show) + +instance Lower Reference where + lowerBound = Reference $ name "" diff --git a/semantic-scope-graph/src/Scope/Scope.hs b/semantic-scope-graph/src/Scope/Scope.hs new file mode 100644 index 000000000..8d4947c61 --- /dev/null +++ b/semantic-scope-graph/src/Scope/Scope.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scope.Scope + ( Scope (..) + , Reference (..) + , ReferenceInfo (..) + , Domain (..) + ) where + +import Data.Hole +import Data.Map.Strict (Map) +import Data.Semilattice.Lower +import Data.Sequence (Seq) +import Scope.Info +import Scope.Path +import Scope.Reference +import Scope.Types + +-- Offsets and frame addresses in the heap should be addresses? +data Scope address = Scope + { edges :: Map EdgeLabel [address] + , references :: Map Reference ([ReferenceInfo], Path address) + , declarations :: Seq (Info address) + , domain :: Domain + } deriving (Eq, Show, Ord) + +instance Lower (Scope scopeAddress) where + lowerBound = Scope mempty mempty mempty Standard + +instance AbstractHole (Scope scopeAddress) where + hole = lowerBound diff --git a/semantic-scope-graph/src/Scope/Types.hs b/semantic-scope-graph/src/Scope/Types.hs new file mode 100644 index 000000000..45e1e9441 --- /dev/null +++ b/semantic-scope-graph/src/Scope/Types.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +module Scope.Types + ( Slot (..) + , EdgeLabel (..) + , Position (..) + , Domain (..) + , Kind (..) + , AccessControl (..) + ) where + +import Data.Aeson (ToJSON) +import Data.Hashable +import Data.Hole +import Data.Semilattice.Lower +import GHC.Generics (Generic) + +-- A slot is a location in the heap where a value is stored. +data Slot address = Slot { frameAddress :: address, position :: Position } + deriving (Eq, Show, Ord) + +instance AbstractHole address => AbstractHole (Slot address) where + hole = Slot hole (Position 0) + + +-- | The type of edge from a scope to its parent scopes. +-- Either a lexical edge or an import edge in the case of non-lexical edges. +data EdgeLabel = Lexical | Import | Export | Superclass | Void + deriving (Bounded, Enum, Eq, Ord, Show) + + +newtype Position = Position { unPosition :: Int } + deriving (Eq, Show, Ord) + + +data Domain + = Standard + | Preluded + deriving (Eq, Show, Ord) + + +data Kind = AbstractClass + | Assignment + | Call + | Class + | DefaultExport + | Function + | Identifier + | Let + | MemberAccess + | Method + | Module + | New + | Parameter + | PublicField + | QualifiedAliasedImport + | QualifiedExport + | QualifiedImport + | RequiredParameter + | This + | TypeAlias + | TypeIdentifier + | Unknown + | UnqualifiedImport + | VariableDeclaration + deriving (Bounded, Enum, Eq, Show, Ord) + +instance Lower Kind where + lowerBound = Unknown + + +data AccessControl = Public + | Protected + | Private + deriving (Bounded, Enum, Eq, Generic, Hashable, ToJSON, Show) + +-- | The Ord AccessControl instance represents an order specification of AccessControls. +-- AccessControls that are less than or equal to another AccessControl implies access. +-- It is helpful to consider `Public <= Private` as saying "Can a Public syntax term access a Private syntax term?" +-- In this way, Public AccessControl is the top of the order specification, and Private AccessControl is the bottom. +instance Ord AccessControl where + -- | Private AccessControl represents the least overlap or accessibility with other AccessControls. + -- When asking if the AccessControl "on the left" is less than the AccessControl "on the right", Private AccessControl on the left always implies access to the thing on the right. + (<=) Private _ = True + (<=) _ Private = False + + -- | Protected AccessControl is in between Private and Public in the order specification. + -- Protected AccessControl "on the left" has access to Protected or Public AccessControls "on the right". + (<=) Protected Public = True + (<=) Protected Protected = True + + -- | Public AccessControl "on the left" has access only to Public AccessControl "on the right". + (<=) Public Public = True + (<=) Public _ = False diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index ed1c77bde..73a828331 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -34,7 +34,7 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as Map import Control.Abstract hiding - (Array (..), Boolean (..), Function (..), Hash (..), Numeric (..), Object (..), String (..), Unit (..), While (..)) + (Array (..), Boolean (..), Function (..), Hash (..), Numeric (..), Object (..), String (..), Unit (..), While (..), Void) import qualified Control.Abstract as Abstract import Data.Abstract.BaseError import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bf5915f49..486401303 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -14,7 +14,7 @@ module Data.Syntax.Expression (module Data.Syntax.Expression) where import Prelude hiding (null) import Analysis.Name as Name -import Control.Abstract hiding (Bitwise (..), Call) +import Control.Abstract hiding (Bitwise (..), Call, Void) import Control.Applicative import Control.Monad import Data.Abstract.Evaluatable as Abstract