github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-23 14:54:16 +03:00
Code Issues Projects Releases Wiki Activity

Switch everything over to using Source.Loc.

Browse Source
This commit is contained in:
Rob Rix 2019-09-20 14:51:48 -04:00
parent 17c61c19d1
commit 0f8e69c72f
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
41 changed files with 195 additions and 222 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
docs/assignment.md
View File

@ -73,7 +73,7 @@ TODO: explain how traversal works in terms of matching/advancing -->
#### Ways to combine assignments #### Ways to combine assignments
1. The `Functor` instance maps values from the AST (`Location`, `ByteString`, etc.) onto another structure. 1. The `Functor` instance maps values from the AST (`Loc`, `ByteString`, etc.) onto another structure.
2. The `Applicative` instance assigns sequences of (sibling) AST nodes in order, as well as providing `pure` assignments. 2. The `Applicative` instance assigns sequences of (sibling) AST nodes in order, as well as providing `pure` assignments.

1
semantic.cabal
View File

@ -159,7 +159,6 @@ library
, Data.ImportPath , Data.ImportPath
, Data.JSON.Fields , Data.JSON.Fields
, Data.Language , Data.Language
, Data.Location
, Data.Map.Monoidal , Data.Map.Monoidal
, Data.Patch , Data.Patch
, Data.Project , Data.Project

4
src/Analysis/Abstract/Graph.hs
View File

@ -27,10 +27,10 @@ import Data.ByteString.Builder
import Data.Graph import Data.Graph
import Data.Graph.ControlFlowVertex import Data.Graph.ControlFlowVertex
import Data.Term import Data.Term
import Data.Location
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import Prologue import Prologue
import Source.Loc
style :: Style ControlFlowVertex Builder style :: Style ControlFlowVertex Builder
style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier)) style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
@ -74,7 +74,7 @@ graphingTerms :: ( Member (Reader ModuleInfo) sig
, Declarations1 syntax , Declarations1 syntax
, Ord address , Ord address
, Foldable syntax , Foldable syntax
, term ~ Term syntax Location , term ~ Term syntax Loc
, Carrier sig m , Carrier sig m
) )
=> Open (term -> Evaluator term address value m a) => Open (term -> Evaluator term address value m a)

12
src/Analysis/PackageDef.hs
View File

@ -6,13 +6,13 @@ module Analysis.PackageDef
) where ) where
import Data.Blob import Data.Blob
import Data.Location
import Data.Source as Source import Data.Source as Source
import Data.Sum import Data.Sum
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
import qualified Language.Go.Syntax import qualified Language.Go.Syntax
import Prologue import Prologue
import Source.Loc
newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text } newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
deriving (Eq, Generic, Show) deriving (Eq, Generic, Show)
@ -27,7 +27,7 @@ newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
-- If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1. -- If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1.
-- --
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2. -- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe PackageDef) packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe PackageDef)
packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
@ -36,7 +36,7 @@ packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasPackageDef syntax where class HasPackageDef syntax where
-- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). -- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef toPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition. -- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition.
-- --
@ -50,13 +50,13 @@ instance (PackageDefStrategy syntax ~ strategy, HasPackageDefWithStrategy strate
-- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). -- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasPackageDef syntax where class CustomHasPackageDef syntax where
-- | Produce a customized 'PackageDef' for a given syntax node. -- | Produce a customized 'PackageDef' for a given syntax node.
customToPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef customToPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
instance CustomHasPackageDef Language.Go.Syntax.Package where instance CustomHasPackageDef Language.Go.Syntax.Package where
customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _) customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _)
= Just $ PackageDef (getSource fromAnn) = Just $ PackageDef (getSource fromAnn)
where getSource = toText . flip Source.slice blobSource . locationByteRange where getSource = toText . flip Source.slice blobSource . locByteRange
-- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'. -- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'.
instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where
@ -70,7 +70,7 @@ data Strategy = Default | Custom
-- --
-- You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class. -- You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class.
class HasPackageDefWithStrategy (strategy :: Strategy) syntax where class HasPackageDefWithStrategy (strategy :: Strategy) syntax where
toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy. -- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.

44
src/Analysis/TOCSummary.hs
View File

@ -13,12 +13,12 @@ import Data.Blob
import Data.Error (Error (..), Colourize (..), showExpectation) import Data.Error (Error (..), Colourize (..), showExpectation)
import Data.Flag import Data.Flag
import Data.Language as Language import Data.Language as Language
import Data.Location
import Data.Source as Source import Data.Source as Source
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Declaration as Declaration
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
import Source.Loc
import Source.Range import Source.Range
import qualified Language.Markdown.Syntax as Markdown import qualified Language.Markdown.Syntax as Markdown
@ -42,12 +42,12 @@ data Declaration
-- --
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2. -- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
declarationAlgebra :: (Foldable syntax, HasDeclaration syntax) declarationAlgebra :: (Foldable syntax, HasDeclaration syntax)
=> Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe Declaration) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe Declaration)
declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax
-- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass
class HasDeclaration syntax where class HasDeclaration syntax where
toDeclaration :: (Foldable syntax) => Blob -> Location -> syntax (Term syntax Location, Maybe Declaration) -> Maybe Declaration toDeclaration :: (Foldable syntax) => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration
instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
toDeclaration = toDeclaration' toDeclaration = toDeclaration'
@ -57,7 +57,7 @@ instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasDeclaration' whole syntax where class HasDeclaration' whole syntax where
-- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). -- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toDeclaration' :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration toDeclaration' :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition. -- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition.
-- --
@ -71,22 +71,22 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy stra
-- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). -- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasDeclaration whole syntax where class CustomHasDeclaration whole syntax where
-- | Produce a customized 'Declaration' for a given syntax node. -- | Produce a customized 'Declaration' for a given syntax node.
customToDeclaration :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration customToDeclaration :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node. -- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
instance CustomHasDeclaration whole Markdown.Heading where instance CustomHasDeclaration whole Markdown.Heading where
customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _) customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _)
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) (blobLanguage blob) level = Just $ HeadingDeclaration (headingText terms) mempty (locSpan ann) (blobLanguage blob) level
where headingText terms = getSource $ maybe (locationByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) where headingText terms = getSource $ maybe (locByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = locationByteRange ann headingByteRange (Term (In ann _), _) = locByteRange ann
getSource = firstLine . toText . flip Source.slice blobSource getSource = firstLine . toText . flip Source.slice blobSource
firstLine = T.takeWhile (/= '\n') firstLine = T.takeWhile (/= '\n')
-- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes. -- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
instance CustomHasDeclaration whole Syntax.Error where instance CustomHasDeclaration whole Syntax.Error where
customToDeclaration blob@Blob{..} ann err@Syntax.Error{} customToDeclaration blob@Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) (blobLanguage blob) = Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locSpan ann) err))) mempty (locSpan ann) (blobLanguage blob)
where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) "" where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). -- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
@ -95,22 +95,22 @@ instance CustomHasDeclaration whole Declaration.Function where
-- Do not summarize anonymous functions -- Do not summarize anonymous functions
| isEmpty identifierAnn = Nothing | isEmpty identifierAnn = Nothing
-- Named functions -- Named functions
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) (blobLanguage blob) | otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locSpan ann) (blobLanguage blob)
where isEmpty = (== 0) . rangeLength . locationByteRange where isEmpty = (== 0) . rangeLength . locByteRange
functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
-- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. -- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
instance CustomHasDeclaration whole Declaration.Method where instance CustomHasDeclaration whole Declaration.Method where
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
-- Methods without a receiver -- Methods without a receiver
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) Nothing | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locSpan ann) (blobLanguage blob) Nothing
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage blob == Go | blobLanguage blob == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverType)) , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverType))
-- Methods with a receiver (class methods) are formatted like `receiver.method_name` -- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn)) | otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn))
where where
isEmpty = (== 0) . rangeLength . locationByteRange isEmpty = (== 0) . rangeLength . locByteRange
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl) methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
-- When encountering a Declaration-annotated term, we need to extract a Text -- When encountering a Declaration-annotated term, we need to extract a Text
@ -118,19 +118,19 @@ instance CustomHasDeclaration whole Declaration.Method where
-- is constructed by slicing out text from the original blob corresponding -- is constructed by slicing out text from the original blob corresponding
-- to a location, which is found via the passed-in rule. -- to a location, which is found via the passed-in rule.
getIdentifier :: Functor m getIdentifier :: Functor m
=> Rewrite (m (Term syntax Location)) (Term syntax Location) => Rewrite (m (Term syntax Loc)) (Term syntax Loc)
-> Blob -> Blob
-> TermF m Location (Term syntax Location, a) -> TermF m Loc (Term syntax Loc, a)
-> Text -> Text
getIdentifier finder Blob{..} (In a r) getIdentifier finder Blob{..} (In a r)
= let declRange = locationByteRange a = let declRange = locByteRange a
bodyRange = locationByteRange <$> rewrite (fmap fst r) (finder >>^ annotation) bodyRange = locByteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
-- Text-based gyrations to slice the identifier out of the provided blob source -- Text-based gyrations to slice the identifier out of the provided blob source
sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange
in maybe mempty sliceFrom bodyRange in maybe mempty sliceFrom bodyRange
getSource :: Source -> Location -> Text getSource :: Source -> Loc -> Text
getSource blobSource = toText . flip Source.slice blobSource . locationByteRange getSource blobSource = toText . flip Source.slice blobSource . locByteRange
-- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'. -- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'.
instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where
@ -144,7 +144,7 @@ data Strategy = Default | Custom
-- --
-- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class. -- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class.
class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy. -- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.

