mirror of
https://github.com/github/semantic.git
synced 2024-12-23 06:41:45 +03:00
Switch everything over to using Source.Loc.
This commit is contained in:
parent
17c61c19d1
commit
0f8e69c72f
@ -73,7 +73,7 @@ TODO: explain how traversal works in terms of matching/advancing -->
|
||||
|
||||
#### 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.
|
||||
|
||||
|
@ -159,7 +159,6 @@ library
|
||||
, Data.ImportPath
|
||||
, Data.JSON.Fields
|
||||
, Data.Language
|
||||
, Data.Location
|
||||
, Data.Map.Monoidal
|
||||
, Data.Patch
|
||||
, Data.Project
|
||||
|
@ -27,10 +27,10 @@ import Data.ByteString.Builder
|
||||
import Data.Graph
|
||||
import Data.Graph.ControlFlowVertex
|
||||
import Data.Term
|
||||
import Data.Location
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
|
||||
style :: Style ControlFlowVertex Builder
|
||||
style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
|
||||
@ -74,7 +74,7 @@ graphingTerms :: ( Member (Reader ModuleInfo) sig
|
||||
, Declarations1 syntax
|
||||
, Ord address
|
||||
, Foldable syntax
|
||||
, term ~ Term syntax Location
|
||||
, term ~ Term syntax Loc
|
||||
, Carrier sig m
|
||||
)
|
||||
=> Open (term -> Evaluator term address value m a)
|
||||
|
@ -6,13 +6,13 @@ module Analysis.PackageDef
|
||||
) where
|
||||
|
||||
import Data.Blob
|
||||
import Data.Location
|
||||
import Data.Source as Source
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.Go.Syntax
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
|
||||
newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
|
||||
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 '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
|
||||
|
||||
|
||||
@ -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.
|
||||
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').
|
||||
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.
|
||||
--
|
||||
@ -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).
|
||||
class CustomHasPackageDef syntax where
|
||||
-- | 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
|
||||
customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In 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'.
|
||||
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.
|
||||
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.
|
||||
|
@ -13,12 +13,12 @@ import Data.Blob
|
||||
import Data.Error (Error (..), Colourize (..), showExpectation)
|
||||
import Data.Flag
|
||||
import Data.Language as Language
|
||||
import Data.Location
|
||||
import Data.Source as Source
|
||||
import qualified Data.Syntax as Syntax
|
||||
import qualified Data.Syntax.Declaration as Declaration
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import Source.Loc
|
||||
import Source.Range
|
||||
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.
|
||||
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
|
||||
|
||||
-- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass
|
||||
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
|
||||
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.
|
||||
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').
|
||||
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.
|
||||
--
|
||||
@ -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).
|
||||
class CustomHasDeclaration whole syntax where
|
||||
-- | 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.
|
||||
instance CustomHasDeclaration whole Markdown.Heading where
|
||||
customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _)
|
||||
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) (blobLanguage blob) level
|
||||
where headingText terms = getSource $ maybe (locationByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
|
||||
headingByteRange (Term (In ann _), _) = locationByteRange ann
|
||||
= Just $ HeadingDeclaration (headingText terms) mempty (locSpan ann) (blobLanguage blob) level
|
||||
where headingText terms = getSource $ maybe (locByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
|
||||
headingByteRange (Term (In ann _), _) = locByteRange ann
|
||||
getSource = firstLine . toText . flip Source.slice blobSource
|
||||
firstLine = T.takeWhile (/= '\n')
|
||||
|
||||
-- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
|
||||
instance CustomHasDeclaration whole Syntax.Error where
|
||||
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) ""
|
||||
|
||||
-- | 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
|
||||
| isEmpty identifierAnn = Nothing
|
||||
-- Named functions
|
||||
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) (blobLanguage blob)
|
||||
where isEmpty = (== 0) . rangeLength . locationByteRange
|
||||
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locSpan ann) (blobLanguage blob)
|
||||
where isEmpty = (== 0) . rangeLength . locByteRange
|
||||
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'.
|
||||
instance CustomHasDeclaration whole Declaration.Method where
|
||||
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
|
||||
-- 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).
|
||||
| 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`
|
||||
| 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
|
||||
isEmpty = (== 0) . rangeLength . locationByteRange
|
||||
isEmpty = (== 0) . rangeLength . locByteRange
|
||||
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
|
||||
|
||||
-- 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
|
||||
-- to a location, which is found via the passed-in rule.
|
||||
getIdentifier :: Functor m
|
||||
=> Rewrite (m (Term syntax Location)) (Term syntax Location)
|
||||
=> Rewrite (m (Term syntax Loc)) (Term syntax Loc)
|
||||
-> Blob
|
||||
-> TermF m Location (Term syntax Location, a)
|
||||
-> TermF m Loc (Term syntax Loc, a)
|
||||
-> Text
|
||||
getIdentifier finder Blob{..} (In a r)
|
||||
= let declRange = locationByteRange a
|
||||
bodyRange = locationByteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
|
||||
= let declRange = locByteRange a
|
||||
bodyRange = locByteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
|
||||
-- Text-based gyrations to slice the identifier out of the provided blob source
|
||||
sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange
|
||||
in maybe mempty sliceFrom bodyRange
|
||||
|
||||
getSource :: Source -> Location -> Text
|
||||
getSource blobSource = toText . flip Source.slice blobSource . locationByteRange
|
||||
getSource :: Source -> Loc -> Text
|
||||
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'.
|
||||
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.
|
||||
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.
|
||||
|
@ -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.
|
||||
--
|
||||
-- 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.
|
||||
--
|
||||
@ -20,7 +20,7 @@
|
||||
--
|
||||
-- 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.
|
||||
--
|
||||
@ -61,7 +61,7 @@
|
||||
module Assigning.Assignment
|
||||
-- Types
|
||||
( Assignment
|
||||
, L.Location(..)
|
||||
, L.Loc(..)
|
||||
-- Combinators
|
||||
, branchNode
|
||||
, leafNode
|
||||
@ -100,11 +100,11 @@ import qualified Assigning.Assignment.Table as Table
|
||||
import Control.Monad.Except (MonadError (..))
|
||||
import Data.AST
|
||||
import Data.Error
|
||||
import qualified Data.Location as L
|
||||
import qualified Data.Source as Source (Source, slice, sourceBytes)
|
||||
import Data.Term
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8')
|
||||
import qualified Source.Loc as L
|
||||
import Source.Range
|
||||
import Source.Span hiding (HasSpan(..))
|
||||
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.
|
||||
toTerm :: Element syntax syntaxes
|
||||
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Location))
|
||||
-> Assignment ast grammar (Term (Sum syntaxes) L.Location)
|
||||
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Loc))
|
||||
-> Assignment ast grammar (Term (Sum syntaxes) L.Loc)
|
||||
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
|
||||
End :: AssignmentF ast grammar ()
|
||||
Location :: AssignmentF ast grammar L.Location
|
||||
Loc :: AssignmentF ast grammar L.Loc
|
||||
CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ())
|
||||
Source :: AssignmentF ast grammar ByteString
|
||||
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.
|
||||
--
|
||||
-- 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 = tracing Location `Then` pure
|
||||
location :: Assignment ast grammar L.Loc
|
||||
location = tracing Loc `Then` pure
|
||||
|
||||
getLocals :: HasCallStack => Assignment ast grammar [Text]
|
||||
getLocals = tracing GetLocals `Then` pure
|
||||
@ -174,7 +174,7 @@ currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar)
|
||||
currentNode = tracing CurrentNode `Then` pure
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | A rule to produce a node’s source as a ByteString.
|
||||
@ -213,7 +213,7 @@ choice alternatives
|
||||
mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
@ -261,7 +261,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
|
||||
-> Either (Error (Either String grammar)) (result, State ast grammar)
|
||||
run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
|
||||
where atNode (Term (In node f)) = case runTracing t of
|
||||
Location -> yield (nodeLocation node) state
|
||||
Loc -> yield (nodeLocation node) state
|
||||
GetLocals -> yield stateLocals state
|
||||
PutLocals l -> yield () (state { stateLocals = l })
|
||||
CurrentNode -> yield (In node (() <$ f)) state
|
||||
@ -274,7 +274,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
|
||||
|
||||
anywhere node = case runTracing t of
|
||||
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
|
||||
Alt (a:as) -> sconcat (flip yield state <$> a:|as)
|
||||
Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield
|
||||
|
@ -13,12 +13,12 @@ import Data.AST
|
||||
import Data.Error
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.IntSet as IntSet
|
||||
import Data.Location
|
||||
import Data.Source as Source
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Term (Term, termIn, termAnnotation, termOut)
|
||||
import Data.Text.Encoding (decodeUtf8')
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
import Source.Span hiding (HasSpan (..))
|
||||
|
||||
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
|
||||
|
||||
toTerm :: (Element syntax syntaxes, Element Syntax.Error syntaxes)
|
||||
=> f (syntax (Term (Sum syntaxes) Location))
|
||||
-> f (Term (Sum syntaxes) Location)
|
||||
=> f (syntax (Term (Sum syntaxes) Loc))
|
||||
-> f (Term (Sum syntaxes) Loc)
|
||||
|
||||
parseError :: ( Bounded symbol
|
||||
, Element Syntax.Error syntaxes
|
||||
, HasCallStack
|
||||
, 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") [])
|
||||
|
||||
|
||||
@ -167,8 +167,8 @@ stateSpan :: State s -> Span
|
||||
stateSpan state@(State _ _ []) = Span (statePos state) (statePos state)
|
||||
stateSpan (State _ _ (s:_)) = astSpan s
|
||||
|
||||
stateLocation :: State s -> Location
|
||||
stateLocation state = Location (stateRange state) (stateSpan state)
|
||||
stateLocation :: State s -> Loc
|
||||
stateLocation state = Loc (stateRange state) (stateSpan state)
|
||||
|
||||
advanceState :: State s -> State s
|
||||
advanceState state
|
||||
|
@ -6,18 +6,18 @@ module Data.AST
|
||||
, AST
|
||||
) where
|
||||
|
||||
import Data.Location
|
||||
import Data.Term
|
||||
import Data.Aeson
|
||||
import Data.Text (pack)
|
||||
import Data.JSON.Fields
|
||||
import Source.Loc
|
||||
|
||||
-- | An AST node labelled with symbols and source location.
|
||||
type AST syntax grammar = Term syntax (Node grammar)
|
||||
|
||||
data Node grammar = Node
|
||||
{ nodeSymbol :: !grammar
|
||||
, nodeLocation :: {-# UNPACK #-} !Location
|
||||
, nodeLocation :: {-# UNPACK #-} !Loc
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -25,11 +25,11 @@ data Node grammar = Node
|
||||
instance Show grammar => ToJSONFields (Node grammar) where
|
||||
toJSONFields Node{..} =
|
||||
[ "symbol" .= pack (show nodeSymbol)
|
||||
, "span" .= locationSpan nodeLocation
|
||||
, "span" .= locSpan nodeLocation
|
||||
]
|
||||
|
||||
nodeSpan :: Node grammar -> Span
|
||||
nodeSpan = locationSpan . nodeLocation
|
||||
nodeSpan = locSpan . nodeLocation
|
||||
|
||||
nodeByteRange :: Node grammar -> Range
|
||||
nodeByteRange = locationByteRange . nodeLocation
|
||||
nodeByteRange = locByteRange . nodeLocation
|
||||
|
@ -22,13 +22,13 @@ import Data.Abstract.Package (PackageInfo (..))
|
||||
import Data.Aeson
|
||||
import Data.Graph (VertexTag (..))
|
||||
import qualified Data.Graph as G
|
||||
import Data.Location
|
||||
import qualified Data.Syntax as Syntax
|
||||
import qualified Data.Syntax.Declaration as Declaration
|
||||
import qualified Data.Syntax.Expression as Expression
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
|
||||
-- | A vertex of representing some node in a control flow graph.
|
||||
@ -101,9 +101,9 @@ instance ToJSON ControlFlowVertex where
|
||||
|
||||
class VertexDeclaration syntax where
|
||||
toVertex :: (Declarations1 syntax, Foldable syntax)
|
||||
=> Location
|
||||
=> Loc
|
||||
-> ModuleInfo
|
||||
-> syntax (Term syntax Location)
|
||||
-> syntax (Term syntax Loc)
|
||||
-> Maybe (ControlFlowVertex, Name)
|
||||
|
||||
instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
|
||||
@ -111,9 +111,9 @@ instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
|
||||
|
||||
class VertexDeclaration' whole syntax where
|
||||
toVertex' :: (Declarations1 whole, Foldable whole)
|
||||
=> Location
|
||||
=> Loc
|
||||
-> ModuleInfo
|
||||
-> syntax (Term whole Location)
|
||||
-> syntax (Term whole Loc)
|
||||
-> Maybe (ControlFlowVertex, Name)
|
||||
|
||||
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
|
||||
toVertexWithStrategy :: (Declarations1 whole, Foldable whole)
|
||||
=> proxy strategy
|
||||
-> Location
|
||||
-> Loc
|
||||
-> ModuleInfo
|
||||
-> syntax (Term whole Location)
|
||||
-> syntax (Term whole Loc)
|
||||
-> Maybe (ControlFlowVertex, Name)
|
||||
|
||||
-- | 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)
|
||||
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
(Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (locationSpan ann), name)
|
||||
(_, Just (_, name)) -> Just (variableVertex (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 (locSpan ann), name)
|
||||
_ -> Nothing
|
||||
|
@ -6,7 +6,7 @@ module Data.History
|
||||
, remark
|
||||
) where
|
||||
|
||||
import Data.Location
|
||||
import Source.Loc
|
||||
|
||||
-- | 'History' values, when attached to a given 'Term', describe the ways in
|
||||
-- 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'.
|
||||
mark :: Functor f
|
||||
=> (Range -> History)
|
||||
-> f Location
|
||||
-> f Loc
|
||||
-> f History
|
||||
mark f = fmap (f . locationByteRange)
|
||||
mark f = fmap (f . locByteRange)
|
||||
|
||||
-- | Change the 'History' annotation on a 'Term'.
|
||||
remark :: Functor f
|
||||
|
@ -10,11 +10,11 @@ module Data.JSON.Fields
|
||||
|
||||
import Data.Aeson
|
||||
import qualified Data.Map as Map
|
||||
import Data.Location
|
||||
import Data.Sum (Apply (..), Sum)
|
||||
import qualified Data.Text as Text
|
||||
import GHC.Generics
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
|
||||
class ToJSONFields a where
|
||||
toJSONFields :: KeyValue kv => a -> [kv]
|
||||
@ -53,8 +53,8 @@ instance ToJSONFields Range where
|
||||
instance ToJSONFields Span where
|
||||
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
|
||||
|
||||
instance ToJSONFields Location where
|
||||
toJSONFields Location{..} = toJSONFields locationByteRange <> toJSONFields locationSpan
|
||||
instance ToJSONFields Loc where
|
||||
toJSONFields Loc{..} = toJSONFields locByteRange <> toJSONFields locSpan
|
||||
|
||||
|
||||
newtype JSONFields a = JSONFields { unJSONFields :: a }
|
||||
|
@ -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 #-}
|
@ -5,7 +5,6 @@ module Data.Syntax where
|
||||
import Data.Abstract.Evaluatable hiding (Empty, Error)
|
||||
import Data.Aeson as Aeson (ToJSON(..), object)
|
||||
import Data.JSON.Fields
|
||||
import Data.Location
|
||||
import qualified Data.Set as Set
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
@ -16,6 +15,7 @@ import Diffing.Algorithm
|
||||
import Prelude
|
||||
import Prologue
|
||||
import Reprinting.Tokenize hiding (Element)
|
||||
import Source.Loc
|
||||
import qualified Assigning.Assignment as Assignment
|
||||
import qualified Data.Error as Error
|
||||
import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..))
|
||||
@ -49,16 +49,16 @@ makeTerm1' syntax = case toList syntax of
|
||||
_ -> error "makeTerm1': empty structure"
|
||||
|
||||
-- | 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
|
||||
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.
|
||||
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)
|
||||
|
||||
-- | 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") [])
|
||||
|
||||
-- | 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.
|
||||
|
@ -132,7 +132,7 @@ type Syntax =
|
||||
, Literal.Boolean
|
||||
]
|
||||
|
||||
type Term = Term.Term (Sum Syntax) Location
|
||||
type Term = Term.Term (Sum Syntax) Loc
|
||||
type Assignment = Assignment.Assignment [] Grammar
|
||||
|
||||
-- | Assignment from AST in Go's grammar onto a program in Go's syntax.
|
||||
|
@ -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
|
||||
|
||||
assignment :: Assignment Term
|
||||
|
@ -9,11 +9,11 @@ where
|
||||
import Assigning.Assignment.Deterministic hiding (Assignment)
|
||||
import qualified Assigning.Assignment.Deterministic as Deterministic
|
||||
import Data.Sum
|
||||
import Data.Location
|
||||
import qualified Data.Syntax as Syntax
|
||||
import qualified Data.Syntax.Literal as Literal
|
||||
import qualified Data.Term as Term
|
||||
import Prologue
|
||||
import Source.Loc
|
||||
import Text.Parser.Combinators
|
||||
import TreeSitter.JSON as Grammar
|
||||
|
||||
@ -28,7 +28,7 @@ type Syntax =
|
||||
, Syntax.Error
|
||||
]
|
||||
|
||||
type Term = Term.Term (Sum Syntax) Location
|
||||
type Term = Term.Term (Sum Syntax) Loc
|
||||
type Assignment = Deterministic.Assignment Grammar
|
||||
|
||||
assignment :: Assignment Term
|
||||
|
@ -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
|
||||
|
||||
-- | Assignment from AST in Java's grammar onto a program in Java's syntax.
|
||||
|
@ -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
|
||||
|
||||
assignment :: Assignment Term
|
||||
|
@ -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
|
||||
|
||||
-- | Assignment from AST in PHP's grammar onto a program in PHP's syntax.
|
||||
|
@ -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
|
||||
|
||||
-- | Assignment from AST in Python's grammar onto a program in Python's syntax.
|
||||
|
@ -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
|
||||
|
||||
-- | 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
|
||||
<|> expression
|
||||
|
||||
identWithLocals :: Assignment (Location, Text, [Text])
|
||||
identWithLocals :: Assignment (Loc, Text, [Text])
|
||||
identWithLocals = do
|
||||
loc <- symbol Identifier
|
||||
-- source advances, so it's important we call getLocals first
|
||||
|
@ -208,7 +208,7 @@ type Syntax = '[
|
||||
, TSX.Syntax.AnnotatedExpression
|
||||
]
|
||||
|
||||
type Term = Term.Term (Sum Syntax) Location
|
||||
type Term = Term.Term (Sum Syntax) Loc
|
||||
type Assignment = Assignment.Assignment [] Grammar
|
||||
|
||||
-- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax.
|
||||
|
@ -199,7 +199,7 @@ type Syntax = '[
|
||||
, TypeScript.Syntax.AnnotatedExpression
|
||||
]
|
||||
|
||||
type Term = Term.Term (Sum Syntax) Location
|
||||
type Term = Term.Term (Sum Syntax) Loc
|
||||
type Assignment = Assignment.Assignment [] Grammar
|
||||
|
||||
-- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax.
|
||||
|
@ -8,9 +8,9 @@ module Parsing.CMark
|
||||
import CMarkGFM
|
||||
import qualified Data.AST as A
|
||||
import Data.Ix
|
||||
import Data.Location
|
||||
import Data.Source
|
||||
import Data.Term
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
import TreeSitter.Language (Symbol(..), SymbolType(..))
|
||||
|
||||
@ -55,7 +55,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT
|
||||
toTerm within withinSpan (Node position t children) =
|
||||
let range = maybe within (spanToRangeInLineRanges lineRanges . 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)))
|
||||
|
||||
|
@ -84,7 +84,7 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
|
||||
)
|
||||
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
|
||||
-> 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 _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell)
|
||||
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.
|
||||
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.
|
||||
-> Assignment ast grammar (Term (Sum fs) Location) -- ^ An assignment from AST onto 'Term's.
|
||||
-> Parser (Term (Sum fs) Location) -- ^ A parser producing 'Term's.
|
||||
-> Assignment ast grammar (Term (Sum fs) Loc) -- ^ An assignment from AST onto '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)
|
||||
=> Parser (AST [] grammar)
|
||||
-> Deterministic.Assignment grammar (Term (Sum syntaxes) Location)
|
||||
-> Parser (Term (Sum syntaxes) Location)
|
||||
-> Deterministic.Assignment grammar (Term (Sum syntaxes) Loc)
|
||||
-> Parser (Term (Sum syntaxes) Loc)
|
||||
-- | A parser for 'Markdown' using cmark.
|
||||
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
|
||||
-- | An abstraction over parsers when we don’t know the details of the term type.
|
||||
|
@ -17,9 +17,9 @@ import Foreign.Marshal.Array (allocaArray)
|
||||
import Data.AST (AST, Node (Node))
|
||||
import Data.Blob
|
||||
import Data.Duration
|
||||
import Data.Location
|
||||
import Data.Source
|
||||
import Data.Term
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
|
||||
import qualified TreeSitter.Language as TS
|
||||
@ -84,7 +84,7 @@ toAST node@TS.Node{..} = do
|
||||
children <- allocaArray count $ \ childNodesPtr -> do
|
||||
_ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` 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 g = a where a = pure . embed <=< traverse a <=< g
|
||||
|
@ -14,13 +14,13 @@ import Control.Effect.Reader
|
||||
import Control.Effect.State
|
||||
import Data.Diff
|
||||
import Data.Graph
|
||||
import Data.Location
|
||||
import Data.Patch
|
||||
import Data.String (IsString (..))
|
||||
import Data.Term
|
||||
import Prologue
|
||||
import Semantic.Api.Bridge
|
||||
import Semantic.Proto.SemanticPB
|
||||
import Source.Loc
|
||||
|
||||
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)
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax) =>
|
||||
ToTreeGraph TermVertex (TermF syntax Location) where
|
||||
ToTreeGraph TermVertex (TermF syntax Loc) where
|
||||
toTreeGraph = termAlgebra where
|
||||
termAlgebra ::
|
||||
( ConstructorName syntax
|
||||
@ -70,17 +70,17 @@ instance (ConstructorName syntax, Foldable syntax) =>
|
||||
, Member (Reader (Graph TermVertex)) sig
|
||||
, Carrier sig m
|
||||
)
|
||||
=> TermF syntax Location (m (Graph TermVertex))
|
||||
=> TermF syntax Loc (m (Graph TermVertex))
|
||||
-> m (Graph TermVertex)
|
||||
termAlgebra (In ann syntax) = do
|
||||
i <- fresh
|
||||
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
|
||||
pure (parent `connect` root `overlay` subGraph)
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax) =>
|
||||
ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) where
|
||||
ToTreeGraph DiffTreeVertex (DiffF syntax Loc Loc) where
|
||||
toTreeGraph d = case d of
|
||||
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))))
|
||||
@ -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))))
|
||||
pure (parent `connect` replace `overlay` graph)
|
||||
where
|
||||
ann a = converting #? locationSpan a
|
||||
ann a = converting #? locSpan a
|
||||
diffAlgebra ::
|
||||
( Foldable f
|
||||
, Member Fresh sig
|
||||
|
@ -26,9 +26,9 @@ import Data.List (sortOn)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map.Monoidal as Map
|
||||
import Data.Patch
|
||||
import Data.Location
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import Source.Loc
|
||||
|
||||
data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] }
|
||||
deriving stock (Eq, Show, Generic)
|
||||
|
@ -23,7 +23,6 @@ import Data.Diff
|
||||
import Data.Graph
|
||||
import Data.JSON.Fields
|
||||
import Data.Language
|
||||
import Data.Location
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
@ -39,6 +38,7 @@ import Semantic.Task as Task
|
||||
import Semantic.Telemetry as Stat
|
||||
import Serializing.Format hiding (JSON)
|
||||
import qualified Serializing.Format as Format
|
||||
import Source.Loc
|
||||
|
||||
data DiffOutputFormat
|
||||
= DiffJSONTree
|
||||
@ -55,7 +55,7 @@ parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
|
||||
parseDiffBuilder DiffShow = distributeFoldMap showDiff
|
||||
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 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 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
|
||||
|
||||
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
|
||||
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 =
|
||||
let graph = renderTreeGraph diff
|
||||
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
|
||||
@ -111,7 +111,7 @@ type TermPairConstraints =
|
||||
]
|
||||
|
||||
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
|
||||
SomeTermPair terms <- doParse blobPair decorate
|
||||
diff <- diffTerms blobPair terms
|
||||
@ -125,7 +125,7 @@ diffTerms blobs terms = time "diff" languageTag $ do
|
||||
where languageTag = languageTagForBlobPair blobs
|
||||
|
||||
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
|
||||
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob)
|
||||
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse haskellParser blob >>= decorate blob)
|
||||
|
@ -12,7 +12,6 @@ import Control.Exception
|
||||
import Control.Lens
|
||||
import Data.Blob hiding (File (..))
|
||||
import Data.ByteString.Builder
|
||||
import Data.Location
|
||||
import Data.Maybe
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
@ -26,6 +25,7 @@ import Semantic.Api.Terms (ParseEffects, doParse)
|
||||
import Semantic.Proto.SemanticPB hiding (Blob)
|
||||
import Semantic.Task
|
||||
import Serializing.Format
|
||||
import Source.Loc
|
||||
import Tags.Taggable
|
||||
import Tags.Tagging
|
||||
|
||||
@ -41,7 +41,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
|
||||
symbolsToSummarize :: [Text]
|
||||
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
|
||||
|
||||
tagsToFile :: [Tag] -> Legacy.File
|
||||
@ -72,7 +72,7 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
|
||||
symbolsToSummarize :: [Text]
|
||||
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)
|
||||
|
||||
tagsToFile :: [Tag] -> File
|
||||
|
@ -26,7 +26,6 @@ import Data.Either
|
||||
import Data.Graph
|
||||
import Data.JSON.Fields
|
||||
import Data.Language
|
||||
import Data.Location
|
||||
import Data.Quieterm
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
@ -41,6 +40,7 @@ import Semantic.Proto.SemanticPB hiding (Blob)
|
||||
import Semantic.Task
|
||||
import Serializing.Format hiding (JSON)
|
||||
import qualified Serializing.Format as Format
|
||||
import Source.Loc
|
||||
import Tags.Taggable
|
||||
|
||||
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
|
||||
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
|
||||
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
|
||||
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
|
||||
@ -113,7 +113,7 @@ type TermConstraints =
|
||||
, 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
|
||||
Go -> SomeTerm <$> parse goParser blob
|
||||
Haskell -> SomeTerm <$> parse haskellParser blob
|
||||
|
@ -55,7 +55,6 @@ import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, Vertex
|
||||
import Data.Language as Language
|
||||
import Data.List (isPrefixOf, isSuffixOf)
|
||||
import Data.Project
|
||||
import Data.Location
|
||||
import Data.Term
|
||||
import Data.Text (pack, unpack)
|
||||
import Language.Haskell.HsColour
|
||||
@ -64,6 +63,7 @@ import Parsing.Parser
|
||||
import Prologue hiding (TypeError (..))
|
||||
import Semantic.Analysis
|
||||
import Semantic.Task as Task
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
import System.FilePath.Posix (takeDirectory, (</>))
|
||||
import Text.Show.Pretty (ppShow)
|
||||
@ -102,7 +102,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
|
||||
, Ord1 syntax
|
||||
, Functor syntax
|
||||
, Evaluatable syntax
|
||||
, term ~ Term syntax Location
|
||||
, term ~ Term syntax Loc
|
||||
, FreeVariables1 syntax
|
||||
, HasPrelude lang
|
||||
, Member Trace sig
|
||||
@ -255,7 +255,7 @@ parsePythonPackage :: forall syntax sig m term.
|
||||
, FreeVariables1 syntax
|
||||
, AccessControls1 syntax
|
||||
, Functor syntax
|
||||
, term ~ Term syntax Location
|
||||
, term ~ Term syntax Loc
|
||||
, Member (Error SomeException) sig
|
||||
, Member Distribute sig
|
||||
, Member Resolution sig
|
||||
@ -335,11 +335,11 @@ withTermSpans :: ( Member (Reader Span) sig
|
||||
, Member (State Span) sig -- last evaluated child's span
|
||||
, Recursive term
|
||||
, Carrier sig m
|
||||
, Base term ~ TermF syntax Location
|
||||
, Base term ~ TermF syntax Loc
|
||||
)
|
||||
=> Open (term -> Evaluator term address value m a)
|
||||
withTermSpans recur term = let
|
||||
span = locationSpan (termFAnnotation (project term))
|
||||
span = locSpan (termFAnnotation (project term))
|
||||
updatedSpanAlg = withCurrentSpan span (recur term)
|
||||
in modifyChildSpan span updatedSpanAlg
|
||||
|
||||
|
@ -71,7 +71,6 @@ import Data.ByteString.Builder
|
||||
import Data.Diff
|
||||
import qualified Data.Error as Error
|
||||
import qualified Data.Flag as Flag
|
||||
import Data.Location
|
||||
import Data.Source (Source)
|
||||
import Data.Sum
|
||||
import qualified Data.Syntax as Syntax
|
||||
@ -89,6 +88,7 @@ import Semantic.Timeout
|
||||
import Semantic.Resolution
|
||||
import Semantic.Telemetry
|
||||
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'
|
||||
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.
|
||||
decorate :: (Functor f, Member Task sig, Carrier sig m)
|
||||
=> RAlgebra (TermF f Location) (Term f Location) field
|
||||
-> Term f Location
|
||||
=> RAlgebra (TermF f Loc) (Term f Loc) field
|
||||
-> Term f Loc
|
||||
-> m (Term f field)
|
||||
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.
|
||||
data Task (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 input output . Render (Renderer input output) input (output -> 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
|
||||
SomeParser parser -> SomeTerm <$> runParser blob parser
|
||||
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 = cata $ \ (In Assignment.Location{..} syntax) -> case syntax of
|
||||
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locationSpan err]
|
||||
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String]
|
||||
errors = cata $ \ (In Assignment.Loc{..} syntax) -> case syntax of
|
||||
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locSpan err]
|
||||
_ -> fold syntax
|
||||
runAssignment :: ( Apply Foldable syntaxes
|
||||
, Apply Functor syntaxes
|
||||
@ -294,10 +294,10 @@ runParser blob@Blob{..} parser = case parser of
|
||||
, Carrier sig 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
|
||||
-> assignment (Term (Sum syntaxes) Assignment.Location)
|
||||
-> m (Term (Sum syntaxes) Assignment.Location)
|
||||
-> assignment (Term (Sum syntaxes) Assignment.Loc)
|
||||
-> m (Term (Sum syntaxes) Assignment.Loc)
|
||||
runAssignment assign parser assignment = do
|
||||
taskSession <- ask
|
||||
let requestID' = ("github_request_id", requestID taskSession)
|
||||
|
@ -33,7 +33,6 @@ import Data.Blob.IO
|
||||
import Data.Graph (topologicalSort)
|
||||
import qualified Data.Language as Language
|
||||
import Data.List (uncons)
|
||||
import Data.Location
|
||||
import Data.Project hiding (readFile)
|
||||
import Data.Quieterm (Quieterm, quieterm)
|
||||
import Data.Sum (weaken)
|
||||
@ -48,6 +47,7 @@ import Semantic.Analysis
|
||||
import Semantic.Config
|
||||
import Semantic.Graph
|
||||
import Semantic.Task
|
||||
import Source.Loc
|
||||
import System.Exit (die)
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
|
||||
@ -76,10 +76,10 @@ justEvaluating
|
||||
type FileEvaluator err syntax =
|
||||
[FilePath]
|
||||
-> IO
|
||||
( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise),
|
||||
( Heap Precise Precise (Value (Quieterm (Sum syntax) Loc) Precise),
|
||||
( ScopeGraph Precise
|
||||
, 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 = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser
|
||||
|
@ -48,11 +48,10 @@ import Semantic.Analysis
|
||||
import Semantic.Config
|
||||
import Semantic.Graph
|
||||
import Semantic.Task
|
||||
import Source.Loc
|
||||
import System.Exit (die)
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
|
||||
import Data.Location
|
||||
|
||||
type ProjectEvaluator syntax =
|
||||
Project
|
||||
-> IO
|
||||
@ -60,7 +59,7 @@ type ProjectEvaluator syntax =
|
||||
(Hole (Maybe Name) Precise)
|
||||
(Hole (Maybe Name) Precise)
|
||||
(Value
|
||||
(Quieterm (Sum syntax) Location)
|
||||
(Quieterm (Sum syntax) Loc)
|
||||
(Hole (Maybe Name) Precise)),
|
||||
(ScopeGraph (Hole (Maybe Name) Precise),
|
||||
ModuleTable
|
||||
@ -68,7 +67,7 @@ type ProjectEvaluator syntax =
|
||||
(ModuleResult
|
||||
(Hole (Maybe Name) Precise)
|
||||
(Value
|
||||
(Quieterm (Sum syntax) Location)
|
||||
(Quieterm (Sum syntax) Loc)
|
||||
(Hole (Maybe Name) Precise))))))
|
||||
|
||||
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
|
||||
-- polymorphic in @lang@.
|
||||
justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
|
||||
, term ~ Quieterm (Sum lang) Location
|
||||
, term ~ Quieterm (Sum lang) Loc
|
||||
, value ~ Concrete.Value term hole
|
||||
, Apply Show1 lang
|
||||
)
|
||||
@ -149,7 +148,7 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
|
||||
(ResumableWithC (BaseError (LoadError hole value))
|
||||
(FreshC
|
||||
(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
|
||||
(LiftC IO))))))))))))) a
|
||||
-> IO (Heap hole hole value, (ScopeGraph hole, a))
|
||||
@ -200,7 +199,7 @@ callGraphProject
|
||||
syntax
|
||||
syntax) =>
|
||||
Parser
|
||||
(Term syntax Location)
|
||||
(Term syntax Loc)
|
||||
-> Proxy lang
|
||||
-> [FilePath]
|
||||
-> IO
|
||||
@ -238,7 +237,7 @@ evalJavaScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
|
||||
evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser
|
||||
|
||||
typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
|
||||
, qterm ~ Quieterm (Sum syntax) Location
|
||||
, qterm ~ Quieterm (Sum syntax) Loc
|
||||
, value ~ Type
|
||||
, address ~ Monovariant
|
||||
, result ~ (ModuleTable (Module (ModuleResult address value))))
|
||||
@ -246,15 +245,15 @@ typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
|
||||
typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser
|
||||
|
||||
typecheckRubyFile :: ( syntax ~ Language.Ruby.Assignment.Syntax
|
||||
, qterm ~ Quieterm (Sum syntax) Location
|
||||
, qterm ~ Quieterm (Sum syntax) Loc
|
||||
, value ~ Type
|
||||
, address ~ Monovariant
|
||||
, result ~ (ModuleTable (Module (ModuleResult address value))))
|
||||
=> FileTypechecker syntax qterm value address result
|
||||
typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser
|
||||
|
||||
evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location
|
||||
, qterm ~ Quieterm (Sum syntax) Location
|
||||
evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Loc
|
||||
, qterm ~ Quieterm (Sum syntax) Loc
|
||||
, address ~ Hole (Maybe Name) Precise
|
||||
, LanguageSyntax lang syntax
|
||||
)
|
||||
@ -290,8 +289,8 @@ evaluateProjectForScopeGraph proxy parser project = runTask' $ do
|
||||
(raiseHandler (runReader (lowerBound @Span))
|
||||
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
|
||||
|
||||
evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
|
||||
, qterm ~ Quieterm (Sum syntax) Location
|
||||
evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Loc
|
||||
, qterm ~ Quieterm (Sum syntax) Loc
|
||||
, LanguageSyntax lang syntax
|
||||
)
|
||||
=> Proxy (lang :: Language.Language)
|
||||
@ -309,8 +308,8 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
|
||||
(ResumableC (BaseError (LoadError Monovariant Type))
|
||||
(ReaderC (Live Monovariant)
|
||||
(NonDetC
|
||||
(ReaderC (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) 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) Loc) Monovariant Type)
|
||||
(FreshC
|
||||
(StateC (ScopeGraph Monovariant)
|
||||
(StateC (Heap Monovariant Monovariant Type)
|
||||
@ -341,8 +340,8 @@ type LanguageSyntax lang syntax = ( Language.SLanguage lang
|
||||
, Apply AccessControls1 syntax
|
||||
, Apply FreeVariables1 syntax)
|
||||
|
||||
evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Location
|
||||
, qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Location
|
||||
evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Loc
|
||||
, qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Loc
|
||||
)
|
||||
=> Proxy 'Language.Python
|
||||
-> Parser term
|
||||
@ -366,7 +365,7 @@ evaluatePythonProjects proxy parser lang path = runTask' $ do
|
||||
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
|
||||
|
||||
evaluatePythonProject :: ( syntax ~ Language.Python.Assignment.Syntax
|
||||
, qterm ~ Quieterm (Sum syntax) Location
|
||||
, qterm ~ Quieterm (Sum syntax) Loc
|
||||
, value ~ (Concrete.Value qterm address)
|
||||
, address ~ Precise
|
||||
, result ~ (ModuleTable (Module (ModuleResult address value)))) => FilePath
|
||||
|
@ -31,9 +31,9 @@ import Data.Abstract.Declarations
|
||||
import Data.Abstract.Name
|
||||
import Data.Blob
|
||||
import Data.Language
|
||||
import Data.Location
|
||||
import Data.Term
|
||||
import Data.Text hiding (empty)
|
||||
import Source.Loc
|
||||
import Source.Range
|
||||
|
||||
import Streaming hiding (Sum)
|
||||
@ -67,11 +67,11 @@ class Taggable constr where
|
||||
( Foldable 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
|
||||
|
||||
@ -80,13 +80,13 @@ class TaggableBy (strategy :: Strategy) constr where
|
||||
( Foldable syntax
|
||||
, HasTextElement syntax
|
||||
)
|
||||
=> Language -> constr (Term syntax Location) -> Maybe Range
|
||||
=> Language -> constr (Term syntax Loc) -> Maybe Range
|
||||
docsLiteral' _ _ = Nothing
|
||||
|
||||
snippet' :: (Foldable syntax) => Location -> constr (Term syntax Location) -> Maybe Range
|
||||
snippet' :: (Foldable syntax) => Loc -> constr (Term syntax Loc) -> Maybe Range
|
||||
snippet' _ _ = Nothing
|
||||
|
||||
symbolName' :: Declarations1 syntax => constr (Term syntax Location) -> Maybe Name
|
||||
symbolName' :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name
|
||||
symbolName' _ = Nothing
|
||||
|
||||
type IsTaggable syntax =
|
||||
@ -100,28 +100,28 @@ type IsTaggable syntax =
|
||||
|
||||
tagging :: (Monad m, IsTaggable syntax)
|
||||
=> Blob
|
||||
-> Term syntax Location
|
||||
-> Term syntax Loc
|
||||
-> Stream (Of Token) m ()
|
||||
tagging b = foldSubterms (descend (blobLanguage b))
|
||||
|
||||
descend ::
|
||||
( ConstructorName (TermF syntax Location)
|
||||
( ConstructorName (TermF syntax Loc)
|
||||
, IsTaggable syntax
|
||||
, 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
|
||||
let term = fmap subterm t
|
||||
let snippetRange = snippet loc term
|
||||
let litRange = docsLiteral lang term
|
||||
|
||||
enter (constructorName term) snippetRange
|
||||
maybe (pure ()) (emitIden (locationSpan loc) litRange) (symbolName term)
|
||||
maybe (pure ()) (emitIden (locSpan loc) litRange) (symbolName term)
|
||||
traverse_ subtermRef t
|
||||
exit (constructorName term) snippetRange
|
||||
|
||||
subtractLocation :: Location -> Location -> Range
|
||||
subtractLocation a b = subtractRange (locationByteRange a) (locationByteRange b)
|
||||
subtractLoc :: Loc -> Loc -> Range
|
||||
subtractLoc a b = subtractRange (locByteRange a) (locByteRange b)
|
||||
|
||||
-- Instances
|
||||
|
||||
@ -151,60 +151,60 @@ instance Apply Taggable fs => TaggableBy 'Custom (Sum fs) where
|
||||
snippet' x = apply @Taggable (snippet x)
|
||||
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)
|
||||
snippet' ann t = snippet ann (termFOut t)
|
||||
symbolName' t = symbolName (termFOut t)
|
||||
|
||||
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
|
||||
docsLiteral' Python (Declaration.Function _ _ _ (Term (In _ bodyF)))
|
||||
| (Term (In exprAnn exprF):_) <- toList bodyF
|
||||
, isTextElement exprF = Just (locationByteRange exprAnn)
|
||||
, isTextElement exprF = Just (locByteRange exprAnn)
|
||||
| otherwise = 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
|
||||
|
||||
instance TaggableBy 'Custom Declaration.Method where
|
||||
docsLiteral' Python (Declaration.Method _ _ _ _ (Term (In _ bodyF)) _)
|
||||
| (Term (In exprAnn exprF):_) <- toList bodyF
|
||||
, isTextElement exprF = Just (locationByteRange exprAnn)
|
||||
, isTextElement exprF = Just (locByteRange exprAnn)
|
||||
| otherwise = 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
|
||||
|
||||
instance TaggableBy 'Custom Declaration.Class where
|
||||
docsLiteral' Python (Declaration.Class _ _ _ (Term (In _ bodyF)))
|
||||
| (Term (In exprAnn exprF):_) <- toList bodyF
|
||||
, isTextElement exprF = Just (locationByteRange exprAnn)
|
||||
, isTextElement exprF = Just (locByteRange exprAnn)
|
||||
| otherwise = 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
|
||||
|
||||
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
|
||||
|
||||
instance TaggableBy 'Custom Ruby.Module where
|
||||
snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body
|
||||
snippet' ann (Ruby.Module _ _) = Just $ locationByteRange ann
|
||||
snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
|
||||
snippet' ann (Ruby.Module _ _) = Just $ locByteRange ann
|
||||
symbolName' = declaredName . Ruby.moduleIdentifier
|
||||
|
||||
instance TaggableBy 'Custom TypeScript.Module where
|
||||
snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body
|
||||
snippet' ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann
|
||||
snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
|
||||
snippet' ann (TypeScript.Module _ _ ) = Just $ locByteRange ann
|
||||
symbolName' = declaredName . TypeScript.moduleIdentifier
|
||||
|
||||
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
|
||||
|
||||
instance TaggableBy 'Custom Ruby.Send where
|
||||
snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body
|
||||
snippet' ann _ = Just $ locationByteRange ann
|
||||
snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLoc ann body
|
||||
snippet' ann _ = Just $ locByteRange ann
|
||||
symbolName' Ruby.Send{..} = declaredName =<< sendSelector
|
||||
|
@ -14,16 +14,16 @@ import Streaming
|
||||
import qualified Streaming.Prelude as Streaming
|
||||
|
||||
import Data.Blob
|
||||
import Data.Location
|
||||
import qualified Data.Source as Source
|
||||
import Data.Tag
|
||||
import Data.Term
|
||||
import Source.Loc
|
||||
import Tags.Taggable
|
||||
|
||||
runTagging :: (IsTaggable syntax)
|
||||
=> Blob
|
||||
-> [Text]
|
||||
-> Term syntax Location
|
||||
-> Term syntax Loc
|
||||
-> [Tag]
|
||||
runTagging blob symbolsToSummarize
|
||||
= Eff.run
|
||||
|
@ -14,12 +14,12 @@ import Data.Abstract.Number as Number
|
||||
import Data.Abstract.Package (PackageInfo (..))
|
||||
import Data.Abstract.Value.Concrete as Concrete
|
||||
import qualified Data.Language as Language
|
||||
import Data.Location
|
||||
import Data.Quieterm
|
||||
import Data.Scientific (scientific)
|
||||
import Data.Sum
|
||||
import Data.Text (pack)
|
||||
import qualified Language.TypeScript.Assignment as TypeScript
|
||||
import Source.Loc
|
||||
import SpecHelpers
|
||||
|
||||
spec :: (?session :: TaskSession) => Spec
|
||||
@ -176,7 +176,7 @@ spec = do
|
||||
|
||||
it "member access of private methods throws AccessControlError" $ do
|
||||
(_, (_, 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
|
||||
|
||||
where
|
||||
@ -184,5 +184,5 @@ spec = do
|
||||
evaluate = evalTypeScriptProject . map (fixtures <>)
|
||||
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))
|
||||
|
@ -255,7 +255,7 @@ spec = do
|
||||
Left [ "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
|
||||
deriving (Bounded, Enum, Eq, Ix, Ord, Show)
|
||||
|
@ -28,7 +28,6 @@ import Data.Functor.Both
|
||||
import qualified Data.Language as Language
|
||||
import Data.List.NonEmpty
|
||||
import Data.Patch
|
||||
import Data.Location
|
||||
import Data.Semigroup.App
|
||||
import qualified Data.Syntax as Syntax
|
||||
import qualified Data.Syntax.Literal as Literal
|
||||
@ -45,6 +44,7 @@ import Data.Text as T (Text, pack)
|
||||
import Data.These
|
||||
import Data.Sum
|
||||
import Diffing.Algorithm.RWS
|
||||
import Source.Loc
|
||||
import Source.Range
|
||||
import Source.Span
|
||||
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
|
||||
tiers = cons1 AppMerge
|
||||
|
||||
instance Listable Location where
|
||||
tiers = cons2 Location
|
||||
instance Listable Loc where
|
||||
tiers = cons2 Loc
|
||||
|
||||
instance Listable Range where
|
||||
tiers = cons2 Range
|
||||
|
@ -10,7 +10,6 @@ import Data.Diff
|
||||
import Data.Functor.Classes
|
||||
import Data.Hashable.Lifted
|
||||
import Data.Patch
|
||||
import Data.Location
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
import Data.Text (Text)
|
||||
@ -22,6 +21,7 @@ import qualified Data.Syntax.Declaration as Declaration
|
||||
import Rendering.TOC
|
||||
import Semantic.Api (diffSummaryBuilder)
|
||||
import Serializing.Format as Format
|
||||
import Source.Loc
|
||||
import Source.Span
|
||||
|
||||
import SpecHelpers
|
||||
@ -233,7 +233,7 @@ diffWithParser :: ( Eq1 syntax
|
||||
, Member Task sig
|
||||
, Carrier sig m
|
||||
)
|
||||
=> Parser (Term syntax Location)
|
||||
=> Parser (Term syntax Loc)
|
||||
-> BlobPair
|
||||
-> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
|
||||
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin
|
||||
|
Loading…
Reference in New Issue
Block a user