diff --git a/.licenses/semantic/cabal/ghc-boot-th.txt b/.licenses/semantic/cabal/ghc-boot-th.txt index bbbe5c228..8f2819873 100644 --- a/.licenses/semantic/cabal/ghc-boot-th.txt +++ b/.licenses/semantic/cabal/ghc-boot-th.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-boot-th -version: 8.6.3 +version: 8.6.4 summary: Shared functionality between GHC and the @template-haskell@ -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/ghc-boot.txt b/.licenses/semantic/cabal/ghc-boot.txt index c715656ea..0084942f2 100644 --- a/.licenses/semantic/cabal/ghc-boot.txt +++ b/.licenses/semantic/cabal/ghc-boot.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-boot -version: 8.6.3 +version: 8.6.4 summary: Shared functionality between GHC and its boot libraries -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/ghc-heap.txt b/.licenses/semantic/cabal/ghc-heap.txt index 8a0529d93..fbde5f4e0 100644 --- a/.licenses/semantic/cabal/ghc-heap.txt +++ b/.licenses/semantic/cabal/ghc-heap.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-heap -version: 8.6.3 +version: 8.6.4 summary: Functions for walking GHC's heap -homepage: + license: bsd-3-clause --- Copyright (c) 2012-2013, Joachim Breitner diff --git a/.licenses/semantic/cabal/ghc.txt b/.licenses/semantic/cabal/ghc.txt index d6371ff42..46b589aa3 100644 --- a/.licenses/semantic/cabal/ghc.txt +++ b/.licenses/semantic/cabal/ghc.txt @@ -1,7 +1,7 @@ --- type: cabal name: ghc -version: 8.6.3 +version: 8.6.4 summary: The GHC API homepage: https://www.haskell.org/ghc/ license: bsd-3-clause diff --git a/.licenses/semantic/cabal/ghci.txt b/.licenses/semantic/cabal/ghci.txt index 6d8722ae5..6a2628b6f 100644 --- a/.licenses/semantic/cabal/ghci.txt +++ b/.licenses/semantic/cabal/ghci.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghci -version: 8.6.3 +version: 8.6.4 summary: The library supporting GHC's interactive interpreter -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/http-types.txt b/.licenses/semantic/cabal/http-types.txt index 69998e84f..f2be57f9f 100644 --- a/.licenses/semantic/cabal/http-types.txt +++ b/.licenses/semantic/cabal/http-types.txt @@ -1,7 +1,7 @@ --- type: cabal name: http-types -version: 0.12.2 +version: 0.12.3 summary: Generic HTTP types for Haskell (for both client and server code). homepage: https://github.com/aristidb/http-types license: bsd-3-clause diff --git a/.licenses/semantic/cabal/process.txt b/.licenses/semantic/cabal/process.txt index a8172524d..7ff425efc 100644 --- a/.licenses/semantic/cabal/process.txt +++ b/.licenses/semantic/cabal/process.txt @@ -1,9 +1,9 @@ --- type: cabal name: process -version: 1.6.3.0 +version: 1.6.5.0 summary: Process libraries -homepage: + license: bsd-3-clause --- This library (libraries/process) is derived from code from two diff --git a/.licenses/semantic/cabal/recursion-schemes.txt b/.licenses/semantic/cabal/recursion-schemes.txt index 662bb4153..b5e68fef1 100644 --- a/.licenses/semantic/cabal/recursion-schemes.txt +++ b/.licenses/semantic/cabal/recursion-schemes.txt @@ -1,7 +1,7 @@ --- type: cabal name: recursion-schemes -version: 5.1.1 +version: 5.1.2 summary: Generalized bananas, lenses and barbed wire homepage: https://github.com/ekmett/recursion-schemes/ license: bsd-2-clause diff --git a/.licenses/semantic/cabal/th-abstraction.txt b/.licenses/semantic/cabal/th-abstraction.txt index 7660bdd7c..f590fe449 100644 --- a/.licenses/semantic/cabal/th-abstraction.txt +++ b/.licenses/semantic/cabal/th-abstraction.txt @@ -1,7 +1,7 @@ --- type: cabal name: th-abstraction -version: 0.2.10.0 +version: 0.2.11.0 summary: Nicer interface for reified information about data types homepage: https://github.com/glguy/th-abstraction license: isc diff --git a/.licenses/semantic/cabal/transformers.txt b/.licenses/semantic/cabal/transformers.txt index 7ab55c2b2..d000945ac 100644 --- a/.licenses/semantic/cabal/transformers.txt +++ b/.licenses/semantic/cabal/transformers.txt @@ -1,9 +1,9 @@ --- type: cabal name: transformers -version: 0.5.5.0 +version: 0.5.6.2 summary: Concrete functor and monad transformers -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/semantic.cabal b/semantic.cabal index 45e6cf5df..d52117647 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -54,6 +54,7 @@ common dependencies , network , recursion-schemes , scientific + , safe-exceptions , semilattices , text , these diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 4880c787f..cbfc49e67 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -45,9 +45,9 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta -- TODO: This span is still wrong. declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope) - param <- gensym withScope associatedScope $ do - declare (Declaration param) rel accessControl emptySpan ScopeGraph.Unknown Nothing + param <- gensym + declare (Declaration param) ScopeGraph.Gensym accessControl emptySpan ScopeGraph.Unknown Nothing slot <- lookupSlot declaration value <- builtIn associatedScope value diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 937248db1..a4c8eae92 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -3,6 +3,7 @@ module Control.Abstract.ScopeGraph ( lookup , declare + , declareMaybeName , reference , newScope , newPreludeScope @@ -79,6 +80,27 @@ declare decl rel accessControl span kind scope = do moduleInfo <- ask @ModuleInfo modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress) +-- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym). +-- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'. +declareMaybeName :: ( Carrier sig m + , Member (State (ScopeGraph address)) sig + , Member (Reader (CurrentScope address)) sig + , Member (Reader ModuleInfo) sig + , Member Fresh sig + , Ord address + ) + => Maybe Name + -> Relation + -> AccessControl + -> Span + -> Kind + -> Maybe address + -> Evaluator term address value m Name +declareMaybeName maybeName relation ac span kind scope = do + case maybeName of + Just name -> declare (Declaration name) relation ac span kind scope >> pure name + _ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name + putDeclarationScope :: ( Ord address , Member (Reader (CurrentScope address)) sig , Member (State (ScopeGraph address)) sig diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs index 3d98a269d..a4d9ee3b9 100644 --- a/src/Control/Effect/Catch.hs +++ b/src/Control/Effect/Catch.hs @@ -6,6 +6,7 @@ module Control.Effect.Catch ( Catch (..) , catch + , catchSync , runCatch , CatchC (..) ) where @@ -14,6 +15,7 @@ import Control.Effect.Carrier import Control.Effect.Reader import Control.Effect.Sum import qualified Control.Exception as Exc +import Control.Exception.Safe (isSyncException) import Control.Monad.IO.Class data Catch m k @@ -39,6 +41,16 @@ catch :: (Member Catch sig, Carrier sig m, Exc.Exception e) -> m a catch go cleanup = send (CatchIO go cleanup pure) +catchSync :: (Member Catch sig, Carrier sig m, Exc.Exception e, MonadIO m) + => m a + -> (e -> m a) + -> m a +catchSync f g = f `catch` \e -> + if isSyncException e + then g e + -- intentionally rethrowing an async exception synchronously, + -- since we want to preserve async behavior + else liftIO (Exc.throw e) -- | Evaulate a 'Catch' effect. runCatch :: (forall x . m x -> IO x) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index f0ce97e3d..8f1c9a304 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,7 +30,7 @@ import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.Name as X -import qualified Data.Abstract.ScopeGraph as ScopeGraph +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.ScopeGraph (Relation(..)) import Data.Abstract.AccessControls.Class as X import Data.Language @@ -192,7 +192,7 @@ defineSelf :: ( Carrier sig m => Evaluator term address value m () defineSelf = do let self = Declaration X.__self - declare self Default Public emptySpan ScopeGraph.Unknown Nothing + declare self ScopeGraph.Gensym Public emptySpan ScopeGraph.Unknown Nothing slot <- lookupSlot self assign slot =<< object =<< currentFrame diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 950a14d12..096099a78 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -86,7 +86,7 @@ instance Ord AccessControl where (<=) Public _ = False -data Relation = Default | Instance | Prelude +data Relation = Default | Instance | Prelude | Gensym deriving (Eq, Show, Ord, Generic, NFData) instance Lower Relation where diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 257a50de0..c477e8577 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -28,15 +28,10 @@ instance Diffable Function where instance Evaluatable Function where eval _ _ Function{..} = do - name <- maybeM (throwNoNameError functionName) (declaredName functionName) span <- ask @Span - associatedScope <- declareFunction name ScopeGraph.Public span ScopeGraph.Function + (name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public span ScopeGraph.Function - params <- withScope associatedScope . for functionParameters $ \paramNode -> do - param <- maybeM (throwNoNameError paramNode) (declaredName paramNode) - - let paramSpan = getSpan paramNode - param <$ declare (Declaration param) Default ScopeGraph.Public paramSpan ScopeGraph.Parameter Nothing + params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params functionBody associatedScope @@ -50,17 +45,17 @@ declareFunction :: ( Carrier sig m , Member Fresh sig , Ord address ) - => Name + => Maybe Name -> ScopeGraph.AccessControl -> Span -> ScopeGraph.Kind - -> Evaluator term address value m address + -> Evaluator term address value m (Name, address) declareFunction name accessControl span kind = do currentScope' <- currentScope let lexicalEdges = Map.singleton Lexical [ currentScope' ] associatedScope <- newScope lexicalEdges - declare (Declaration name) Default accessControl span kind (Just associatedScope) - pure associatedScope + name' <- declareMaybeName name Default accessControl span kind (Just associatedScope) + pure (name', associatedScope) instance Tokenize Function where tokenize Function{..} = within' Scope.Function $ do @@ -92,16 +87,13 @@ instance Diffable Method where -- local environment. instance Evaluatable Method where eval _ _ Method{..} = do - name <- maybeM (throwNoNameError methodName) (declaredName methodName) span <- ask @Span - associatedScope <- declareFunction name methodAccessControl span ScopeGraph.Method + (name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl span ScopeGraph.Method params <- withScope associatedScope $ do -- TODO: Should we give `self` a special Relation? - declare (Declaration __self) Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing - for methodParameters $ \paramNode -> do - param <- maybeM (throwNoNameError paramNode) (declaredName paramNode) - param <$ declare (Declaration param) Default ScopeGraph.Public span ScopeGraph.Parameter Nothing + declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing + for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params methodBody associatedScope @@ -144,9 +136,8 @@ instance Declarations1 RequiredParameter where -- TODO: Implement Eval instance for RequiredParameter instance Evaluatable RequiredParameter where eval _ _ RequiredParameter{..} = do - name <- maybeM (throwNoNameError requiredParameter) (declaredName requiredParameter) span <- ask @Span - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing + _ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing unit @@ -170,9 +161,8 @@ instance Evaluatable VariableDeclaration where eval _ _ (VariableDeclaration []) = unit eval eval _ (VariableDeclaration decs) = do for_ decs $ \declaration -> do - name <- maybeM (throwNoNameError declaration) (declaredName declaration) - let declarationSpan = getSpan declaration - declare (Declaration name) Default ScopeGraph.Public declarationSpan ScopeGraph.VariableDeclaration Nothing + let span = getSpan declaration + _ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public span ScopeGraph.VariableDeclaration Nothing eval declaration unit @@ -209,10 +199,8 @@ data PublicFieldDefinition a = PublicFieldDefinition instance Evaluatable PublicFieldDefinition where eval eval _ PublicFieldDefinition{..} = do span <- ask @Span - propertyName <- maybeM (throwNoNameError publicFieldPropertyName) (declaredName publicFieldPropertyName) - - declare (Declaration propertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing - slot <- lookupSlot (Declaration propertyName) + name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing + slot <- lookupSlot (Declaration name) value <- eval publicFieldValue assign slot value unit @@ -236,12 +224,13 @@ instance Diffable Class where instance Evaluatable Class where eval eval _ Class{..} = do - name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier) span <- ask @Span currentScope' <- currentScope superScopes <- for classSuperclasses $ \superclass -> do - name <- maybeM (throwNoNameError superclass) (declaredName superclass) + name <- case declaredName superclass of + Just name -> pure name + Nothing -> gensym scope <- associatedScope (Declaration name) slot <- lookupSlot (Declaration name) superclassFrame <- scopedEnvironment =<< deref slot @@ -253,7 +242,7 @@ instance Evaluatable Class where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope) + name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) classFrame <- newFrame classScope frameEdges @@ -323,13 +312,11 @@ data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: instance Evaluatable TypeAlias where eval _ _ TypeAlias{..} = do - name <- maybeM (throwNoNameError typeAliasIdentifier) (declaredName typeAliasIdentifier) + -- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here. kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind) - span <- ask @Span assocScope <- associatedScope (Declaration kindName) - -- TODO: Should we consider a special Relation for `TypeAlias`? - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope + name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope slot <- lookupSlot (Declaration name) kindSlot <- lookupSlot (Declaration kindName) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bf4729752..9079ea9ca 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -427,6 +427,7 @@ instance Evaluatable MemberAccess where let lhsAccessControl = fromMaybe Public (termToAccessControl lhs) infos <- declarationsByAccessControl rhsScope lhsAccessControl + -- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'. rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs) rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of Just _ -> pure rhsValue diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 9477058e2..6df0a3219 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -121,13 +121,13 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } instance Evaluatable Let where eval eval _ Let{..} = do - name <- maybeM (throwNoNameError letVariable) (declaredName letVariable) - letSpan <- ask @Span + -- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph. valueName <- maybeM (throwNoNameError letValue) (declaredName letValue) assocScope <- associatedScope (Declaration valueName) _ <- withLexicalScopeAndFrame $ do - declare (Declaration name) Default Public letSpan ScopeGraph.Let assocScope + letSpan <- ask @Span + name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope letVal <- eval letValue slot <- lookupSlot (Declaration name) assign slot letVal diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 781b905b0..be3ea3326 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -75,11 +75,10 @@ data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, q instance Evaluatable QualifiedImport where eval _ _ (QualifiedImport importPath aliasTerm) = do paths <- resolveGoImport importPath - alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) span <- ask @Span scopeAddress <- newScope mempty - declare (Declaration alias) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress) - aliasSlot <- lookupSlot (Declaration alias) + name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress) + aliasSlot <- lookupSlot (Declaration name) withScope scopeAddress $ do let diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 2054ce073..1229965a6 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -172,6 +172,7 @@ data QualifiedName a = QualifiedName { name :: a, identifier :: a } instance Evaluatable QualifiedName where eval _ _ (QualifiedName obj iden) = do + -- TODO: Consider gensym'ed names used for References. name <- maybeM (throwNoNameError obj) (declaredName obj) let objSpan = getSpan obj reference (Reference name) objSpan ScopeGraph.Identifier (Declaration name) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index eaa055226..7af737e17 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -187,6 +187,7 @@ newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a -- import a.b.c instance Evaluatable QualifiedImport where eval _ _ (QualifiedImport qualifiedNames) = do + -- TODO: Consider gensym'ed names for imports. qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames modulePaths <- resolvePythonModules (QualifiedName qualifiedName) let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index f11fb9988..e08504529 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -181,7 +181,9 @@ instance Diffable Class where instance Evaluatable Class where eval eval _ Class{..} = do - name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier) + (name, relation) <- case declaredName classIdentifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -210,7 +212,7 @@ instance Evaluatable Class where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Class (Just classScope) + declare (Declaration name) relation Public span ScopeGraph.Class (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) childFrame <- newFrame classScope frameEdges @@ -241,7 +243,9 @@ data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } instance Evaluatable Module where eval eval _ Module{..} = do - name <- maybeM (throwNoNameError moduleIdentifier) (declaredName moduleIdentifier) + (name, relation) <- case declaredName moduleIdentifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -260,7 +264,7 @@ instance Evaluatable Module where Nothing -> do let edges = Map.singleton Lexical [ currentScope' ] classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Module (Just classScope) + declare (Declaration name) relation Public span ScopeGraph.Module (Just classScope) currentFrame' <- currentFrame let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') @@ -323,10 +327,12 @@ instance Declarations1 Assignment where instance Evaluatable Assignment where eval eval ref Assignment{..} = do - lhsName <- maybeM (throwNoNameError assignmentTarget) (declaredName assignmentTarget) + (lhsName, relation) <- case declaredName assignmentTarget of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) maybeSlot <- maybeLookupDeclaration (Declaration lhsName) assignmentSpan <- ask @Span - maybe (declare (Declaration lhsName) Default Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot + maybe (declare (Declaration lhsName) relation Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot lhs <- ref assignmentTarget rhs <- eval assignmentValue diff --git a/src/Language/TypeScript/Syntax/Import.hs b/src/Language/TypeScript/Syntax/Import.hs index ad07c520f..4ae7ce6a2 100644 --- a/src/Language/TypeScript/Syntax/Import.hs +++ b/src/Language/TypeScript/Syntax/Import.hs @@ -58,10 +58,8 @@ instance Evaluatable QualifiedAliasedImport where importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) let scopeMap = Map.singleton moduleScope moduleFrame aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap) - - alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) - declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope) - aliasSlot <- lookupSlot (Declaration alias) + name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope) + aliasSlot <- lookupSlot (Declaration name) assign aliasSlot =<< object aliasFrame unit diff --git a/src/Language/TypeScript/Syntax/JSX.hs b/src/Language/TypeScript/Syntax/JSX.hs index dd93c33f9..ceb6129b5 100644 --- a/src/Language/TypeScript/Syntax/JSX.hs +++ b/src/Language/TypeScript/Syntax/JSX.hs @@ -76,9 +76,8 @@ instance Declarations1 RequiredParameter where instance Evaluatable RequiredParameter where eval eval ref RequiredParameter{..} = do - name <- maybeM (throwNoNameError requiredParameterSubject) (declaredName requiredParameterSubject) span <- ask @Span - declare (Declaration name) Default Public span ScopeGraph.RequiredParameter Nothing + _ <- declareMaybeName (declaredName requiredParameterSubject) Default Public span ScopeGraph.RequiredParameter Nothing lhs <- ref requiredParameterSubject rhs <- eval requiredParameterValue diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 272acbf4b..951beb39f 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -193,7 +193,9 @@ declareModule :: ( AbstractValue term address value m -> [term] -> Evaluator term address value m value declareModule eval identifier statements = do - name <- maybeM (throwNoNameError identifier) (declaredName identifier) + (name, relation) <- case declaredName identifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -212,7 +214,7 @@ declareModule eval identifier statements = do Nothing -> do let edges = Map.singleton Lexical [ currentScope' ] childScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Module (Just childScope) + declare (Declaration name) relation Public span ScopeGraph.Module (Just childScope) currentFrame' <- currentFrame let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') @@ -257,7 +259,6 @@ instance Declarations a => Declarations (AbstractClass a) where instance Evaluatable AbstractClass where eval eval _ AbstractClass{..} = do - name <- maybeM (throwNoNameError abstractClassIdentifier) (declaredName abstractClassIdentifier) span <- ask @Span currentScope' <- currentScope @@ -274,7 +275,7 @@ instance Evaluatable AbstractClass where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.AbstractClass (Just classScope) + name <- declareMaybeName (declaredName abstractClassIdentifier) Default Public span ScopeGraph.AbstractClass (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) childFrame <- newFrame classScope frameEdges diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 2f4f43144..a514d9851 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -37,8 +37,12 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) [] + -- Legacy symbols output doesn't include Function Calls. + symbolsToSummarize :: [Text] + symbolsToSummarize = ["Function", "Method", "Class", "Module"] + renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m [Legacy.File] - renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob term) + renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob symbolsToSummarize term) tagsToFile :: Blob -> [Tag] -> Legacy.File tagsToFile Blob{..} tags = Legacy.File (pack blobPath) (pack (show blobLanguage)) (fmap tagToSymbol tags) @@ -63,8 +67,11 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut where errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) + symbolsToSummarize :: [Text] + symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"] + renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File - renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term) + renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob symbolsToSummarize term) tagsToFile :: Blob -> [Tag] -> File tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index e6ea213cb..5912194af 100644 --- a/src/Tags/Taggable.hs +++ b/src/Tags/Taggable.hs @@ -200,6 +200,15 @@ instance Taggable TypeScript.Module where snippet ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann symbolName = declaredName . TypeScript.moduleIdentifier +instance Taggable Expression.Call where + snippet ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLocation ann body + symbolName = declaredName . Expression.callFunction + +instance Taggable Ruby.Send where + snippet ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body + snippet ann _ = Just $ locationByteRange ann + symbolName Ruby.Send{..} = maybe Nothing declaredName sendSelector + instance Taggable [] instance Taggable Comment.Comment instance Taggable Comment.HashBang @@ -209,7 +218,6 @@ instance Taggable Expression.Await instance Taggable Expression.BAnd instance Taggable Expression.BOr instance Taggable Expression.BXOr -instance Taggable Expression.Call instance Taggable Expression.Cast instance Taggable Expression.Comparison instance Taggable Expression.Complement @@ -606,7 +614,6 @@ instance Taggable PHP.PropertyModifier instance Taggable PHP.InterfaceDeclaration instance Taggable PHP.Declare -instance Taggable Ruby.Send instance Taggable Ruby.Require instance Taggable Ruby.Load instance Taggable Ruby.LowPrecedenceAnd diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 2cc205d4b..1cd83ebd9 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -21,19 +21,17 @@ import Data.Term import Data.Text hiding (empty) import Tags.Taggable -symbolsToSummarize :: [Text] -symbolsToSummarize = ["Function", "Method", "Class", "Module"] - runTagging :: (IsTaggable syntax) => Blob + -> [Text] -> Term syntax Location -> Either TranslationError [Tag] -runTagging blob tree +runTagging blob symbolsToSummarize tree = Eff.run . Error.runError . State.evalState mempty . runT $ source (tagging blob tree) - ~> contextualizing blob + ~> contextualizing blob symbolsToSummarize type ContextToken = (Text, Maybe Range) @@ -41,8 +39,8 @@ type Contextualizer = StateC [ContextToken] ( ErrorC TranslationError PureC) -contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag -contextualizing Blob{..} = repeatedly $ await >>= \case +contextualizing :: Blob -> [Text] -> Machine.ProcessT Contextualizer Token Tag +contextualizing Blob{..} symbolsToSummarize = repeatedly $ await >>= \case Enter x r -> enterScope (x, r) Exit x r -> exitScope (x, r) Iden iden span docsLiteralRange -> lift State.get >>= \case diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 34d9aeba0..04cbb3001 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -1,7 +1,8 @@ module Tags.Spec (spec) where -import Tags.Tagging +import Data.Text (Text) import SpecHelpers +import Tags.Tagging spec :: Spec @@ -9,35 +10,40 @@ spec = parallel $ do describe "go" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go" - runTagging blob tree `shouldBe` Right - [ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 7 2)) ["Statements"] (Just "func TestFromBits(t *testing.T)") (Just "// TestFromBits ...") - , Tag "Hi" "Function" (Span (Pos 9 1) (Pos 10 2)) ["Statements"] (Just "func Hi()") Nothing ] + runTagging blob symbolsToSummarize tree `shouldBe` Right + [ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 8 2)) ["Statements"] (Just "func TestFromBits(t *testing.T) {") (Just "// TestFromBits ...") + , Tag "Hi" "Function" (Span (Pos 10 1) (Pos 11 2)) ["Statements"] (Just "func Hi()") Nothing ] it "produces tags for methods" $ do (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/method.go" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "CheckAuth" "Method" (Span (Pos 3 1) (Pos 3 100)) ["Statements"] (Just "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)") Nothing] + it "produces tags for calls" $ do + (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go" + runTagging blob ["Call"] tree `shouldBe` Right + [ Tag "Hi" "Call" (Span (Pos 7 2) (Pos 7 6)) ["Function", "Context", "Statements"] (Just "Hi()") Nothing] + describe "javascript and typescript" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/javascript/tags/simple_function_with_docs.js" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "myFunction" "Function" (Span (Pos 2 1) (Pos 4 2)) ["Statements"] (Just "function myFunction()") (Just "// This is myFunction") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/class.ts" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "FooBar" "Class" (Span (Pos 1 1) (Pos 1 16)) ["Statements"] (Just "class FooBar") Nothing ] it "produces tags for modules" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/module.ts" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "APromise" "Module" (Span (Pos 1 1) (Pos 1 20)) ["Statements"] (Just "module APromise { }") Nothing ] describe "python" $ do it "produces tags for functions" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_functions.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "def Foo(x)") Nothing , Tag "Bar" "Function" (Span (Pos 7 1) (Pos 11 13)) ["Statements"] (Just "def Bar()") Nothing , Tag "local" "Function" (Span (Pos 8 5) (Pos 9 17)) ["Statements", "Function", "Statements"] (Just "def local()") Nothing @@ -45,35 +51,43 @@ spec = parallel $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_function_with_docs.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x)") (Just "\"\"\"This is the foo function\"\"\"") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/class.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Class" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "class Foo") (Just "\"\"\"The Foo class\"\"\"") , Tag "f" "Function" (Span (Pos 3 5) (Pos 5 17)) ["Statements", "Class", "Statements"] (Just "def f(self)") (Just "\"\"\"The f method\"\"\"") ] it "produces tags for multi-line functions" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/multiline.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x,") Nothing ] describe "ruby" $ do it "produces tags for methods" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb" - runTagging blob tree `shouldBe` Right - [ Tag "foo" "Method" (Span (Pos 1 1) (Pos 2 4)) ["Statements"] (Just "def foo") Nothing ] + runTagging blob symbolsToSummarize tree `shouldBe` Right + [ Tag "foo" "Method" (Span (Pos 1 1) (Pos 4 4)) ["Statements"] (Just "def foo") Nothing ] + + it "produces tags for sends" $ do + (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb" + runTagging blob ["Send"] tree `shouldBe` Right + [ Tag "puts" "Send" (Span (Pos 2 3) (Pos 2 12)) ["Statements", "Method", "Statements"] (Just "puts \"hi\"") Nothing + , Tag "bar" "Send" (Span (Pos 3 3) (Pos 3 8)) ["Statements", "Method", "Statements"] (Just "a.bar") Nothing + , Tag "a" "Send" (Span (Pos 3 3) (Pos 3 4)) ["Send", "Statements", "Method", "Statements"] (Just "a") Nothing + ] it "produces tags for methods with docs" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method_with_docs.rb" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "foo" "Method" (Span (Pos 2 1) (Pos 3 4)) ["Statements"] (Just "def foo") (Just "# Public: foo") ] it "produces tags for methods and classes with docs" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/class_module.rb" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Module" (Span (Pos 2 1 ) (Pos 12 4)) ["Statements"] (Just "module Foo") (Just "# Public: Foo") , Tag "Bar" "Class" (Span (Pos 5 3 ) (Pos 11 6)) ["Module", "Context", "Statements"] (Just "class Bar") (Just "# Public: Bar") , Tag "baz" "Method" (Span (Pos 8 5 ) (Pos 10 8)) ["Class", "Context", "Module", "Context", "Statements"] (Just "def baz(a)") (Just "# Public: baz") @@ -81,3 +95,6 @@ spec = parallel $ do , Tag "foo" "Method" (Span (Pos 15 3) (Pos 17 6)) ["Statements", "Class", "Statements"] (Just "def foo") Nothing , Tag "foo" "Method" (Span (Pos 18 3) (Pos 19 6)) ["Statements", "Class", "Statements"] (Just "def self.foo") Nothing ] + +symbolsToSummarize :: [Text] +symbolsToSummarize = ["Function", "Method", "Class", "Module"] diff --git a/test/fixtures/go/tags/simple_functions.go b/test/fixtures/go/tags/simple_functions.go index a9595e745..3b411672d 100644 --- a/test/fixtures/go/tags/simple_functions.go +++ b/test/fixtures/go/tags/simple_functions.go @@ -4,6 +4,7 @@ import "testing" // TestFromBits ... func TestFromBits(t *testing.T) { + Hi() } func Hi() { diff --git a/test/fixtures/ruby/tags/simple_method.rb b/test/fixtures/ruby/tags/simple_method.rb index ff7bbbe94..b3d1487af 100644 --- a/test/fixtures/ruby/tags/simple_method.rb +++ b/test/fixtures/ruby/tags/simple_method.rb @@ -1,2 +1,4 @@ def foo + puts "hi" + a.bar end