26
src/Assigning/Assignment.hs
View File

@ -8,7 +8,7 @@
-- --
-- 1. 'symbol' rules match a node against a specific symbol in the source language’s grammar; they succeed iff a) there is a current node, and b) its symbol is equal to the argument symbol. Matching a 'symbol' rule does not advance past the current node, meaning that you can match a node against a symbol and also e.g. match against the node’s 'children'. This also means that some care must be taken, as repeating a symbol with 'many' or 'some' (see below) will never advance past the current node and could therefore loop forever. -- 1. 'symbol' rules match a node against a specific symbol in the source language’s grammar; they succeed iff a) there is a current node, and b) its symbol is equal to the argument symbol. Matching a 'symbol' rule does not advance past the current node, meaning that you can match a node against a symbol and also e.g. match against the node’s 'children'. This also means that some care must be taken, as repeating a symbol with 'many' or 'some' (see below) will never advance past the current node and could therefore loop forever.
-- --
-- 2. 'location' rules always succeed, and produce the current node’s Location (byte Range and Span). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties. -- 2. 'location' rules always succeed, and produce the current node’s Loc (byte Range and Span). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties.
-- --
-- 3. 'source' rules succeed whenever there is a current node (i.e. matching has not advanced past the root node or the last child node when operating within a 'children' rule), and produce its source as a ByteString. 'source' is intended to match leaf nodes such as e.g. comments. 'source' rules advance past the current node. -- 3. 'source' rules succeed whenever there is a current node (i.e. matching has not advanced past the root node or the last child node when operating within a 'children' rule), and produce its source as a ByteString. 'source' is intended to match leaf nodes such as e.g. comments. 'source' rules advance past the current node.
-- --
@ -20,7 +20,7 @@
-- --
-- Assignments can further be combined in a few different ways: -- Assignments can further be combined in a few different ways:
-- --
-- 1. The 'Functor' instance maps values from the AST (Location, ByteString, etc.) into another structure. -- 1. The 'Functor' instance maps values from the AST (Loc, ByteString, etc.) into another structure.
-- --
-- 2. The 'Applicative' instance assigns sequences of (sibling) AST nodes in order, as well as providing 'pure' assignments (see above). Most assignments of a single piece of syntax consist of an 'Applicative' chain of assignments. -- 2. The 'Applicative' instance assigns sequences of (sibling) AST nodes in order, as well as providing 'pure' assignments (see above). Most assignments of a single piece of syntax consist of an 'Applicative' chain of assignments.
-- --
@ -61,7 +61,7 @@
module Assigning.Assignment module Assigning.Assignment
-- Types -- Types
( Assignment ( Assignment
, L.Location(..) , L.Loc(..)
-- Combinators -- Combinators
, branchNode , branchNode
, leafNode , leafNode
@ -100,11 +100,11 @@ import qualified Assigning.Assignment.Table as Table
import Control.Monad.Except (MonadError (..)) import Control.Monad.Except (MonadError (..))
import Data.AST import Data.AST
import Data.Error import Data.Error
import qualified Data.Location as L
import qualified Data.Source as Source (Source, slice, sourceBytes) import qualified Data.Source as Source (Source, slice, sourceBytes)
import Data.Term import Data.Term
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8') import Data.Text.Encoding (decodeUtf8')
import qualified Source.Loc as L
import Source.Range import Source.Range
import Source.Span hiding (HasSpan(..)) import Source.Span hiding (HasSpan(..))
import Text.Parser.Combinators as Parsers hiding (choice) import Text.Parser.Combinators as Parsers hiding (choice)
@ -120,8 +120,8 @@ leafNode sym = symbol sym *> source
-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's. -- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's.
toTerm :: Element syntax syntaxes toTerm :: Element syntax syntaxes
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Location)) => Assignment ast grammar (syntax (Term (Sum syntaxes) L.Loc))
-> Assignment ast grammar (Term (Sum syntaxes) L.Location) -> Assignment ast grammar (Term (Sum syntaxes) L.Loc)
toTerm syntax = termIn <$> location <*> (inject <$> syntax) toTerm syntax = termIn <$> location <*> (inject <$> syntax)
@ -132,7 +132,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
data AssignmentF ast grammar a where data AssignmentF ast grammar a where
End :: AssignmentF ast grammar () End :: AssignmentF ast grammar ()
Location :: AssignmentF ast grammar L.Location Loc :: AssignmentF ast grammar L.Loc
CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ()) CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ())
Source :: AssignmentF ast grammar ByteString Source :: AssignmentF ast grammar ByteString
Children :: Assignment ast grammar a -> AssignmentF ast grammar a Children :: Assignment ast grammar a -> AssignmentF ast grammar a
@ -159,8 +159,8 @@ tracing f = case getCallStack callStack of
-- | Zero-width production of the current location. -- | Zero-width production of the current location.
-- --
-- If assigning at the end of input or at the end of a list of children, the location will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node. -- If assigning at the end of input or at the end of a list of children, the location will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node.
location :: Assignment ast grammar L.Location location :: Assignment ast grammar L.Loc
location = tracing Location `Then` pure location = tracing Loc `Then` pure
getLocals :: HasCallStack => Assignment ast grammar [Text] getLocals :: HasCallStack => Assignment ast grammar [Text]
getLocals = tracing GetLocals `Then` pure getLocals = tracing GetLocals `Then` pure
@ -174,7 +174,7 @@ currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar)
currentNode = tracing CurrentNode `Then` pure currentNode = tracing CurrentNode `Then` pure
-- | Zero-width match of a node with the given symbol, producing the current node’s location. -- | Zero-width match of a node with the given symbol, producing the current node’s location.
symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Loc
symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` pure symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` pure
-- | A rule to produce a node’s source as a ByteString. -- | A rule to produce a node’s source as a ByteString.
@ -213,7 +213,7 @@ choice alternatives
mergeHandlers hs = Just (\ err -> asum (hs <*> [err])) mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
-- | Match and advance past a node with the given symbol. -- | Match and advance past a node with the given symbol.
token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Loc
token s = symbol s <* advance token s = symbol s <* advance
@ -261,7 +261,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
-> Either (Error (Either String grammar)) (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar)
run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
where atNode (Term (In node f)) = case runTracing t of where atNode (Term (In node f)) = case runTracing t of
Location -> yield (nodeLocation node) state Loc -> yield (nodeLocation node) state
GetLocals -> yield stateLocals state GetLocals -> yield stateLocals state
PutLocals l -> yield () (state { stateLocals = l }) PutLocals l -> yield () (state { stateLocals = l })
CurrentNode -> yield (In node (() <$ f)) state CurrentNode -> yield (In node (() <$ f)) state
@ -274,7 +274,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
anywhere node = case runTracing t of anywhere node = case runTracing t of
End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield
Location -> yield (L.Location (Range stateOffset stateOffset) (Span statePos statePos)) state Loc -> yield (L.Loc (Range stateOffset stateOffset) (Span statePos statePos)) state
Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield
Alt (a:as) -> sconcat (flip yield state <$> a:|as) Alt (a:as) -> sconcat (flip yield state <$> a:|as)
Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield

12
src/Assigning/Assignment/Deterministic.hs
View File

