Merge pull request #80 from github/remove-redundant-hasspan

Remove redundant HasSpan class.

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

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

src/Data/Abstract/HasSpan.hs

@@ -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

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

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

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

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
 

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

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 ->

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 $

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)

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