diff --git a/semantic.cabal b/semantic.cabal index 013e3dd8f6..8ede2c97a9 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -120,7 +120,6 @@ library , Data.Abstract.FreeVariables , Data.Abstract.AccessControls.Class , Data.Abstract.AccessControls.Instances - , Data.Abstract.HasSpan , Data.Abstract.Heap , Data.Abstract.Live , Data.Abstract.Module diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 60fc0f4bdd..f08cee1ef9 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -5,8 +5,6 @@ module Data.Abstract.Evaluatable , traceResolve -- * Preludes , HasPrelude(..) --- * Spans -, HasSpan(..) -- * Effects , EvalError(..) , throwEvalError @@ -37,11 +35,10 @@ import Data.Language import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable -import Data.Span (emptySpan) +import Data.Span (HasSpan(..), emptySpan) import Data.Sum hiding (project) import Data.Term import Prologue -import Data.Abstract.HasSpan -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class (Show1 constr, Foldable constr) => Evaluatable constr where diff --git a/src/Data/Abstract/HasSpan.hs b/src/Data/Abstract/HasSpan.hs deleted file mode 100644 index cf461b2bb7..0000000000 --- a/src/Data/Abstract/HasSpan.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Data.Abstract.HasSpan (HasSpan(..)) where - -import Data.Location -import Data.Quieterm -import Data.Term - - -class HasSpan term where - getSpan :: term -> Span - - -instance HasSpan ann => HasSpan (Term syntax ann) where - getSpan = getSpan . termAnnotation - -instance HasSpan ann => HasSpan (Quieterm syntax ann) where - getSpan = getSpan . termFAnnotation . unQuieterm - -instance HasSpan Location where - getSpan = locationSpan diff --git a/src/Data/Location.hs b/src/Data/Location.hs index 7ce9a66994..ba8f6857e0 100644 --- a/src/Data/Location.hs +++ b/src/Data/Location.hs @@ -8,6 +8,7 @@ module Data.Location import Prologue +import Control.Lens.Lens import Data.JSON.Fields import Data.Range import Data.Span @@ -20,5 +21,9 @@ data Location deriving (Eq, Ord, Show, Generic, NFData) deriving Semigroup via GenericSemigroup Location +instance HasSpan Location where + span = lens locationSpan (\l s -> l { locationSpan = s }) + {-# INLINE span #-} + instance ToJSONFields Location where toJSONFields Location{..} = toJSONFields locationByteRange <> toJSONFields locationSpan diff --git a/src/Data/Quieterm.hs b/src/Data/Quieterm.hs index be6c6e9db6..496556696a 100644 --- a/src/Data/Quieterm.hs +++ b/src/Data/Quieterm.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} module Data.Quieterm ( Quieterm(..) , quieterm ) where +import Prelude hiding (span) + +import Control.Lens import Control.DeepSeq import Data.Abstract.Declarations (Declarations) import Data.Abstract.FreeVariables (FreeVariables) import Data.Functor.Classes import Data.Functor.Foldable +import Data.Span import Data.Term import Text.Show (showListWith) @@ -43,5 +47,9 @@ instance NFData1 f => NFData1 (Quieterm f) where instance (NFData1 f, NFData a) => NFData (Quieterm f a) where rnf = liftRnf rnf +instance HasSpan ann => HasSpan (Quieterm syntax ann) where + span = lens (view span . unQuieterm) (\(Quieterm i) s -> Quieterm (set span s i)) + {-# INLINE span #-} + quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann quieterm = cata Quieterm diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 2494db90d7..65a6e3fea0 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -45,9 +45,11 @@ class HasSpan a where start :: Lens' a Pos start = span.start + {-# INLINE start #-} end :: Lens' a Pos end = span.end + {-# INLINE end #-} instance HasSpan Span where span = id diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index c477e85772..ac6682fb9d 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -2,17 +2,20 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Declaration where -import Prologue +import Prelude hiding (span) +import Prologue + +import Control.Lens.Getter +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Control.Abstract hiding (AccessControl (..), Function) import Data.Abstract.Evaluatable import Data.Abstract.Name (__self) -import qualified Data.Abstract.ScopeGraph as ScopeGraph +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.JSON.Fields -import qualified Data.Map.Strict as Map import qualified Data.Reprinting.Scope as Scope -import qualified Data.Set as Set -import Data.Span (emptySpan) +import Data.Span import Diffing.Algorithm import Reprinting.Tokenize hiding (Superclass) @@ -28,10 +31,10 @@ instance Diffable Function where instance Evaluatable Function where eval _ _ Function{..} = do - span <- ask @Span - (name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public span ScopeGraph.Function + current <- ask @Span + (name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public current ScopeGraph.Function - params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing + params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params functionBody associatedScope @@ -87,13 +90,13 @@ instance Diffable Method where -- local environment. instance Evaluatable Method where eval _ _ Method{..} = do - span <- ask @Span - (name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl span ScopeGraph.Method + current <- ask @Span + (name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl current ScopeGraph.Method params <- withScope associatedScope $ do -- TODO: Should we give `self` a special Relation? 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 + for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params methodBody associatedScope @@ -161,8 +164,7 @@ instance Evaluatable VariableDeclaration where eval _ _ (VariableDeclaration []) = unit eval eval _ (VariableDeclaration decs) = do for_ decs $ \declaration -> do - let span = getSpan declaration - _ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public span ScopeGraph.VariableDeclaration Nothing + _ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public (declaration^.span) ScopeGraph.VariableDeclaration Nothing eval declaration unit diff --git a/src/Data/Term.hs b/src/Data/Term.hs index f3df4c2680..7d5a7ef4de 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, FunctionalDependencies #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Data.Term ( Term(..) , termIn @@ -14,11 +14,15 @@ module Data.Term , Annotated (..) ) where +import Prelude hiding (span) import Prologue -import Data.Aeson -import Data.JSON.Fields -import Text.Show + +import Control.Lens.Lens +import Data.Aeson +import Data.JSON.Fields +import Data.Span import qualified Data.Sum as Sum +import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } @@ -40,6 +44,18 @@ guardTerm = Sum.projectGuard . termOut data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur } deriving (Eq, Ord, Foldable, Functor, Show, Traversable, Generic1) +annotationLens :: Lens' (TermF syntax ann recur) ann +annotationLens = lens termFAnnotation (\t a -> t { termFAnnotation = a }) +{-# INLINE annotationLens #-} + +instance HasSpan ann => HasSpan (TermF syntax ann recur) where + span = annotationLens.span + {-# INLINE span #-} + +instance HasSpan ann => HasSpan (Term syntax ann) where + span = inner.span where inner = lens unTerm (\t i -> t { unTerm = i }) + {-# INLINE span #-} + -- | A convenience typeclass to get the annotation out of a 'Term' or 'TermF'. -- Useful in term-rewriting algebras. class Annotated t ann | t -> ann where diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 1229965a6c..06b72399f4 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -2,6 +2,13 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.PHP.Syntax where +import Prelude hiding (span) +import Prologue hiding (Text) + +import Control.Lens.Getter +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + import Control.Abstract as Abstract import Data.Abstract.BaseError import Data.Abstract.Evaluatable as Abstract @@ -10,10 +17,8 @@ import Data.Abstract.Path import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.JSON.Fields import qualified Data.Language as Language -import qualified Data.Map.Strict as Map -import qualified Data.Text as T +import Data.Span import Diffing.Algorithm -import Prologue hiding (Text) newtype Text a = Text { value :: T.Text } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, NFData1) @@ -174,8 +179,7 @@ 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) + reference (Reference name) (obj^.span) ScopeGraph.Identifier (Declaration name) childScope <- associatedScope (Declaration name) propName <- maybeM (throwNoNameError iden) (declaredName iden) @@ -185,8 +189,7 @@ instance Evaluatable QualifiedName where currentFrameAddress <- currentFrame frameAddress <- newFrame childScope (Map.singleton Lexical (Map.singleton currentScopeAddress currentFrameAddress)) withScopeAndFrame frameAddress $ do - let propSpan = getSpan iden - reference (Reference propName) propSpan ScopeGraph.Identifier (Declaration propName) + reference (Reference propName) (iden^.span) ScopeGraph.Identifier (Declaration propName) slot <- lookupSlot (Declaration propName) deref slot Nothing -> diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 7af737e171..428451dd65 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -3,24 +3,27 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME module Language.Python.Syntax where +import Prelude hiding (span) +import Prologue + +import Control.Lens.Getter +import Data.Aeson hiding (object) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import System.FilePath.Posix + import Control.Abstract.Heap import Control.Abstract.ScopeGraph hiding (Import) import Data.Abstract.BaseError import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Aeson hiding (object) -import Data.Functor.Classes.Generic import Data.JSON.Fields import qualified Data.Language as Language -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import qualified Data.Text as T +import Data.Span import Diffing.Algorithm -import GHC.Generics -import Prologue -import System.FilePath.Posix data QualifiedName = QualifiedName { paths :: NonEmpty FilePath } @@ -132,8 +135,7 @@ instance Evaluatable Import where -- Add declaration of the alias name to the current scope (within our current module). aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm) - let aliasSpan = getSpan aliasTerm - declare (Declaration aliasName) Default Public aliasSpan ScopeGraph.UnqualifiedImport (Just importScope) + declare (Declaration aliasName) Default Public (aliasTerm^.span) ScopeGraph.UnqualifiedImport (Just importScope) -- Retrieve the frame slot for the new declaration. aliasSlot <- lookupSlot (Declaration aliasName) assign aliasSlot =<< object aliasFrame @@ -171,8 +173,7 @@ instance Evaluatable Import where aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm) aliasValue <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) if aliasValue /= aliasName then do - let aliasSpan = getSpan aliasTerm - insertImportReference (Reference aliasName) aliasSpan ScopeGraph.Identifier (Declaration aliasValue) scopeAddress + insertImportReference (Reference aliasName) (aliasTerm^.span) ScopeGraph.Identifier (Declaration aliasValue) scopeAddress else pure () @@ -198,8 +199,7 @@ instance Evaluatable QualifiedImport where go [] = pure () go (((nameTerm, name), modulePath) : namesAndPaths) = do scopeAddress <- newScope mempty - let nameSpan = getSpan nameTerm - declare (Declaration name) Default Public nameSpan ScopeGraph.QualifiedImport (Just scopeAddress) + declare (Declaration name) Default Public (nameTerm^.span) ScopeGraph.QualifiedImport (Just scopeAddress) aliasSlot <- lookupSlot (Declaration name) -- a.b.c withScope scopeAddress $ diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 5e577ad350..9b01f737a6 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -5,16 +5,18 @@ module Semantic.Analysis , evalTerm ) where +import Prologue + +import qualified Data.Map.Strict as Map + import Control.Abstract as Abstract import Control.Abstract.ScopeGraph (runAllocator) import Control.Effect.Interpose import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable -import Data.Function import Data.Language (Language) -import Prologue -import qualified Data.Map.Strict as Map +import Data.Span type ModuleC address value m = ErrorC (LoopControl value) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c8224f3da8..3d23df5609 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -55,6 +55,7 @@ import Data.Language as Language import Data.List (isPrefixOf, isSuffixOf) import Data.Project import Data.Location +import Data.Span import Data.Term import Data.Text (pack, unpack) import Language.Haskell.HsColour