@ -13,12 +13,12 @@ import Data.AST
import Data.Error import Data.Error
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet import qualified Data.IntSet as IntSet
import Data.Location
import Data.Source as Source import Data.Source as Source
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import Data.Term (Term, termIn, termAnnotation, termOut) import Data.Term (Term, termIn, termAnnotation, termOut)
import Data.Text.Encoding (decodeUtf8') import Data.Text.Encoding (decodeUtf8')
import Prologue import Prologue
import Source.Loc
import Source.Span hiding (HasSpan (..)) import Source.Span hiding (HasSpan (..))
class (Alternative f, Ord symbol, Show symbol) => Assigning symbol f | f -> symbol where class (Alternative f, Ord symbol, Show symbol) => Assigning symbol f | f -> symbol where
@ -26,15 +26,15 @@ class (Alternative f, Ord symbol, Show symbol) => Assigning symbol f | f -> symb
branchNode :: symbol -> f a -> f a branchNode :: symbol -> f a -> f a
toTerm :: (Element syntax syntaxes, Element Syntax.Error syntaxes) toTerm :: (Element syntax syntaxes, Element Syntax.Error syntaxes)
=> f (syntax (Term (Sum syntaxes) Location)) => f (syntax (Term (Sum syntaxes) Loc))
-> f (Term (Sum syntaxes) Location) -> f (Term (Sum syntaxes) Loc)
parseError :: ( Bounded symbol parseError :: ( Bounded symbol
, Element Syntax.Error syntaxes , Element Syntax.Error syntaxes
, HasCallStack , HasCallStack
, Assigning symbol f , Assigning symbol f
) )
=> f (Term (Sum syntaxes) Location) => f (Term (Sum syntaxes) Loc)
parseError = toTerm (leafNode maxBound $> Syntax.Error (Syntax.ErrorStack (Syntax.errorSite <$> getCallStack (freezeCallStack callStack))) [] (Just "ParseError") []) parseError = toTerm (leafNode maxBound $> Syntax.Error (Syntax.ErrorStack (Syntax.errorSite <$> getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
@ -167,8 +167,8 @@ stateSpan :: State s -> Span
stateSpan state@(State _ _ []) = Span (statePos state) (statePos state) stateSpan state@(State _ _ []) = Span (statePos state) (statePos state)
stateSpan (State _ _ (s:_)) = astSpan s stateSpan (State _ _ (s:_)) = astSpan s
stateLocation :: State s -> Location stateLocation :: State s -> Loc
stateLocation state = Location (stateRange state) (stateSpan state) stateLocation state = Loc (stateRange state) (stateSpan state)
advanceState :: State s -> State s advanceState :: State s -> State s
advanceState state advanceState state

10
src/Data/AST.hs
View File

@ -6,18 +6,18 @@ module Data.AST
, AST , AST
) where ) where
import Data.Location
import Data.Term import Data.Term
import Data.Aeson import Data.Aeson
import Data.Text (pack) import Data.Text (pack)
import Data.JSON.Fields import Data.JSON.Fields
import Source.Loc
-- | An AST node labelled with symbols and source location. -- | An AST node labelled with symbols and source location.
type AST syntax grammar = Term syntax (Node grammar) type AST syntax grammar = Term syntax (Node grammar)
data Node grammar = Node data Node grammar = Node
{ nodeSymbol :: !grammar { nodeSymbol :: !grammar
, nodeLocation :: {-# UNPACK #-} !Location , nodeLocation :: {-# UNPACK #-} !Loc
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -25,11 +25,11 @@ data Node grammar = Node
instance Show grammar => ToJSONFields (Node grammar) where instance Show grammar => ToJSONFields (Node grammar) where
toJSONFields Node{..} = toJSONFields Node{..} =
[ "symbol" .= pack (show nodeSymbol) [ "symbol" .= pack (show nodeSymbol)
, "span" .= locationSpan nodeLocation , "span" .= locSpan nodeLocation
] ]
nodeSpan :: Node grammar -> Span nodeSpan :: Node grammar -> Span
nodeSpan = locationSpan . nodeLocation nodeSpan = locSpan . nodeLocation
nodeByteRange :: Node grammar -> Range nodeByteRange :: Node grammar -> Range
nodeByteRange = locationByteRange . nodeLocation nodeByteRange = locByteRange . nodeLocation

24
src/Data/Graph/ControlFlowVertex.hs
View File

@ -22,13 +22,13 @@ import Data.Abstract.Package (PackageInfo (..))
import Data.Aeson import Data.Aeson
import Data.Graph (VertexTag (..)) import Data.Graph (VertexTag (..))
import qualified Data.Graph as G import qualified Data.Graph as G
import Data.Location
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Expression as Expression
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
import Prologue import Prologue
import Source.Loc
import Source.Span import Source.Span
-- | A vertex of representing some node in a control flow graph. -- | A vertex of representing some node in a control flow graph.
@ -101,9 +101,9 @@ instance ToJSON ControlFlowVertex where
class VertexDeclaration syntax where class VertexDeclaration syntax where
toVertex :: (Declarations1 syntax, Foldable syntax) toVertex :: (Declarations1 syntax, Foldable syntax)
=> Location => Loc
-> ModuleInfo -> ModuleInfo
-> syntax (Term syntax Location) -> syntax (Term syntax Loc)
-> Maybe (ControlFlowVertex, Name) -> Maybe (ControlFlowVertex, Name)
instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
@ -111,9 +111,9 @@ instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
class VertexDeclaration' whole syntax where class VertexDeclaration' whole syntax where
toVertex' :: (Declarations1 whole, Foldable whole) toVertex' :: (Declarations1 whole, Foldable whole)
=> Location => Loc
-> ModuleInfo -> ModuleInfo
-> syntax (Term whole Location) -> syntax (Term whole Loc)
-> Maybe (ControlFlowVertex, Name) -> Maybe (ControlFlowVertex, Name)
instance (VertexDeclarationStrategy syntax ~ strategy, VertexDeclarationWithStrategy strategy whole syntax) => VertexDeclaration' whole syntax where instance (VertexDeclarationStrategy syntax ~ strategy, VertexDeclarationWithStrategy strategy whole syntax) => VertexDeclaration' whole syntax where
@ -132,9 +132,9 @@ type family VertexDeclarationStrategy syntax where
class VertexDeclarationWithStrategy (strategy :: Strategy) whole syntax where class VertexDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toVertexWithStrategy :: (Declarations1 whole, Foldable whole) toVertexWithStrategy :: (Declarations1 whole, Foldable whole)
=> proxy strategy => proxy strategy
-> Location -> Loc
-> ModuleInfo -> ModuleInfo
-> syntax (Term whole Location) -> syntax (Term whole Loc)
-> Maybe (ControlFlowVertex, Name) -> Maybe (ControlFlowVertex, Name)
-- | The 'Default' strategy produces 'Nothing'. -- | The 'Default' strategy produces 'Nothing'.
@ -145,17 +145,17 @@ instance Apply (VertexDeclaration' whole) fs => VertexDeclarationWithStrategy 'C
toVertexWithStrategy _ ann info = apply @(VertexDeclaration' whole) (toVertex' ann info) toVertexWithStrategy _ ann info = apply @(VertexDeclaration' whole) (toVertex' ann info)
instance VertexDeclarationWithStrategy 'Custom whole Syntax.Identifier where instance VertexDeclarationWithStrategy 'Custom whole Syntax.Identifier where
toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (locationSpan ann), name) toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (locSpan ann), name)
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Function where instance VertexDeclarationWithStrategy 'Custom whole Declaration.Function where
toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (locSpan ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Method where instance VertexDeclarationWithStrategy 'Custom whole Declaration.Method where
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (locSpan ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole whole => VertexDeclarationWithStrategy 'Custom whole Expression.MemberAccess where instance VertexDeclarationWithStrategy 'Custom whole whole => VertexDeclarationWithStrategy 'Custom whole Expression.MemberAccess where
toVertexWithStrategy proxy ann info (Expression.MemberAccess (Term (In lhsAnn lhs)) (Term (In rhsAnn rhs))) = toVertexWithStrategy proxy ann info (Expression.MemberAccess (Term (In lhsAnn lhs)) (Term (In rhsAnn rhs))) =
case (toVertexWithStrategy proxy lhsAnn info lhs, toVertexWithStrategy proxy rhsAnn info rhs) of case (toVertexWithStrategy proxy lhsAnn info lhs, toVertexWithStrategy proxy rhsAnn info rhs) of
(Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (locationSpan ann), name) (Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (locSpan ann), name)
(_, Just (_, name)) -> Just (variableVertex (formatName name) info (locationSpan ann), name) (_, Just (_, name)) -> Just (variableVertex (formatName name) info (locSpan ann), name)
_ -> Nothing _ -> Nothing

6
src/Data/History.hs
View File

@ -6,7 +6,7 @@ module Data.History
, remark , remark
) where ) where
import Data.Location import Source.Loc
-- | 'History' values, when attached to a given 'Term', describe the ways in -- | 'History' values, when attached to a given 'Term', describe the ways in
-- which that term was modified during a refactoring pass, if any. -- which that term was modified during a refactoring pass, if any.
@ -21,9 +21,9 @@ data History
-- | Convert a 'Term' annotated with a 'Range' to one annotated with a 'History'. -- | Convert a 'Term' annotated with a 'Range' to one annotated with a 'History'.
mark :: Functor f mark :: Functor f
=> (Range -> History) => (Range -> History)
-> f Location -> f Loc
-> f History -> f History
mark f = fmap (f . locationByteRange) mark f = fmap (f . locByteRange)
-- | Change the 'History' annotation on a 'Term'. -- | Change the 'History' annotation on a 'Term'.
remark :: Functor f remark :: Functor f

6
src/Data/JSON/Fields.hs
View File

@ -10,11 +10,11 @@ module Data.JSON.Fields
import Data.Aeson import Data.Aeson
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Location
import Data.Sum (Apply (..), Sum) import Data.Sum (Apply (..), Sum)
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC.Generics import GHC.Generics
import Prologue import Prologue
import Source.Loc
class ToJSONFields a where class ToJSONFields a where
toJSONFields :: KeyValue kv => a -> [kv] toJSONFields :: KeyValue kv => a -> [kv]
@ -53,8 +53,8 @@ instance ToJSONFields Range where
instance ToJSONFields Span where instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ] toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance ToJSONFields Location where instance ToJSONFields Loc where
toJSONFields Location{..} = toJSONFields locationByteRange <> toJSONFields locationSpan toJSONFields Loc{..} = toJSONFields locByteRange <> toJSONFields locSpan
newtype JSONFields a = JSONFields { unJSONFields :: a } newtype JSONFields a = JSONFields { unJSONFields :: a }

25
src/Data/Location.hs
View File

@ -1,25 +0,0 @@
{-# LANGUAGE DeriveAnyClass, DerivingVia #-}
module Data.Location
( Location(..)
, Span(..)
, Range(..)
) where
import Prologue
import Control.Lens.Lens
import Source.Range
import Source.Span
data Location
= Location
{ locationByteRange :: {-# UNPACK #-} Range
, locationSpan :: {-# UNPACK #-} Span
}
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 #-}

10
src/Data/Syntax.hs
View File

@ -5,7 +5,6 @@ module Data.Syntax where
import Data.Abstract.Evaluatable hiding (Empty, Error) import Data.Abstract.Evaluatable hiding (Empty, Error)
import Data.Aeson as Aeson (ToJSON(..), object) import Data.Aeson as Aeson (ToJSON(..), object)
import Data.JSON.Fields import Data.JSON.Fields
import Data.Location
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Sum import Data.Sum
import Data.Term import Data.Term
@ -16,6 +15,7 @@ import Diffing.Algorithm
import Prelude import Prelude
import Prologue import Prologue
import Reprinting.Tokenize hiding (Element) import Reprinting.Tokenize hiding (Element)
import Source.Loc
import qualified Assigning.Assignment as Assignment import qualified Assigning.Assignment as Assignment
import qualified Data.Error as Error import qualified Data.Error as Error
import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..)) import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..))
@ -49,16 +49,16 @@ makeTerm1' syntax = case toList syntax of
_ -> error "makeTerm1': empty structure" _ -> error "makeTerm1': empty structure"
-- | Construct an empty term at the current position. -- | Construct an empty term at the current position.
emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
where startLocation Location{..} = Location (Range (start locationByteRange) (start locationByteRange)) (Span (spanStart locationSpan) (spanStart locationSpan)) where startLocation Loc{..} = Loc (Range (start locByteRange) (start locByteRange)) (Span (spanStart locSpan) (spanStart locSpan))
-- | Catch assignment errors into an error term. -- | Catch assignment errors into an error term.
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source) handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
-- | Catch parse errors into an error term. -- | Catch parse errors into an error term.
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") []) parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") [])
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.

2
src/Language/Go/Assignment.hs
View File

@ -132,7 +132,7 @@ type Syntax =
, Literal.Boolean , Literal.Boolean
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Go's grammar onto a program in Go's syntax. -- | Assignment from AST in Go's grammar onto a program in Go's syntax.

2
src/Language/Haskell/Assignment.hs
View File

@ -169,7 +169,7 @@ type Syntax = '[
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
assignment :: Assignment Term assignment :: Assignment Term

4
src/Language/JSON/Assignment.hs
View File

@ -9,11 +9,11 @@ where
import Assigning.Assignment.Deterministic hiding (Assignment) import Assigning.Assignment.Deterministic hiding (Assignment)
import qualified Assigning.Assignment.Deterministic as Deterministic import qualified Assigning.Assignment.Deterministic as Deterministic
import Data.Sum import Data.Sum
import Data.Location
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Literal as Literal
import qualified Data.Term as Term import qualified Data.Term as Term
import Prologue import Prologue
import Source.Loc
import Text.Parser.Combinators import Text.Parser.Combinators
import TreeSitter.JSON as Grammar import TreeSitter.JSON as Grammar
@ -28,7 +28,7 @@ type Syntax =
, Syntax.Error , Syntax.Error
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Deterministic.Assignment Grammar type Assignment = Deterministic.Assignment Grammar
assignment :: Assignment Term assignment :: Assignment Term

2
src/Language/Java/Assignment.hs
View File

@ -155,7 +155,7 @@ type Syntax =
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Java's grammar onto a program in Java's syntax. -- | Assignment from AST in Java's grammar onto a program in Java's syntax.

2
src/Language/Markdown/Assignment.hs
View File

@ -46,7 +46,7 @@ type Syntax =
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment (Term.TermF [] CMarkGFM.NodeType) Grammar type Assignment = Assignment.Assignment (Term.TermF [] CMarkGFM.NodeType) Grammar
assignment :: Assignment Term assignment :: Assignment Term

2
src/Language/PHP/Assignment.hs
View File

@ -162,7 +162,7 @@ type Syntax = '[
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in PHP's grammar onto a program in PHP's syntax. -- | Assignment from AST in PHP's grammar onto a program in PHP's syntax.

2
src/Language/Python/Assignment.hs
View File

@ -118,7 +118,7 @@ type Syntax =
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Python's grammar onto a program in Python's syntax. -- | Assignment from AST in Python's grammar onto a program in Python's syntax.

4
src/Language/Ruby/Assignment.hs
View File

@ -129,7 +129,7 @@ type Syntax = '[
, [] , []
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax. -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
@ -487,7 +487,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Ruby.Syntax.
<|> lhsIdent <|> lhsIdent
<|> expression <|> expression
identWithLocals :: Assignment (Location, Text, [Text]) identWithLocals :: Assignment (Loc, Text, [Text])
identWithLocals = do identWithLocals = do
loc <- symbol Identifier loc <- symbol Identifier
-- source advances, so it's important we call getLocals first -- source advances, so it's important we call getLocals first

2
src/Language/TSX/Assignment.hs
View File

@ -208,7 +208,7 @@ type Syntax = '[
, TSX.Syntax.AnnotatedExpression , TSX.Syntax.AnnotatedExpression
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax. -- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax.

2
src/Language/TypeScript/Assignment.hs
View File

@ -199,7 +199,7 @@ type Syntax = '[
, TypeScript.Syntax.AnnotatedExpression , TypeScript.Syntax.AnnotatedExpression
] ]
type Term = Term.Term (Sum Syntax) Location type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax. -- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax.

4
src/Parsing/CMark.hs
View File

@ -8,9 +8,9 @@ module Parsing.CMark
import CMarkGFM import CMarkGFM
import qualified Data.AST as A import qualified Data.AST as A
import Data.Ix import Data.Ix
import Data.Location
import Data.Source import Data.Source
import Data.Term import Data.Term
import Source.Loc
import Source.Span import Source.Span
import TreeSitter.Language (Symbol(..), SymbolType(..)) import TreeSitter.Language (Symbol(..), SymbolType(..))
@ -55,7 +55,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT
toTerm within withinSpan (Node position t children) = toTerm within withinSpan (Node position t children) =
let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position
span = maybe withinSpan toSpan position span = maybe withinSpan toSpan position
in termIn (A.Node (toGrammar t) (Location range span)) (In t (toTerm range span <$> children)) in termIn (A.Node (toGrammar t) (Loc range span)) (In t (toTerm range span <$> children))
toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn)))

10
src/Parsing/Parser.hs
View File

@ -84,7 +84,7 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
) )
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select. -> Language -- ^ The 'Language' to select.
-> SomeAnalysisParser typeclasses Location -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. -> SomeAnalysisParser typeclasses Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced.
someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go) someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go)
someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell) someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell)
someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'JavaScript) someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'JavaScript)
@ -103,12 +103,12 @@ data Parser term where
-- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type.
AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast) AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast)
=> Parser (Term ast (Node grammar)) -- ^ A parser producing AST. => Parser (Term ast (Node grammar)) -- ^ A parser producing AST.
-> Assignment ast grammar (Term (Sum fs) Location) -- ^ An assignment from AST onto 'Term's. -> Assignment ast grammar (Term (Sum fs) Loc) -- ^ An assignment from AST onto 'Term's.
-> Parser (Term (Sum fs) Location) -- ^ A parser producing 'Term's. -> Parser (Term (Sum fs) Loc) -- ^ A parser producing 'Term's.
DeterministicParser :: (Enum grammar, Ord grammar, Show grammar, Element Syntax.Error syntaxes, Apply Foldable syntaxes, Apply Functor syntaxes) DeterministicParser :: (Enum grammar, Ord grammar, Show grammar, Element Syntax.Error syntaxes, Apply Foldable syntaxes, Apply Functor syntaxes)
=> Parser (AST [] grammar) => Parser (AST [] grammar)
-> Deterministic.Assignment grammar (Term (Sum syntaxes) Location) -> Deterministic.Assignment grammar (Term (Sum syntaxes) Loc)
-> Parser (Term (Sum syntaxes) Location) -> Parser (Term (Sum syntaxes) Loc)
-- | A parser for 'Markdown' using cmark. -- | A parser for 'Markdown' using cmark.
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-- | An abstraction over parsers when we don’t know the details of the term type. -- | An abstraction over parsers when we don’t know the details of the term type.

4
src/Parsing/TreeSitter.hs
View File

@ -17,9 +17,9 @@ import Foreign.Marshal.Array (allocaArray)
import Data.AST (AST, Node (Node)) import Data.AST (AST, Node (Node))
import Data.Blob import Data.Blob
import Data.Duration import Data.Duration
import Data.Location
import Data.Source import Data.Source
import Data.Term import Data.Term
import Source.Loc
import Source.Span import Source.Span
import qualified TreeSitter.Language as TS import qualified TreeSitter.Language as TS
@ -84,7 +84,7 @@ toAST node@TS.Node{..} = do
children <- allocaArray count $ \ childNodesPtr -> do children <- allocaArray count $ \ childNodesPtr -> do
_ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` childNodesPtr) _ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` childNodesPtr)
peekArray count childNodesPtr peekArray count childNodesPtr
pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Location (nodeRange node) (nodeSpan node))) children pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Loc (nodeRange node) (nodeSpan node))) children
anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t
anaM g = a where a = pure . embed <=< traverse a <=< g anaM g = a where a = pure . embed <=< traverse a <=< g

12
src/Rendering/Graph.hs
View File

@ -14,13 +14,13 @@ import Control.Effect.Reader
import Control.Effect.State import Control.Effect.State
import Data.Diff import Data.Diff
import Data.Graph import Data.Graph
import Data.Location
import Data.Patch import Data.Patch
import Data.String (IsString (..)) import Data.String (IsString (..))
import Data.Term import Data.Term
import Prologue import Prologue
import Semantic.Api.Bridge import Semantic.Api.Bridge
import Semantic.Proto.SemanticPB import Semantic.Proto.SemanticPB
import Source.Loc
import qualified Data.Text as T import qualified Data.Text as T
@ -61,7 +61,7 @@ class ToTreeGraph vertex t | t -> vertex where
toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex) toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex)
instance (ConstructorName syntax, Foldable syntax) => instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph TermVertex (TermF syntax Location) where ToTreeGraph TermVertex (TermF syntax Loc) where
toTreeGraph = termAlgebra where toTreeGraph = termAlgebra where
termAlgebra :: termAlgebra ::
( ConstructorName syntax ( ConstructorName syntax
@ -70,17 +70,17 @@ instance (ConstructorName syntax, Foldable syntax) =>
, Member (Reader (Graph TermVertex)) sig , Member (Reader (Graph TermVertex)) sig
, Carrier sig m , Carrier sig m
) )
=> TermF syntax Location (m (Graph TermVertex)) => TermF syntax Loc (m (Graph TermVertex))
-> m (Graph TermVertex) -> m (Graph TermVertex)
termAlgebra (In ann syntax) = do termAlgebra (In ann syntax) = do
i <- fresh i <- fresh
parent <- ask parent <- ask
let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locationSpan ann) let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locSpan ann)
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph) pure (parent `connect` root `overlay` subGraph)
instance (ConstructorName syntax, Foldable syntax) => instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) where ToTreeGraph DiffTreeVertex (DiffF syntax Loc Loc) where
toTreeGraph d = case d of toTreeGraph d = case d of
Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2)))) Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2))))
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1)))) Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1))))
@ -94,7 +94,7 @@ instance (ConstructorName syntax, Foldable syntax) =>
graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan)))) graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
pure (parent `connect` replace `overlay` graph) pure (parent `connect` replace `overlay` graph)
where where
ann a = converting #? locationSpan a ann a = converting #? locSpan a
diffAlgebra :: diffAlgebra ::
( Foldable f ( Foldable f
, Member Fresh sig , Member Fresh sig

2
src/Rendering/TOC.hs
View File

@ -26,9 +26,9 @@ import Data.List (sortOn)
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map.Monoidal as Map import qualified Data.Map.Monoidal as Map
import Data.Patch import Data.Patch
import Data.Location
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
import Source.Loc
data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] } data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)

12
src/Semantic/Api/Diffs.hs
View File

@ -23,7 +23,6 @@ import Data.Diff
import Data.Graph import Data.Graph
import Data.JSON.Fields import Data.JSON.Fields
import Data.Language import Data.Language
import Data.Location
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
@ -39,6 +38,7 @@ import Semantic.Task as Task
import Semantic.Telemetry as Stat import Semantic.Telemetry as Stat
import Serializing.Format hiding (JSON) import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format import qualified Serializing.Format as Format
import Source.Loc
data DiffOutputFormat data DiffOutputFormat
= DiffJSONTree = DiffJSONTree
@ -55,7 +55,7 @@ parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
parseDiffBuilder DiffShow = distributeFoldMap showDiff parseDiffBuilder DiffShow = distributeFoldMap showDiff
parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff
type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Location Location -> m (Rendering.JSON.JSON "diffs" SomeJSON) type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blobPair jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blobPair
@ -63,7 +63,7 @@ jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blob
jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Location Location -> m (Rendering.JSON.JSON "diffs" SomeJSON) renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
renderJSONTree blobPair = pure . renderJSONDiff blobPair renderJSONTree blobPair = pure . renderJSONDiff blobPair
diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
@ -77,7 +77,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor
path = T.pack $ pathForBlobPair blobPair path = T.pack $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair lang = bridging # languageForBlobPair blobPair
render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Loc Loc -> m DiffTreeFileGraph
render _ diff = render _ diff =
let graph = renderTreeGraph diff let graph = renderTreeGraph diff
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b) toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
@ -111,7 +111,7 @@ type TermPairConstraints =
] ]
doDiff :: (DiffEffects sig m) doDiff :: (DiffEffects sig m)
=> BlobPair -> Decorate m Location ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output => BlobPair -> Decorate m Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
doDiff blobPair decorate render = do doDiff blobPair decorate render = do
SomeTermPair terms <- doParse blobPair decorate SomeTermPair terms <- doParse blobPair decorate
diff <- diffTerms blobPair terms diff <- diffTerms blobPair terms
@ -125,7 +125,7 @@ diffTerms blobs terms = time "diff" languageTag $ do
where languageTag = languageTagForBlobPair blobs where languageTag = languageTagForBlobPair blobs
doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m) doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m)
=> BlobPair -> Decorate m Location ann -> m (SomeTermPair TermPairConstraints ann) => BlobPair -> Decorate m Loc ann -> m (SomeTermPair TermPairConstraints ann)
doParse blobPair decorate = case languageForBlobPair blobPair of doParse blobPair decorate = case languageForBlobPair blobPair of
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob) Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob)
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse haskellParser blob >>= decorate blob) Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse haskellParser blob >>= decorate blob)

6
src/Semantic/Api/Symbols.hs
View File

@ -12,7 +12,6 @@ import Control.Exception
import Control.Lens import Control.Lens
import Data.Blob hiding (File (..)) import Data.Blob hiding (File (..))
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Location
import Data.Maybe import Data.Maybe
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
@ -26,6 +25,7 @@ import Semantic.Api.Terms (ParseEffects, doParse)
import Semantic.Proto.SemanticPB hiding (Blob) import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task import Semantic.Task
import Serializing.Format import Serializing.Format
import Source.Loc
import Tags.Taggable import Tags.Taggable
import Tags.Tagging import Tags.Tagging
@ -41,7 +41,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
symbolsToSummarize :: [Text] symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"] symbolsToSummarize = ["Function", "Method", "Class", "Module"]
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m [Legacy.File] renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m [Legacy.File]
renderToSymbols = pure . pure . tagsToFile . runTagging blob symbolsToSummarize renderToSymbols = pure . pure . tagsToFile . runTagging blob symbolsToSummarize
tagsToFile :: [Tag] -> Legacy.File tagsToFile :: [Tag] -> Legacy.File
@ -72,7 +72,7 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
symbolsToSummarize :: [Text] symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"] symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m File renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m File
renderToSymbols term = pure $ tagsToFile (runTagging blob symbolsToSummarize term) renderToSymbols term = pure $ tagsToFile (runTagging blob symbolsToSummarize term)
tagsToFile :: [Tag] -> File tagsToFile :: [Tag] -> File

6
src/Semantic/Api/Terms.hs
View File

@ -26,7 +26,6 @@ import Data.Either
import Data.Graph import Data.Graph
import Data.JSON.Fields import Data.JSON.Fields
import Data.Language import Data.Language
import Data.Location
import Data.Quieterm import Data.Quieterm
import Data.Term import Data.Term
import qualified Data.Text as T import qualified Data.Text as T
@ -41,6 +40,7 @@ import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task import Semantic.Task
import Serializing.Format hiding (JSON) import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format import qualified Serializing.Format as Format
import Source.Loc
import Tags.Taggable import Tags.Taggable
termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse
@ -54,7 +54,7 @@ termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor
path = T.pack $ blobPath blob path = T.pack $ blobPath blob
lang = bridging # blobLanguage blob lang = bridging # blobLanguage blob
render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Loc -> ParseTreeFileGraph
render t = let graph = renderTreeGraph t render t = let graph = renderTreeGraph t
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b) toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
@ -113,7 +113,7 @@ type TermConstraints =
, Traversable , Traversable
] ]
doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Location) doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Loc)
doParse blob = case blobLanguage blob of doParse blob = case blobLanguage blob of
Go -> SomeTerm <$> parse goParser blob Go -> SomeTerm <$> parse goParser blob
Haskell -> SomeTerm <$> parse haskellParser blob Haskell -> SomeTerm <$> parse haskellParser blob

10
src/Semantic/Graph.hs
View File

@ -55,7 +55,6 @@ import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, Vertex
import Data.Language as Language import Data.Language as Language
import Data.List (isPrefixOf, isSuffixOf) import Data.List (isPrefixOf, isSuffixOf)
import Data.Project import Data.Project
import Data.Location
import Data.Term import Data.Term
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
import Language.Haskell.HsColour import Language.Haskell.HsColour
@ -64,6 +63,7 @@ import Parsing.Parser
import Prologue hiding (TypeError (..)) import Prologue hiding (TypeError (..))
import Semantic.Analysis import Semantic.Analysis
import Semantic.Task as Task import Semantic.Task as Task
import Source.Loc
import Source.Span import Source.Span
import System.FilePath.Posix (takeDirectory, (</>)) import System.FilePath.Posix (takeDirectory, (</>))
import Text.Show.Pretty (ppShow) import Text.Show.Pretty (ppShow)
@ -102,7 +102,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
, Ord1 syntax , Ord1 syntax
, Functor syntax , Functor syntax
, Evaluatable syntax , Evaluatable syntax
, term ~ Term syntax Location , term ~ Term syntax Loc
, FreeVariables1 syntax , FreeVariables1 syntax
, HasPrelude lang , HasPrelude lang
, Member Trace sig , Member Trace sig
@ -255,7 +255,7 @@ parsePythonPackage :: forall syntax sig m term.
, FreeVariables1 syntax , FreeVariables1 syntax
, AccessControls1 syntax , AccessControls1 syntax
, Functor syntax , Functor syntax
, term ~ Term syntax Location , term ~ Term syntax Loc
, Member (Error SomeException) sig , Member (Error SomeException) sig
, Member Distribute sig , Member Distribute sig
, Member Resolution sig , Member Resolution sig
@ -335,11 +335,11 @@ withTermSpans :: ( Member (Reader Span) sig
, Member (State Span) sig -- last evaluated child's span , Member (State Span) sig -- last evaluated child's span
, Recursive term , Recursive term
, Carrier sig m , Carrier sig m
, Base term ~ TermF syntax Location , Base term ~ TermF syntax Loc
) )
=> Open (term -> Evaluator term address value m a) => Open (term -> Evaluator term address value m a)
withTermSpans recur term = let withTermSpans recur term = let
span = locationSpan (termFAnnotation (project term)) span = locSpan (termFAnnotation (project term))
updatedSpanAlg = withCurrentSpan span (recur term) updatedSpanAlg = withCurrentSpan span (recur term)
in modifyChildSpan span updatedSpanAlg in modifyChildSpan span updatedSpanAlg

20
src/Semantic/Task.hs
View File

@ -71,7 +71,6 @@ import Data.ByteString.Builder
import Data.Diff import Data.Diff
import qualified Data.Error as Error import qualified Data.Error as Error
import qualified Data.Flag as Flag import qualified Data.Flag as Flag
import Data.Location
import Data.Source (Source) import Data.Source (Source)
import Data.Sum import Data.Sum
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
@ -89,6 +88,7 @@ import Semantic.Timeout
import Semantic.Resolution import Semantic.Resolution
import Semantic.Telemetry import Semantic.Telemetry
import Serializing.Format hiding (Options) import Serializing.Format hiding (Options)
import Source.Loc
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff type TaskEff
@ -117,8 +117,8 @@ parse parser blob = send (Parse parser blob pure)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: (Functor f, Member Task sig, Carrier sig m) decorate :: (Functor f, Member Task sig, Carrier sig m)
=> RAlgebra (TermF f Location) (Term f Location) field => RAlgebra (TermF f Loc) (Term f Loc) field
-> Term f Location -> Term f Loc
-> m (Term f field) -> m (Term f field)
decorate algebra term = send (Decorate algebra term pure) decorate algebra term = send (Decorate algebra term pure)
@ -198,7 +198,7 @@ instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (Trace
-- | An effect describing high-level tasks to be performed. -- | An effect describing high-level tasks to be performed.
data Task (m :: * -> *) k data Task (m :: * -> *) k
= forall term . Parse (Parser term) Blob (term -> m k) = forall term . Parse (Parser term) Blob (term -> m k)
| forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> m k) | forall f field . Functor f => Decorate (RAlgebra (TermF f Loc) (Term f Loc) field) (Term f Loc) (Term f field -> m k)
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k) | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k)
| forall input output . Render (Renderer input output) input (output -> m k) | forall input output . Render (Renderer input output) input (output -> m k)
| forall input . Serialize (Format input) input (Builder -> m k) | forall input . Serialize (Format input) input (Builder -> m k)
@ -277,9 +277,9 @@ runParser blob@Blob{..} parser = case parser of
in length term `seq` pure term in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser blob parser SomeParser parser -> SomeTerm <$> runParser blob parser
where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage blob where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage blob
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Location -> [Error.Error String] errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String]
errors = cata $ \ (In Assignment.Location{..} syntax) -> case syntax of errors = cata $ \ (In Assignment.Loc{..} syntax) -> case syntax of
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locationSpan err] _ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locSpan err]
_ -> fold syntax _ -> fold syntax
runAssignment :: ( Apply Foldable syntaxes runAssignment :: ( Apply Foldable syntaxes
, Apply Functor syntaxes , Apply Functor syntaxes
@ -294,10 +294,10 @@ runParser blob@Blob{..} parser = case parser of
, Carrier sig m , Carrier sig m
, MonadIO m , MonadIO m
) )
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location)) => (Source -> assignment (Term (Sum syntaxes) Assignment.Loc) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Loc))
-> Parser ast -> Parser ast
-> assignment (Term (Sum syntaxes) Assignment.Location) -> assignment (Term (Sum syntaxes) Assignment.Loc)
-> m (Term (Sum syntaxes) Assignment.Location) -> m (Term (Sum syntaxes) Assignment.Loc)
runAssignment assign parser assignment = do runAssignment assign parser assignment = do
taskSession <- ask taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession) let requestID' = ("github_request_id", requestID taskSession)

6
src/Semantic/Util.hs
View File

@ -33,7 +33,6 @@ import Data.Blob.IO
import Data.Graph (topologicalSort) import Data.Graph (topologicalSort)
import qualified Data.Language as Language import qualified Data.Language as Language
import Data.List (uncons) import Data.List (uncons)
import Data.Location
import Data.Project hiding (readFile) import Data.Project hiding (readFile)
import Data.Quieterm (Quieterm, quieterm) import Data.Quieterm (Quieterm, quieterm)
import Data.Sum (weaken) import Data.Sum (weaken)
@ -48,6 +47,7 @@ import Semantic.Analysis
import Semantic.Config import Semantic.Config
import Semantic.Graph import Semantic.Graph
import Semantic.Task import Semantic.Task
import Source.Loc
import System.Exit (die) import System.Exit (die)
import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (takeDirectory)
@ -76,10 +76,10 @@ justEvaluating
type FileEvaluator err syntax = type FileEvaluator err syntax =
[FilePath] [FilePath]
-> IO -> IO
( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise), ( Heap Precise Precise (Value (Quieterm (Sum syntax) Loc) Precise),
( ScopeGraph Precise ( ScopeGraph Precise
, Either (SomeError (Sum err)) , Either (SomeError (Sum err))
(ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Location) Precise)))))) (ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Loc) Precise))))))
evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax
evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser

35
src/Semantic/UtilDisabled.hs
View File

@ -48,11 +48,10 @@ import Semantic.Analysis
import Semantic.Config import Semantic.Config
import Semantic.Graph import Semantic.Graph
import Semantic.Task import Semantic.Task
import Source.Loc
import System.Exit (die) import System.Exit (die)
import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (takeDirectory)
import Data.Location
type ProjectEvaluator syntax = type ProjectEvaluator syntax =
Project Project
-> IO -> IO
@ -60,7 +59,7 @@ type ProjectEvaluator syntax =
(Hole (Maybe Name) Precise) (Hole (Maybe Name) Precise)
(Hole (Maybe Name) Precise) (Hole (Maybe Name) Precise)
(Value (Value
(Quieterm (Sum syntax) Location) (Quieterm (Sum syntax) Loc)
(Hole (Maybe Name) Precise)), (Hole (Maybe Name) Precise)),
(ScopeGraph (Hole (Maybe Name) Precise), (ScopeGraph (Hole (Maybe Name) Precise),
ModuleTable ModuleTable
@ -68,7 +67,7 @@ type ProjectEvaluator syntax =
(ModuleResult (ModuleResult
(Hole (Maybe Name) Precise) (Hole (Maybe Name) Precise)
(Value (Value
(Quieterm (Sum syntax) Location) (Quieterm (Sum syntax) Loc)
(Hole (Maybe Name) Precise)))))) (Hole (Maybe Name) Precise))))))
type FileTypechecker (syntax :: [* -> *]) qterm value address result type FileTypechecker (syntax :: [* -> *]) qterm value address result
@ -132,7 +131,7 @@ type EvalEffects qterm err = ResumableC (BaseError err)
-- We can't go with the inferred type because this needs to be -- We can't go with the inferred type because this needs to be
-- polymorphic in @lang@. -- polymorphic in @lang@.
justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
, term ~ Quieterm (Sum lang) Location , term ~ Quieterm (Sum lang) Loc
, value ~ Concrete.Value term hole , value ~ Concrete.Value term hole
, Apply Show1 lang , Apply Show1 lang
) )
@ -149,7 +148,7 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
(ResumableWithC (BaseError (LoadError hole value)) (ResumableWithC (BaseError (LoadError hole value))
(FreshC (FreshC
(StateC (ScopeGraph hole) (StateC (ScopeGraph hole)
(StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise))) (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Loc) (Hole (Maybe Name) Precise)))
(TraceByPrintingC (TraceByPrintingC
(LiftC IO))))))))))))) a (LiftC IO))))))))))))) a
-> IO (Heap hole hole value, (ScopeGraph hole, a)) -> IO (Heap hole hole value, (ScopeGraph hole, a))
@ -200,7 +199,7 @@ callGraphProject
syntax syntax
syntax) => syntax) =>
Parser Parser
(Term syntax Location) (Term syntax Loc)
-> Proxy lang -> Proxy lang
-> [FilePath] -> [FilePath]
-> IO -> IO
@ -238,7 +237,7 @@ evalJavaScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser
typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location , qterm ~ Quieterm (Sum syntax) Loc
, value ~ Type , value ~ Type
, address ~ Monovariant , address ~ Monovariant
, result ~ (ModuleTable (Module (ModuleResult address value)))) , result ~ (ModuleTable (Module (ModuleResult address value))))
@ -246,15 +245,15 @@ typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser
typecheckRubyFile :: ( syntax ~ Language.Ruby.Assignment.Syntax typecheckRubyFile :: ( syntax ~ Language.Ruby.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location , qterm ~ Quieterm (Sum syntax) Loc
, value ~ Type , value ~ Type
, address ~ Monovariant , address ~ Monovariant
, result ~ (ModuleTable (Module (ModuleResult address value)))) , result ~ (ModuleTable (Module (ModuleResult address value))))
=> FileTypechecker syntax qterm value address result => FileTypechecker syntax qterm value address result
typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser
evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Loc
, qterm ~ Quieterm (Sum syntax) Location , qterm ~ Quieterm (Sum syntax) Loc
, address ~ Hole (Maybe Name) Precise , address ~ Hole (Maybe Name) Precise
, LanguageSyntax lang syntax , LanguageSyntax lang syntax
) )
@ -290,8 +289,8 @@ evaluateProjectForScopeGraph proxy parser project = runTask' $ do
(raiseHandler (runReader (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span))
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules))))))) (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Loc
, qterm ~ Quieterm (Sum syntax) Location , qterm ~ Quieterm (Sum syntax) Loc
, LanguageSyntax lang syntax , LanguageSyntax lang syntax
) )
=> Proxy (lang :: Language.Language) => Proxy (lang :: Language.Language)
@ -309,8 +308,8 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
(ResumableC (BaseError (LoadError Monovariant Type)) (ResumableC (BaseError (LoadError Monovariant Type))
(ReaderC (Live Monovariant) (ReaderC (Live Monovariant)
(NonDetC (NonDetC
(ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Loc) Monovariant Type)
(StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Loc) Monovariant Type)
(FreshC (FreshC
(StateC (ScopeGraph Monovariant) (StateC (ScopeGraph Monovariant)
(StateC (Heap Monovariant Monovariant Type) (StateC (Heap Monovariant Monovariant Type)
@ -341,8 +340,8 @@ type LanguageSyntax lang syntax = ( Language.SLanguage lang
, Apply AccessControls1 syntax , Apply AccessControls1 syntax
, Apply FreeVariables1 syntax) , Apply FreeVariables1 syntax)
evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Location evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Loc
, qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Location , qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Loc
) )
=> Proxy 'Language.Python => Proxy 'Language.Python
-> Parser term -> Parser term
@ -366,7 +365,7 @@ evaluatePythonProjects proxy parser lang path = runTask' $ do
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules))))))) (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
evaluatePythonProject :: ( syntax ~ Language.Python.Assignment.Syntax evaluatePythonProject :: ( syntax ~ Language.Python.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location , qterm ~ Quieterm (Sum syntax) Loc
, value ~ (Concrete.Value qterm address) , value ~ (Concrete.Value qterm address)
, address ~ Precise , address ~ Precise
, result ~ (ModuleTable (Module (ModuleResult address value)))) => FilePath , result ~ (ModuleTable (Module (ModuleResult address value)))) => FilePath

58
src/Tags/Taggable.hs
View File

@ -31,9 +31,9 @@ import Data.Abstract.Declarations
import Data.Abstract.Name import Data.Abstract.Name
import Data.Blob import Data.Blob
import Data.Language import Data.Language
import Data.Location
import Data.Term import Data.Term
import Data.Text hiding (empty) import Data.Text hiding (empty)
import Source.Loc
import Source.Range import Source.Range
import Streaming hiding (Sum) import Streaming hiding (Sum)
@ -67,11 +67,11 @@ class Taggable constr where
( Foldable syntax ( Foldable syntax
, HasTextElement syntax , HasTextElement syntax
) )
=> Language -> constr (Term syntax Location) -> Maybe Range => Language -> constr (Term syntax Loc) -> Maybe Range
snippet :: Foldable syntax => Location -> constr (Term syntax Location) -> Maybe Range snippet :: Foldable syntax => Loc -> constr (Term syntax Loc) -> Maybe Range
symbolName :: Declarations1 syntax => constr (Term syntax Location) -> Maybe Name symbolName :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name
data Strategy = Default | Custom data Strategy = Default | Custom
@ -80,13 +80,13 @@ class TaggableBy (strategy :: Strategy) constr where
( Foldable syntax ( Foldable syntax
, HasTextElement syntax , HasTextElement syntax
) )
=> Language -> constr (Term syntax Location) -> Maybe Range => Language -> constr (Term syntax Loc) -> Maybe Range
docsLiteral' _ _ = Nothing docsLiteral' _ _ = Nothing
snippet' :: (Foldable syntax) => Location -> constr (Term syntax Location) -> Maybe Range snippet' :: (Foldable syntax) => Loc -> constr (Term syntax Loc) -> Maybe Range
snippet' _ _ = Nothing snippet' _ _ = Nothing
symbolName' :: Declarations1 syntax => constr (Term syntax Location) -> Maybe Name symbolName' :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name
symbolName' _ = Nothing symbolName' _ = Nothing
type IsTaggable syntax = type IsTaggable syntax =
@ -100,28 +100,28 @@ type IsTaggable syntax =
tagging :: (Monad m, IsTaggable syntax) tagging :: (Monad m, IsTaggable syntax)
=> Blob => Blob
-> Term syntax Location -> Term syntax Loc
-> Stream (Of Token) m () -> Stream (Of Token) m ()
tagging b = foldSubterms (descend (blobLanguage b)) tagging b = foldSubterms (descend (blobLanguage b))
descend :: descend ::
( ConstructorName (TermF syntax Location) ( ConstructorName (TermF syntax Loc)
, IsTaggable syntax , IsTaggable syntax
, Monad m , Monad m
) )
=> Language -> SubtermAlgebra (TermF syntax Location) (Term syntax Location) (Tagger m ()) => Language -> SubtermAlgebra (TermF syntax Loc) (Term syntax Loc) (Tagger m ())
descend lang t@(In loc _) = do descend lang t@(In loc _) = do
let term = fmap subterm t let term = fmap subterm t
let snippetRange = snippet loc term let snippetRange = snippet loc term
let litRange = docsLiteral lang term let litRange = docsLiteral lang term
enter (constructorName term) snippetRange enter (constructorName term) snippetRange
maybe (pure ()) (emitIden (locationSpan loc) litRange) (symbolName term) maybe (pure ()) (emitIden (locSpan loc) litRange) (symbolName term)
traverse_ subtermRef t traverse_ subtermRef t
exit (constructorName term) snippetRange exit (constructorName term) snippetRange
subtractLocation :: Location -> Location -> Range subtractLoc :: Loc -> Loc -> Range
subtractLocation a b = subtractRange (locationByteRange a) (locationByteRange b) subtractLoc a b = subtractRange (locByteRange a) (locByteRange b)
-- Instances -- Instances
@ -151,60 +151,60 @@ instance Apply Taggable fs => TaggableBy 'Custom (Sum fs) where
snippet' x = apply @Taggable (snippet x) snippet' x = apply @Taggable (snippet x)
symbolName' = apply @Taggable symbolName symbolName' = apply @Taggable symbolName
instance Taggable a => TaggableBy 'Custom (TermF a Location) where instance Taggable a => TaggableBy 'Custom (TermF a Loc) where
docsLiteral' l t = docsLiteral l (termFOut t) docsLiteral' l t = docsLiteral l (termFOut t)
snippet' ann t = snippet ann (termFOut t) snippet' ann t = snippet ann (termFOut t)
symbolName' t = symbolName (termFOut t) symbolName' t = symbolName (termFOut t)
instance TaggableBy 'Custom Syntax.Context where instance TaggableBy 'Custom Syntax.Context where
snippet' ann (Syntax.Context _ (Term (In subj _))) = Just (subtractLocation ann subj) snippet' ann (Syntax.Context _ (Term (In subj _))) = Just (subtractLoc ann subj)
instance TaggableBy 'Custom Declaration.Function where instance TaggableBy 'Custom Declaration.Function where
docsLiteral' Python (Declaration.Function _ _ _ (Term (In _ bodyF))) docsLiteral' Python (Declaration.Function _ _ _ (Term (In _ bodyF)))
| (Term (In exprAnn exprF):_) <- toList bodyF | (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn) , isTextElement exprF = Just (locByteRange exprAnn)
| otherwise = Nothing | otherwise = Nothing
docsLiteral' _ _ = Nothing docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Function _ _ _ (Term (In body _))) = Just $ subtractLocation ann body snippet' ann (Declaration.Function _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.functionName symbolName' = declaredName . Declaration.functionName
instance TaggableBy 'Custom Declaration.Method where instance TaggableBy 'Custom Declaration.Method where
docsLiteral' Python (Declaration.Method _ _ _ _ (Term (In _ bodyF)) _) docsLiteral' Python (Declaration.Method _ _ _ _ (Term (In _ bodyF)) _)
| (Term (In exprAnn exprF):_) <- toList bodyF | (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn) , isTextElement exprF = Just (locByteRange exprAnn)
| otherwise = Nothing | otherwise = Nothing
docsLiteral' _ _ = Nothing docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Method _ _ _ _ (Term (In body _)) _) = Just $ subtractLocation ann body snippet' ann (Declaration.Method _ _ _ _ (Term (In body _)) _) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.methodName symbolName' = declaredName . Declaration.methodName
instance TaggableBy 'Custom Declaration.Class where instance TaggableBy 'Custom Declaration.Class where
docsLiteral' Python (Declaration.Class _ _ _ (Term (In _ bodyF))) docsLiteral' Python (Declaration.Class _ _ _ (Term (In _ bodyF)))
| (Term (In exprAnn exprF):_) <- toList bodyF | (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn) , isTextElement exprF = Just (locByteRange exprAnn)
| otherwise = Nothing | otherwise = Nothing
docsLiteral' _ _ = Nothing docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Class _ _ _ (Term (In body _))) = Just $ subtractLocation ann body snippet' ann (Declaration.Class _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.classIdentifier symbolName' = declaredName . Declaration.classIdentifier
instance TaggableBy 'Custom Ruby.Class where instance TaggableBy 'Custom Ruby.Class where
snippet' ann (Ruby.Class _ _ (Term (In body _))) = Just $ subtractLocation ann body snippet' ann (Ruby.Class _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Ruby.classIdentifier symbolName' = declaredName . Ruby.classIdentifier
instance TaggableBy 'Custom Ruby.Module where instance TaggableBy 'Custom Ruby.Module where
snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
snippet' ann (Ruby.Module _ _) = Just $ locationByteRange ann snippet' ann (Ruby.Module _ _) = Just $ locByteRange ann
symbolName' = declaredName . Ruby.moduleIdentifier symbolName' = declaredName . Ruby.moduleIdentifier
instance TaggableBy 'Custom TypeScript.Module where instance TaggableBy 'Custom TypeScript.Module where
snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
snippet' ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann snippet' ann (TypeScript.Module _ _ ) = Just $ locByteRange ann
symbolName' = declaredName . TypeScript.moduleIdentifier symbolName' = declaredName . TypeScript.moduleIdentifier
instance TaggableBy 'Custom Expression.Call where instance TaggableBy 'Custom Expression.Call where
snippet' ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLocation ann body snippet' ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Expression.callFunction symbolName' = declaredName . Expression.callFunction
instance TaggableBy 'Custom Ruby.Send where instance TaggableBy 'Custom Ruby.Send where
snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLoc ann body
snippet' ann _ = Just $ locationByteRange ann snippet' ann _ = Just $ locByteRange ann
symbolName' Ruby.Send{..} = declaredName =<< sendSelector symbolName' Ruby.Send{..} = declaredName =<< sendSelector

4
src/Tags/Tagging.hs
View File

@ -14,16 +14,16 @@ import Streaming
import qualified Streaming.Prelude as Streaming import qualified Streaming.Prelude as Streaming
import Data.Blob import Data.Blob
import Data.Location
import qualified Data.Source as Source import qualified Data.Source as Source
import Data.Tag import Data.Tag
import Data.Term import Data.Term
import Source.Loc
import Tags.Taggable import Tags.Taggable
runTagging :: (IsTaggable syntax) runTagging :: (IsTaggable syntax)
=> Blob => Blob
-> [Text] -> [Text]
-> Term syntax Location -> Term syntax Loc
-> [Tag] -> [Tag]
runTagging blob symbolsToSummarize runTagging blob symbolsToSummarize
= Eff.run = Eff.run

6
test/Analysis/TypeScript/Spec.hs
View File

@ -14,12 +14,12 @@ import Data.Abstract.Number as Number
import Data.Abstract.Package (PackageInfo (..)) import Data.Abstract.Package (PackageInfo (..))
import Data.Abstract.Value.Concrete as Concrete import Data.Abstract.Value.Concrete as Concrete
import qualified Data.Language as Language import qualified Data.Language as Language
import Data.Location
import Data.Quieterm import Data.Quieterm
import Data.Scientific (scientific) import Data.Scientific (scientific)
import Data.Sum import Data.Sum
import Data.Text (pack) import Data.Text (pack)
import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.TypeScript.Assignment as TypeScript
import Source.Loc
import SpecHelpers import SpecHelpers
spec :: (?session :: TaskSession) => Spec spec :: (?session :: TaskSession) => Spec
@ -176,7 +176,7 @@ spec = do
it "member access of private methods throws AccessControlError" $ do it "member access of private methods throws AccessControlError" $ do
(_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_method.ts"] (_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_method.ts"]
let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo "private_method.ts" Language.TypeScript mempty) (Span (Pos 4 1) (Pos 4 16)) (AccessControlError ("foo", ScopeGraph.Public) ("private_add", ScopeGraph.Private) (Closure (PackageInfo "access_control" mempty) (ModuleInfo "adder.ts" Language.TypeScript mempty) (Just "private_add") Nothing [] (Right (Quieterm (In (Location (Range 146 148) (Span (Pos 7 27) (Pos 7 29))) (inject (StatementBlock []))))) (Precise 20) (Precise 18)))))) let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo "private_method.ts" Language.TypeScript mempty) (Span (Pos 4 1) (Pos 4 16)) (AccessControlError ("foo", ScopeGraph.Public) ("private_add", ScopeGraph.Private) (Closure (PackageInfo "access_control" mempty) (ModuleInfo "adder.ts" Language.TypeScript mempty) (Just "private_add") Nothing [] (Right (Quieterm (In (Loc (Range 146 148) (Span (Pos 7 27) (Pos 7 29))) (inject (StatementBlock []))))) (Precise 20) (Precise 18))))))
res `shouldBe` expected res `shouldBe` expected
where where
@ -184,5 +184,5 @@ spec = do
evaluate = evalTypeScriptProject . map (fixtures <>) evaluate = evalTypeScriptProject . map (fixtures <>)
evalTypeScriptProject = testEvaluating <=< (evaluateProject' ?session (Proxy :: Proxy 'Language.TypeScript) typescriptParser) evalTypeScriptProject = testEvaluating <=< (evaluateProject' ?session (Proxy :: Proxy 'Language.TypeScript) typescriptParser)
type TypeScriptTerm = Quieterm (Sum TypeScript.Syntax) Location type TypeScriptTerm = Quieterm (Sum TypeScript.Syntax) Loc
type TypeScriptEvalError = BaseError (EvalError TypeScriptTerm Precise (Concrete.Value TypeScriptTerm Precise)) type TypeScriptEvalError = BaseError (EvalError TypeScriptTerm Precise (Concrete.Value TypeScriptTerm Precise))

2
test/Assigning/Assignment/Spec.hs
View File

@ -255,7 +255,7 @@ spec = do
Left [ "symbol" ] Left [ "symbol" ]
node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol
node symbol start end children = Term (Node symbol (Location (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children) node symbol start end children = Term (Node symbol (Loc (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children)
data Grammar = Palette | Red | Green | Blue | Magenta data Grammar = Palette | Red | Green | Blue | Magenta
deriving (Bounded, Enum, Eq, Ix, Ord, Show) deriving (Bounded, Enum, Eq, Ix, Ord, Show)

6
test/Data/Functor/Listable.hs
View File

@ -28,7 +28,6 @@ import Data.Functor.Both
import qualified Data.Language as Language import qualified Data.Language as Language
import Data.List.NonEmpty import Data.List.NonEmpty
import Data.Patch import Data.Patch
import Data.Location
import Data.Semigroup.App import Data.Semigroup.App
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Literal as Literal
@ -45,6 +44,7 @@ import Data.Text as T (Text, pack)
import Data.These import Data.These
import Data.Sum import Data.Sum
import Diffing.Algorithm.RWS import Diffing.Algorithm.RWS
import Source.Loc
import Source.Range import Source.Range
import Source.Span import Source.Span
import Test.LeanCheck import Test.LeanCheck
@ -542,8 +542,8 @@ instance Listable (f a) => Listable (App f a) where
instance Listable (f a) => Listable (AppMerge f a) where instance Listable (f a) => Listable (AppMerge f a) where
tiers = cons1 AppMerge tiers = cons1 AppMerge
instance Listable Location where instance Listable Loc where
tiers = cons2 Location tiers = cons2 Loc
instance Listable Range where instance Listable Range where
tiers = cons2 Range tiers = cons2 Range

4
test/Rendering/TOC/Spec.hs
View File

@ -10,7 +10,6 @@ import Data.Diff
import Data.Functor.Classes import Data.Functor.Classes
import Data.Hashable.Lifted import Data.Hashable.Lifted
import Data.Patch import Data.Patch
import Data.Location
import Data.Sum import Data.Sum
import Data.Term import Data.Term
import Data.Text (Text) import Data.Text (Text)
@ -22,6 +21,7 @@ import qualified Data.Syntax.Declaration as Declaration
import Rendering.TOC import Rendering.TOC
import Semantic.Api (diffSummaryBuilder) import Semantic.Api (diffSummaryBuilder)
import Serializing.Format as Format import Serializing.Format as Format
import Source.Loc
import Source.Span import Source.Span
import SpecHelpers import SpecHelpers
@ -233,7 +233,7 @@ diffWithParser :: ( Eq1 syntax
, Member Task sig , Member Task sig
, Carrier sig m , Carrier sig m
) )
=> Parser (Term syntax Location) => Parser (Term syntax Loc)
-> BlobPair -> BlobPair
-> m (Diff syntax (Maybe Declaration) (Maybe Declaration)) -> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin