github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/indexer-prototype' into deploy-to-moda

Browse Source
This commit is contained in:
joshvera 2019-02-20 14:23:18 -05:00
parent ea3909c5e4
commit be4250707d
59 changed files with 940 additions and 771 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.hlint.yaml
View File

@ -48,6 +48,7 @@
- ignore: {name: Use ., within: [Analysis.Abstract.Graph.graphingModules]}
- ignore: {name: Reduce duplication, within: [Semantic.Util]}
- ignore: {name: Use newtype instead of data, within: [Semantic.Api.V1.CodeAnalysisPB]}
# Our customized warnings

1
.stylish-haskell.yaml
View File

@ -223,6 +223,7 @@ language_extensions:
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingVia
- ExplicitNamespaces
- FlexibleContexts
- FlexibleInstances

47
proto/semantic.proto → proto/semantic/api/v1/code_analysis.proto
View File

@ -1,13 +1,11 @@
// This file was generated by proto-gen. Do not edit by hand.
syntax = "proto3";
package github.semantic;
package semantic.api.v1;
option java_package = "com.github.semantic.analysis";
option go_package = "github.com/semantic/analysis/;analysis";
// Semantic's CodeAnalysis service provides endpoints for parsing, analyzing, and comparing source code.
option java_package = "com.github.semantic.api.v1";
// Semantic's CodeAnalysis service provides endpoints for parsing, analyzing,
// and comparing source code.
service CodeAnalysis {
// Check health & status of the service.
rpc Ping (PingRequest) returns (PingResponse);
@ -58,7 +56,7 @@ message TermEdge {
}
message TermVertex {
int64 vertexId = 1;
int64 vertex_id = 1;
string term = 2;
Span span = 3;
}
@ -86,7 +84,7 @@ message TOCSummaryChange {
string category = 1;
string term = 2;
Span span = 3;
ChangeType changeType = 4;
ChangeType change_type = 4;
}
message TOCSummaryError {
@ -119,16 +117,12 @@ message DiffTreeEdge {
}
message DiffTreeVertex {
int64 diffVertexId = 1;
DiffTreeTerm diffTerm = 2;
}
message DiffTreeTerm {
oneof sum {
DeletedTerm deleted = 1;
InsertedTerm inserted = 2;
ReplacedTerm replaced = 3;
MergedTerm merged = 4;
int64 diff_vertex_id = 1;
oneof diff_term {
DeletedTerm deleted = 2;
InsertedTerm inserted = 3;
ReplacedTerm replaced = 4;
MergedTerm merged = 5;
}
}
@ -143,16 +137,16 @@ message InsertedTerm {
}
message ReplacedTerm {
string beforeTerm = 1;
Span beforeSpan = 2;
string afterTerm = 3;
Span afterSpan = 4;
string before_term = 1;
Span before_span = 2;
string after_term = 3;
Span after_span = 4;
}
message MergedTerm {
string term = 1;
Span beforeSpan = 2;
Span afterSpan = 3;
Span before_span = 2;
Span after_span = 3;
}
enum Language {
@ -193,6 +187,11 @@ message Symbol {
string kind = 2;
string line = 3;
Span span = 4;
Docstring docs = 5;
}
message Docstring {
string docstring = 1;
}
message Position {

16
semantic.cabal
View File

@ -188,14 +188,14 @@ library
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
-- API
, Semantic.API
, Semantic.API.Diffs
, Semantic.API.Helpers
, Semantic.API.LegacyTypes
, Semantic.API.Symbols
, Semantic.API.Terms
, Semantic.API.TOCSummaries
, Semantic.API.Types
, Semantic.Api
, Semantic.Api.Diffs
, Semantic.Api.Helpers
, Semantic.Api.LegacyTypes
, Semantic.Api.Symbols
, Semantic.Api.Terms
, Semantic.Api.TOCSummaries
, Semantic.Api.V1.CodeAnalysisPB
, Semantic.AST
, Semantic.CLI
, Semantic.Config

6
src/Control/Abstract/Heap.hs
View File

@ -56,7 +56,7 @@ import qualified Data.Abstract.Heap as Heap
import Data.Abstract.Live
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.ScopeGraph (Kind(..), Path (..), Relation(..), putDeclarationScopeAtPosition)
import Data.Abstract.ScopeGraph (Path (..), Relation(..), putDeclarationScopeAtPosition)
import qualified Data.Map.Strict as Map
import Data.Span (Span, emptySpan)
import Prologue
@ -181,7 +181,7 @@ define :: ( HasCallStack
-> Evaluator term address value m ()
define declaration rel accessControl def = withCurrentCallStack callStack $ do
-- TODO: This span is still wrong.
declare declaration rel accessControl emptySpan Unknown Nothing
declare declaration rel accessControl emptySpan Nothing
slot <- lookupSlot declaration
value <- def
assign slot value
@ -203,7 +203,7 @@ withChildFrame :: ( Member (Allocator address) sig
-> (address -> Evaluator term address value m a)
-> Evaluator term address value m a
withChildFrame declaration body = do
scope <- newPreludeScope mempty
scope <- newScope mempty
putDeclarationScope declaration scope
frame <- newFrame scope mempty
withScopeAndFrame frame (body frame)

9
src/Control/Abstract/Primitive.hs
View File

@ -11,7 +11,6 @@ import Control.Abstract.Heap
import Control.Abstract.ScopeGraph
import Control.Abstract.Value
import Data.Abstract.BaseError
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Name
import Data.Map.Strict as Map
import Data.Span
@ -41,13 +40,13 @@ defineBuiltIn :: ( HasCallStack
defineBuiltIn declaration rel accessControl value = withCurrentCallStack callStack $ do
currentScope' <- currentScope
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
associatedScope <- newPreludeScope lexicalEdges
associatedScope <- newScope lexicalEdges
-- TODO: This span is still wrong.
declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope)
declare declaration rel accessControl emptySpan (Just associatedScope)
param <- gensym
withScope associatedScope $ do
declare (Declaration param) rel accessControl emptySpan ScopeGraph.Unknown Nothing
declare (Declaration param) rel accessControl emptySpan Nothing
slot <- lookupSlot declaration
value <- builtIn associatedScope value
@ -81,7 +80,7 @@ defineClass declaration superclasses body = void . define declaration Default Pu
let superclassEdges = (Superclass, ) <$> (fmap pure . catMaybes $ superScopes)
current = fmap (Lexical, ) . pure . pure $ currentScope'
edges = Map.fromList (superclassEdges <> current)
childScope <- newPreludeScope edges
childScope <- newScope edges
putDeclarationScope declaration childScope
withScope childScope $ do

40
src/Control/Abstract/ScopeGraph.hs
View File

@ -5,7 +5,6 @@ module Control.Abstract.ScopeGraph
, declare
, reference
, newScope
, newPreludeScope
, Declaration(..)
, ScopeGraph
, ScopeError(..)
@ -48,7 +47,7 @@ import Control.Effect.Carrier
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.Name hiding (name)
import Data.Abstract.ScopeGraph (Kind, Declaration(..), EdgeLabel, Reference, Relation(..), Scope (..), ScopeGraph, Slot(..), Info(..), AccessControl(..))
import Data.Abstract.ScopeGraph (Declaration(..), EdgeLabel, Reference, Relation(..), Scope (..), ScopeGraph, Slot(..), Info(..), AccessControl(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Span
import Prelude hiding (lookup)
@ -64,20 +63,17 @@ lookup ref = ScopeGraph.scopeOfRef ref <$> get
declare :: ( Carrier sig m
, Member (State (ScopeGraph address)) sig
, Member (Reader (CurrentScope address)) sig
, Member (Reader ModuleInfo) sig
, Ord address
)
=> Declaration
-> Relation
-> AccessControl
-> Span
-> Kind
-> Maybe address
-> Evaluator term address value m ()
declare decl rel accessControl span kind scope = do
declare decl rel accessControl span scope = do
currentAddress <- currentScope
moduleInfo <- ask @ModuleInfo
modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress)
modify (fst . ScopeGraph.declare decl rel accessControl span scope currentAddress)
putDeclarationScope :: ( Ord address
, Member (Reader (CurrentScope address)) sig
@ -105,18 +101,14 @@ reference :: forall address sig m term value .
( Ord address
, Member (State (ScopeGraph address)) sig
, Member (Reader (CurrentScope address)) sig
, Member (Reader ModuleInfo) sig
, Carrier sig m
)
=> Reference
-> Span
-> Kind
-> Declaration
-> Evaluator term address value m ()
reference ref span kind decl = do
reference ref decl = do
currentAddress <- currentScope
moduleInfo <- ask @ModuleInfo
modify @(ScopeGraph address) (ScopeGraph.reference ref moduleInfo span kind decl currentAddress)
modify @(ScopeGraph address) (ScopeGraph.reference ref decl currentAddress)
-- | Combinator to insert an export edge from the current scope to the provided scope address.
insertExportEdge :: (Member (Reader (CurrentScope scopeAddress)) sig, Member (State (ScopeGraph scopeAddress)) sig, Carrier sig m, Ord scopeAddress)
@ -162,21 +154,6 @@ newScope edges = do
address <- alloc name
address <$ modify (ScopeGraph.newScope address edges)
-- | Inserts a new scope into the scope graph with the given edges.
newPreludeScope :: ( Member (Allocator address) sig
, Member (State (ScopeGraph address)) sig
, Member Fresh sig
, Carrier sig m
, Ord address
)
=> Map EdgeLabel [address]
-> Evaluator term address value m address
newPreludeScope edges = do
-- Take the edges and construct a new scope
name <- gensym
address <- alloc name
address <$ modify (ScopeGraph.newPreludeScope address edges)
newtype CurrentScope address = CurrentScope { unCurrentScope :: address }
currentScope :: ( Carrier sig m
@ -237,17 +214,14 @@ insertImportReference :: ( Member (Resumable (BaseError (ScopeError address))) s
, Ord address
)
=> Reference
-> Span
-> Kind
-> Declaration
-> address
-> Evaluator term address value m ()
insertImportReference ref span kind decl scopeAddress = do
insertImportReference ref decl scopeAddress = do
scopeGraph <- get
scope <- lookupScope scopeAddress
currentAddress <- currentScope
moduleInfo <- ask @ModuleInfo
newScope <- maybeM (throwScopeError ImportReferenceError) (ScopeGraph.insertImportReference ref moduleInfo span kind decl currentAddress scopeGraph scope)
newScope <- maybeM (throwScopeError ImportReferenceError) (ScopeGraph.insertImportReference ref decl currentAddress scopeGraph scope)
insertScope scopeAddress newScope
insertScope :: ( Member (State (ScopeGraph address)) sig

1
src/Data/Abstract/AccessControls/Instances.hs
View File

@ -335,7 +335,6 @@ instance AccessControls1 Java.TryWithResources
instance AccessControls1 Java.AssertStatement
instance AccessControls1 Java.AnnotationTypeElement
instance AccessControls1 Python.Alias
instance AccessControls1 Python.Ellipsis
instance AccessControls1 Python.FutureImport
instance AccessControls1 Python.Import

8
src/Data/Abstract/Declarations.hs
View File

@ -12,9 +12,6 @@ class Declarations syntax where
declaredName :: syntax -> Maybe Name
declaredName = const Nothing
declaredAlias :: syntax -> Maybe Name
declaredAlias = const Nothing
class Declarations1 syntax where
-- | Lift a function mapping each element to its declared name (if any) through a containing structure. This can be used to define the declared name for a composite piece of syntax in terms of the declared name of one of its components.
--
@ -22,17 +19,12 @@ class Declarations1 syntax where
liftDeclaredName :: (a -> Maybe Name) -> syntax a -> Maybe Name
liftDeclaredName _ _ = Nothing
liftDeclaredAlias :: (a -> Maybe Name) -> syntax a -> Maybe Name
liftDeclaredAlias _ _ = Nothing
deriving instance Declarations1 syntax => Declarations (Term syntax ann)
instance (Declarations recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where
declaredName = liftDeclaredName declaredName . termFOut
declaredAlias = liftDeclaredAlias declaredAlias . termFOut
instance Apply Declarations1 fs => Declarations1 (Sum fs) where
liftDeclaredName f = apply @Declarations1 (liftDeclaredName f)
liftDeclaredAlias f = apply @Declarations1 (liftDeclaredAlias f)
instance Declarations1 []

5
src/Data/Abstract/Evaluatable.hs
View File

@ -30,7 +30,6 @@ import Data.Abstract.Declarations as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.Name as X
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.ScopeGraph (Relation(..))
import Data.Abstract.AccessControls.Class as X
import Data.Language
@ -192,7 +191,7 @@ defineSelf :: ( Carrier sig m
=> Evaluator term address value m ()
defineSelf = do
let self = Declaration X.__self
declare self Default Public emptySpan ScopeGraph.Unknown Nothing
declare self Default Public emptySpan Nothing
slot <- lookupSlot self
assign slot =<< object =<< currentFrame
@ -211,7 +210,7 @@ data EvalError term address value return where
IntegerFormatError :: Text -> EvalError term address value Integer
NoNameError :: term -> EvalError term address value Name
RationalFormatError :: Text -> EvalError term address value Rational
ReferenceError :: value -> term -> EvalError term address value (Slot address)
ReferenceError :: value -> Name -> EvalError term address value (Slot address)
ScopedEnvError :: value -> EvalError term address value address
throwNoNameError :: ( Carrier sig m

3
src/Data/Abstract/Module.hs
View File

@ -38,9 +38,6 @@ newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
deriving stock (Eq, Ord, Generic)
deriving anyclass (NFData)
instance Lower ModuleInfo where
lowerBound = ModuleInfo mempty
instance Show ModuleInfo where
showsPrec d = showsUnaryWith showsPrec "ModuleInfo" d . modulePath

109
src/Data/Abstract/ScopeGraph.hs
View File

@ -1,21 +1,18 @@
{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, LambdaCase, TupleSections #-}
{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, TupleSections #-}
module Data.Abstract.ScopeGraph
( Slot(..)
, Info(..)
, associatedScope
, lookupDeclaration
, declarationByName
, declarationsByAccessControl
, declarationsByRelation
, Declaration(..) -- TODO don't export these constructors
, declare
, formatDeclaration
, EdgeLabel(..)
, insertDeclarationScope
, insertDeclarationSpan
, insertImportReference
, newScope
, newPreludeScope
, insertScope
, insertEdge
, Path(..)
@ -25,10 +22,8 @@ module Data.Abstract.ScopeGraph
, Position(..)
, reference
, Reference(..) -- TODO don't export these constructors
, ReferenceInfo(..)
, Relation(..)
, ScopeGraph(..)
, Kind(..)
, lookupScope
, lookupScopePath
, Scope(..)
@ -39,26 +34,21 @@ module Data.Abstract.ScopeGraph
, AccessControl(..)
) where
import Prelude hiding (lookup)
import Prologue
import Control.Lens.Lens
import Control.Abstract.Hole
import Data.Abstract.Name
import Data.Aeson
import Data.JSON.Fields (ToJSONFields(..))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.JSON.Fields (ToJSONFields (..))
import Control.Abstract.Hole
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Span
import Prologue
-- A slot is a location in the heap where a value is stored.
data Slot address = Slot { frameAddress :: address, position :: Position }
deriving (Eq, Show, Ord, Generic, NFData)
data AccessControl = Public
| Protected
| Private
@ -88,58 +78,28 @@ instance Ord AccessControl where
(<=) Public _ = False
data Relation = Default | Instance | Prelude
deriving (Eq, Show, Ord, Generic, NFData)
data Relation = Default | Instance deriving (Eq, Show, Ord, Generic, NFData)
instance Lower Relation where
lowerBound = Default
data Info scopeAddress = Info
{ infoDeclaration :: Declaration
, infoModule :: ModuleInfo
, infoRelation :: Relation
, infoAccessControl :: AccessControl
, infoSpan :: Span
, infoKind :: Kind
{ infoDeclaration :: Declaration
, infoRelation :: Relation
, infoAccessControl :: AccessControl
, infoSpan :: Span
, infoAssociatedScope :: Maybe scopeAddress
} deriving (Eq, Show, Ord, Generic, NFData)
instance HasSpan (Info scopeAddress) where
span = lens infoSpan (\i s -> i { infoSpan = s })
{-# INLINE span #-}
instance Lower (Info scopeAddress) where
lowerBound = Info lowerBound lowerBound lowerBound Public lowerBound lowerBound Nothing
data ReferenceInfo = ReferenceInfo
{ refSpan :: Span
, refKind :: Kind
, refModule :: ModuleInfo
} deriving (Eq, Show, Ord, Generic, NFData)
instance HasSpan ReferenceInfo where
span = lens refSpan (\r s -> r { refSpan = s })
{-# INLINE span #-}
data Kind = TypeAlias | Class | Method | QualifiedAliasedImport | QualifiedExport | DefaultExport | Module | AbstractClass | Let | QualifiedImport | UnqualifiedImport | Assignment | RequiredParameter | PublicField | VariableDeclaration | Function | Parameter | Unknown | Identifier | TypeIdentifier | This | New | MemberAccess | Call
deriving (Eq, Show, Ord, Generic, NFData)
instance Lower Kind where
lowerBound = Unknown
lowerBound = Info lowerBound lowerBound Public lowerBound Nothing
-- Offsets and frame addresses in the heap should be addresses?
data Scope address =
Scope {
edges :: Map EdgeLabel [address]
, references :: Map Reference ([ReferenceInfo], Path address)
, declarations :: Seq (Info address)
}
| PreludeScope {
edges :: Map EdgeLabel [address]
, references :: Map Reference ([ReferenceInfo], Path address)
, declarations :: Seq (Info address)
}
deriving (Eq, Show, Ord, Generic, NFData)
data Scope address = Scope
{ edges :: Map EdgeLabel [address]
, references :: Map Reference (Path address)
, declarations :: Seq (Info address)
} deriving (Eq, Show, Ord, Generic, NFData)
instance Lower (Scope scopeAddress) where
lowerBound = Scope mempty mempty mempty
@ -193,7 +153,7 @@ pathPosition (DPath _ p) = p
pathPosition (EPath _ _ p) = pathPosition p
-- Returns the reference paths of a scope in a scope graph.
pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference ([ReferenceInfo], Path scope))
pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope))
pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph
-- Returns the declaration data of a scope in a scope graph.
@ -227,37 +187,35 @@ lookupScope scope = Map.lookup scope . unScopeGraph
-- TODO: Return the whole value in Maybe or Either.
declare :: Ord scope
=> Declaration
-> ModuleInfo
-> Relation
-> AccessControl
-> Span
-> Kind
-> Maybe scope
-> scope
-> ScopeGraph scope
-> (ScopeGraph scope, Maybe Position)
declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do
declare decl rel accessControl declSpan assocScope currentScope g = fromMaybe (g, Nothing) $ do
scope <- lookupScope currentScope g
dataSeq <- ddataOfScope currentScope g
case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of
Just index -> pure (g, Just (Position index))
Nothing -> do
let newScope = scope { declarations = declarations scope Seq.|> Info decl moduleInfo rel accessControl declSpan kind assocScope }
let newScope = scope { declarations = declarations scope Seq.|> Info decl rel accessControl declSpan assocScope }
pure (insertScope currentScope newScope g, Just (Position (length (declarations newScope))))
-- | Add a reference to a declaration in the scope graph.
-- Returns the original scope graph if the declaration could not be found.
reference :: Ord scope => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> scope -> ScopeGraph scope -> ScopeGraph scope
reference ref moduleInfo span kind decl currentAddress g = fromMaybe g $ do
reference :: Ord scope => Reference -> Declaration -> scope -> ScopeGraph scope -> ScopeGraph scope
reference ref decl currentAddress g = fromMaybe g $ do
-- Start from the current address
currentScope' <- lookupScope currentAddress g
-- Build a path up to the declaration
flip (insertScope currentAddress) g . flip (insertReference ref moduleInfo span kind) currentScope' <$> findPath (const Nothing) decl currentAddress g
flip (insertScope currentAddress) g . flip (insertReference ref) currentScope' <$> findPath (const Nothing) decl currentAddress g
-- | Insert a reference into the given scope by constructing a resolution path to the declaration within the given scope graph.
insertImportReference :: Ord address => Reference -> ModuleInfo -> Span -> Kind -> Declaration -> address -> ScopeGraph address -> Scope address -> Maybe (Scope address)
insertImportReference ref moduleInfo span kind decl currentAddress g scope = flip (insertReference ref moduleInfo span kind) scope . EPath Import currentAddress <$> findPath (const Nothing) decl currentAddress g
insertImportReference :: Ord address => Reference -> Declaration -> address -> ScopeGraph address -> Scope address -> Maybe (Scope address)
insertImportReference ref decl currentAddress g scope = flip (insertReference ref) scope . EPath Import currentAddress <$> findPath (const Nothing) decl currentAddress g
lookupScopePath :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress)
lookupScopePath declaration currentAddress g = findPath (flip (lookupReference declaration) g) (Declaration declaration) currentAddress g
@ -284,10 +242,8 @@ foldGraph combine address graph = go lowerBound address
pathToDeclaration :: Ord scopeAddress => Declaration -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress)
pathToDeclaration decl address g = DPath decl . snd <$> lookupDeclaration (unDeclaration decl) address g
insertReference :: Reference -> ModuleInfo -> Span -> Kind -> Path scopeAddress -> Scope scopeAddress -> Scope scopeAddress
insertReference ref moduleInfo span kind path scope = scope { references = Map.alter (\case
Nothing -> pure ([ ReferenceInfo span kind moduleInfo ], path)
Just (refInfos, path) -> pure (ReferenceInfo span kind moduleInfo : refInfos, path)) ref (references scope) }
insertReference :: Reference -> Path scopeAddress -> Scope scopeAddress -> Scope scopeAddress
insertReference ref path scope = scope { references = Map.insert ref path (references scope) }
lookupDeclaration :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Info scopeAddress, Position)
lookupDeclaration name scope g = do
@ -309,7 +265,7 @@ putDeclarationScopeAtPosition scope position assocScope g@(ScopeGraph graph) = f
pure $ ScopeGraph (Map.adjust (\s -> s { declarations = seq }) scope graph)
lookupReference :: Ord scopeAddress => Name -> scopeAddress -> ScopeGraph scopeAddress -> Maybe (Path scopeAddress)
lookupReference name scope g = fmap snd . Map.lookup (Reference name) =<< pathsOfScope scope g
lookupReference name scope g = Map.lookup (Reference name) =<< pathsOfScope scope g
insertEdge :: Ord scopeAddress => EdgeLabel -> scopeAddress -> scopeAddress -> ScopeGraph scopeAddress -> ScopeGraph scopeAddress
insertEdge label target currentAddress g@(ScopeGraph graph) = fromMaybe g $ do
@ -340,10 +296,6 @@ insertDeclarationSpan decl@Declaration{..} span g = fromMaybe g $ do
newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
newScope address edges = insertScope address (Scope edges mempty mempty)
-- | Insert a new scope with the given address and edges into the scope graph.
newPreludeScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
newPreludeScope address edges = insertScope address (PreludeScope edges mempty mempty)
insertScope :: Ord address => address -> Scope address -> ScopeGraph address -> ScopeGraph address
insertScope address scope = ScopeGraph . Map.insert address scope . unScopeGraph
@ -362,7 +314,7 @@ pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope)
pathOfRef ref graph = do
scope <- scopeOfRef ref graph
pathsMap <- pathsOfScope scope graph
snd <$> Map.lookup ref pathsMap
Map.lookup ref pathsMap
-- Returns the scope the declaration was declared in.
scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope
@ -389,9 +341,6 @@ newtype Declaration = Declaration { unDeclaration :: Name }
instance Lower Declaration where
lowerBound = Declaration $ name ""
formatDeclaration :: Declaration -> Text
formatDeclaration = formatName . unDeclaration
-- | The type of edge from a scope to its parent scopes.
-- Either a lexical edge or an import edge in the case of non-lexical edges.
data EdgeLabel = Lexical | Import | Export | Superclass

4
src/Data/Graph.hs
View File

@ -24,6 +24,7 @@ import Control.Effect
import Control.Effect.State
import Data.Aeson
import qualified Data.Set as Set
import Semantic.Api.V1.CodeAnalysisPB
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
@ -100,6 +101,9 @@ instance Ord vertex => Ord (Graph vertex) where
class VertexTag vertex where
uniqueTag :: vertex -> Int
instance VertexTag DiffTreeVertex where uniqueTag = fromIntegral . diffVertexId
instance VertexTag TermVertex where uniqueTag = fromIntegral . vertexId
instance (Ord vertex, ToJSON vertex, VertexTag vertex) => ToJSON (Graph vertex) where
toJSON (Graph graph) = object ["vertices" .= G.vertexList graph, "edges" .= (Edge <$> G.edgeList graph)]
toEncoding (Graph graph) = pairs ("vertices" .= G.vertexList graph <> "edges" .= (Edge <$> G.edgeList graph))

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

@ -147,8 +147,7 @@ instance VertexDeclarationWithStrategy 'Custom whole Declaration.Method where
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (locationSpan 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)
_ -> Nothing
toVertexWithStrategy proxy ann info (Expression.MemberAccess (Term (In lhsAnn lhs)) name) =
case toVertexWithStrategy proxy lhsAnn info lhs of
Just (Variable n _ _, _) -> Just (variableVertex (n <> "." <> formatName name) info (locationSpan ann), name)
_ -> Just (variableVertex (formatName name) info (locationSpan ann), name)

6
src/Data/Language.hs
View File

@ -2,7 +2,6 @@
module Data.Language
( Language (..)
, SLanguage (..)
, ensureLanguage
, extensionsForLanguage
, knownLanguage
, languageForFilePath
@ -100,11 +99,6 @@ instance FromJSON Language where
knownLanguage :: Language -> Bool
knownLanguage = (/= Unknown)
-- | Returns 'Nothing' when passed 'Unknown'.
ensureLanguage :: Language -> Maybe Language
ensureLanguage Unknown = Nothing
ensureLanguage x = Just x
-- | Defaults to 'Unknown'.
instance HasDefault Language where def = Unknown

2
src/Data/Source.hs
View File

@ -33,6 +33,8 @@ import Data.Array
import qualified Data.ByteString as B
import Data.Char (ord)
import Data.List (span)
import Data.Range
import Data.Span hiding (HasSpan (..))
import Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

3
src/Data/Span.hs
View File

@ -19,6 +19,7 @@ import Prologue
import Control.Lens.Lens
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson as A
import Proto3.Suite
import Data.JSON.Fields
@ -36,7 +37,7 @@ column = lens posColumn (\p l -> p { posColumn = l })
data Span = Span
{ spanStart :: Pos
, spanEnd :: Pos
} deriving (Eq, Ord, Generic, Hashable, NFData)
} deriving (Eq, Ord, Generic, Hashable, Named, NFData)
-- | "Classy-fields" interface for data types that have spans.
class HasSpan a where

9
src/Data/Syntax.hs
View File

@ -20,7 +20,6 @@ import Reprinting.Tokenize hiding (Element)
import qualified Assigning.Assignment as Assignment
import qualified Data.Error as Error
import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Control.Abstract.Heap (deref, lookupSlot)
-- Combinators
@ -123,13 +122,10 @@ newtype Identifier a = Identifier { name :: Name }
instance Evaluatable Identifier where
eval eval ref' term@(Identifier name) = do
-- FIXME: Set the span up correctly in ref so we can move the `reference` call there.
span <- ask @Span
reference (Reference name) span ScopeGraph.Identifier (Declaration name)
deref =<< ref eval ref' term
eval eval ref' = ref eval ref' >=> deref
ref _ _ (Identifier name) = do
reference (Reference name) (Declaration name)
lookupSlot (Declaration name)
@ -141,7 +137,6 @@ instance FreeVariables1 Identifier where
instance Declarations1 Identifier where
liftDeclaredName _ (Identifier x) = pure x
liftDeclaredAlias _ (Identifier x) = pure x
-- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier { contents :: Text }

25
src/Data/Syntax/Declaration.hs
View File

@ -30,14 +30,12 @@ instance Evaluatable Function where
eval _ _ Function{..} = do
name <- maybeM (throwNoNameError functionName) (declaredName functionName)
span <- ask @Span
associatedScope <- declareFunction name ScopeGraph.Public span ScopeGraph.Function
associatedScope <- declareFunction name Default ScopeGraph.Public span
params <- withScope associatedScope . for functionParameters $ \paramNode -> do
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
let paramSpan = getSpan paramNode
-- TODO: This might be a motivation for a typeclass for `declarationKind` since we
-- sometimes create declarations for our children.
param <$ declare (Declaration param) Default ScopeGraph.Public paramSpan ScopeGraph.Parameter Nothing
addr <- lookupSlot (Declaration name)
@ -61,7 +59,7 @@ declareFunction name accessControl span kind = do
currentScope' <- currentScope
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
associatedScope <- newScope lexicalEdges
declare (Declaration name) Default accessControl span kind (Just associatedScope)
declare (Declaration name) relation accessControl span (Just associatedScope)
pure associatedScope
instance Tokenize Function where
@ -96,14 +94,13 @@ instance Evaluatable Method where
eval _ _ Method{..} = do
name <- maybeM (throwNoNameError methodName) (declaredName methodName)
span <- ask @Span
associatedScope <- declareFunction name methodAccessControl span ScopeGraph.Method
associatedScope <- declareFunction name Default methodAccessControl span
params <- withScope associatedScope $ do
-- TODO: Should we give `self` a special Relation?
declare (Declaration __self) Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
declare (Declaration __self) Default ScopeGraph.Public emptySpan Nothing
for methodParameters $ \paramNode -> do
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
param <$ declare (Declaration param) Default ScopeGraph.Public span ScopeGraph.Parameter Nothing
param <$ declare (Declaration param) Default ScopeGraph.Public span Nothing
addr <- lookupSlot (Declaration name)
v <- function name params methodBody associatedScope
@ -170,12 +167,12 @@ newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a
instance Evaluatable VariableDeclaration where
eval _ _ (VariableDeclaration []) = unit
eval eval' _ (VariableDeclaration decs) = do
eval eval _ (VariableDeclaration decs) = do
for_ decs $ \declaration -> do
name <- maybeM (throwNoNameError declaration) (declaredName declaration)
let declarationSpan = getSpan declaration
declare (Declaration name) Default ScopeGraph.Public declarationSpan ScopeGraph.VariableDeclaration Nothing
eval' declaration
eval declaration
unit
instance Declarations a => Declarations (VariableDeclaration a) where
@ -213,7 +210,7 @@ instance Evaluatable PublicFieldDefinition where
span <- ask @Span
propertyName <- maybeM (throwNoNameError publicFieldPropertyName) (declaredName publicFieldPropertyName)
declare (Declaration propertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
declare (Declaration propertyName) Instance publicFieldAccessControl span Nothing
slot <- lookupSlot (Declaration propertyName)
value <- eval publicFieldValue
assign slot value
@ -249,13 +246,13 @@ instance Evaluatable Class where
superclassFrame <- scopedEnvironment =<< deref slot
pure $ case (scope, superclassFrame) of
(Just scope, Just frame) -> Just (scope, frame)
_ -> Nothing
_ -> Nothing
let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
declare (Declaration name) Default ScopeGraph.Public span (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
classFrame <- newFrame classScope frameEdges
@ -331,7 +328,7 @@ instance Evaluatable TypeAlias where
span <- ask @Span
assocScope <- associatedScope (Declaration kindName)
-- TODO: Should we consider a special Relation for `TypeAlias`?
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
declare (Declaration name) Default ScopeGraph.Public span assocScope
slot <- lookupSlot (Declaration name)
kindSlot <- lookupSlot (Declaration kindName)

47
src/Data/Syntax/Expression.hs
View File

@ -18,7 +18,6 @@ import qualified Data.Reprinting.Scope as Scope
import qualified Data.Reprinting.Token as Token
import Diffing.Algorithm hiding (Delete)
import Reprinting.Tokenize hiding (Superclass)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
@ -406,18 +405,18 @@ data MemberAccess a = MemberAccess { lhs :: a, rhs :: a }
deriving (Eq1, Show1, Ord1) via Generically MemberAccess
instance Declarations1 MemberAccess where
liftDeclaredName declaredName MemberAccess{..} = declaredName rhs
liftDeclaredName _ MemberAccess{..} = Just rhs
instance Evaluatable MemberAccess where
eval eval ref MemberAccess{..} = do
eval eval _ MemberAccess{..} = do
lhsValue <- eval lhs
lhsFrame <- Abstract.scopedEnvironment lhsValue
rhsSlot <- case lhsFrame of
Just lhsFrame ->
-- FIXME: The span is not set up correctly when calling `ref` so we have to eval
-- it first
withScopeAndFrame lhsFrame (eval rhs >> ref rhs)
withScopeAndFrame lhsFrame $ do
reference (Reference rhs) (Declaration rhs)
lookupSlot (Declaration rhs)
-- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object.
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
@ -427,28 +426,30 @@ instance Evaluatable MemberAccess where
let lhsAccessControl = fromMaybe Public (termToAccessControl lhs)
infos <- declarationsByAccessControl rhsScope lhsAccessControl
rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs)
rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of
rhsValue' <- case find (\Info{..} -> Declaration rhs == infoDeclaration) infos of
Just _ -> pure rhsValue
Nothing -> do
let lhsName = fromMaybe (name "") (declaredName lhs)
info <- declarationByName rhsScope (Declaration rhsName)
throwEvalError $ AccessControlError (lhsName, lhsAccessControl) (rhsName, infoAccessControl info) rhsValue
info <- declarationByName rhsScope (Declaration rhs)
throwEvalError $ AccessControlError (lhsName, lhsAccessControl) (rhs, infoAccessControl info) rhsValue
bindThis lhsValue rhsValue'
ref eval ref' MemberAccess{..} = do
ref eval _ MemberAccess{..} = do
lhsValue <- eval lhs
lhsFrame <- Abstract.scopedEnvironment lhsValue
case lhsFrame of
Just lhsFrame -> withScopeAndFrame lhsFrame (ref' rhs)
Just lhsFrame ->
withScopeAndFrame lhsFrame $ do
reference (Reference rhs) (Declaration rhs)
lookupSlot (Declaration rhs)
-- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object.
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
instance Tokenize MemberAccess where
tokenize MemberAccess{..} = lhs *> yield Access <* rhs
tokenize MemberAccess{..} = lhs *> yield Access *> yield (Run (formatName rhs))
-- | Subscript (e.g a[1])
data Subscript a = Subscript { lhs :: a, rhs :: [a] }
@ -553,20 +554,15 @@ instance Evaluatable New where
void . withScopeAndFrame objectFrame $ do
for_ instanceMembers $ \Info{..} -> do
declare infoDeclaration Default infoAccessControl infoSpan infoKind infoAssociatedScope
declare infoDeclaration Default infoAccessControl infoSpan infoAssociatedScope
-- TODO: This is a typescript specific name and we should allow languages to customize it.
let constructorName = Name.name "constructor"
maybeConstructor <- maybeLookupDeclaration (Declaration constructorName)
case maybeConstructor of
Just slot -> do
span <- ask @Span
reference (Reference constructorName) span ScopeGraph.New (Declaration constructorName)
constructor <- deref slot
args <- traverse eval newArguments
boundConstructor <- bindThis objectVal constructor
call boundConstructor args
Nothing -> pure objectVal
reference (Reference constructorName) (Declaration constructorName)
constructor <- deref =<< lookupSlot (Declaration constructorName)
args <- traverse eval newArguments
boundConstructor <- bindThis objectVal constructor
call boundConstructor args
pure objectVal
@ -595,8 +591,7 @@ instance Tokenize This where
instance Evaluatable This where
eval _ _ This = do
span <- ask @Span
reference (Reference __self) span ScopeGraph.This (Declaration __self)
reference (Reference __self) (Declaration __self)
deref =<< lookupSlot (Declaration __self)
instance AccessControls1 This where

2
src/Data/Syntax/Statement.hs
View File

@ -127,7 +127,7 @@ instance Evaluatable Let where
assocScope <- associatedScope (Declaration valueName)
_ <- withLexicalScopeAndFrame $ do
declare (Declaration name) Default Public letSpan ScopeGraph.Let assocScope
declare (Declaration name) Default Public letSpan assocScope
letVal <- eval letValue
slot <- lookupSlot (Declaration name)
assign slot letVal

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

@ -258,6 +258,9 @@ element = symbol Element *> children expression
fieldIdentifier :: Assignment Term
fieldIdentifier = makeTerm <$> symbol FieldIdentifier <*> (Syntax.Identifier . name <$> source)
fieldIdentifier' :: Assignment Name
fieldIdentifier' = symbol FieldIdentifier *> (name <$> source)
floatLiteral :: Assignment Term
floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source)
@ -295,6 +298,9 @@ runeLiteral = makeTerm <$> symbol Grammar.RuneLiteral <*> (Go.Syntax.Rune <$> so
typeIdentifier :: Assignment Term
typeIdentifier = makeTerm <$> symbol TypeIdentifier <*> (Syntax.Identifier . name <$> source)
typeIdentifier' :: Assignment Name
typeIdentifier' = symbol TypeIdentifier *> (name <$> source)
nil :: Assignment Term
nil = makeTerm <$> symbol Nil <*> (Literal.Null <$ source)
@ -344,7 +350,7 @@ pointerType :: Assignment Term
pointerType = makeTerm <$> symbol PointerType <*> children (Type.Pointer <$> expression)
qualifiedType :: Assignment Term
qualifiedType = makeTerm <$> symbol QualifiedType <*> children (Expression.MemberAccess <$> expression <*> typeIdentifier)
qualifiedType = makeTerm <$> symbol QualifiedType <*> children (Expression.MemberAccess <$> expression <*> typeIdentifier')
sliceType :: Assignment Term
sliceType = makeTerm <$> symbol SliceType <*> children (Type.Slice <$> expression)
@ -488,7 +494,7 @@ parenthesizedExpression :: Assignment Term
parenthesizedExpression = symbol ParenthesizedExpression *> children expressions
selectorExpression :: Assignment Term
selectorExpression = makeWithContext <$> symbol SelectorExpression <*> children ((,,) <$> expression <*> optional comment <*> fieldIdentifier)
selectorExpression = makeWithContext <$> symbol SelectorExpression <*> children ((,,) <$> expression <*> optional comment <*> fieldIdentifier')
where makeWithContext loc (lhs, comment, rhs) = maybe (makeTerm loc (Expression.MemberAccess lhs rhs)) (\c -> makeTerm loc (Syntax.Context (c :| []) (makeTerm loc (Expression.MemberAccess lhs rhs)))) comment
sliceExpression :: Assignment Term

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

@ -78,7 +78,7 @@ instance Evaluatable QualifiedImport where
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
span <- ask @Span
scopeAddress <- newScope mempty
declare (Declaration alias) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress)
declare (Declaration alias) Default Public span (Just scopeAddress)
aliasSlot <- lookupSlot (Declaration alias)
withScope scopeAddress $ do

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

@ -303,7 +303,7 @@ typeIdentifier :: Assignment Term
typeIdentifier = makeTerm <$> symbol TypeIdentifier <*> (Syntax.Identifier . name <$> source)
scopedIdentifier :: Assignment Term
scopedIdentifier = makeTerm <$> symbol ScopedIdentifier <*> children (Expression.MemberAccess <$> term expression <*> identifier)
scopedIdentifier = makeTerm <$> symbol ScopedIdentifier <*> children (Expression.MemberAccess <$> term expression <*> identifier')
superInterfaces :: Assignment [Term]
superInterfaces = symbol SuperInterfaces *> children (symbol InterfaceTypeList *> children(manyTerm type'))
@ -337,7 +337,7 @@ generic :: Assignment Term
generic = makeTerm <$> symbol Grammar.GenericType <*> children(Java.Syntax.GenericType <$> term type' <*> manyTerm type')
methodInvocation :: Assignment Term
methodInvocation = makeTerm <$> symbol MethodInvocation <*> children (uncurry Expression.Call <$> (callFunction <$> expression <*> optional ((,) <$ optional (token AnonRParen) <* token AnonDot <*> manyTerm typeArgument <*> identifier)) <*> (argumentList <|> pure []) <*> emptyTerm)
methodInvocation = makeTerm <$> symbol MethodInvocation <*> children (uncurry Expression.Call <$> (callFunction <$> expression <*> optional ((,) <$ optional (token AnonRParen) <* token AnonDot <*> manyTerm typeArgument <*> identifier')) <*> (argumentList <|> pure []) <*> emptyTerm)
where
callFunction a (Just (typeArguments, b)) = (typeArguments, makeTerm1 (Expression.MemberAccess a b))
callFunction a Nothing = ([], a)
@ -347,7 +347,7 @@ methodReference = makeTerm <$> symbol Grammar.MethodReference <*> children (Java
where new = makeTerm <$> token AnonNew <*> pure Java.Syntax.NewKeyword
explicitConstructorInvocation :: Assignment Term
explicitConstructorInvocation = makeTerm <$> symbol ExplicitConstructorInvocation <*> children (uncurry Expression.Call <$> (callFunction <$> term expression <*> optional ((,) <$ optional (token AnonRParen) <* token AnonDot <*> manyTerm type' <*> identifier)) <*> argumentList <*> emptyTerm)
explicitConstructorInvocation = makeTerm <$> symbol ExplicitConstructorInvocation <*> children (uncurry Expression.Call <$> (callFunction <$> term expression <*> optional ((,) <$ optional (token AnonRParen) <* token AnonDot <*> manyTerm type' <*> identifier')) <*> argumentList <*> emptyTerm)
where
callFunction a (Just (typeArguments, b)) = (typeArguments, makeTerm1 (Expression.MemberAccess a b))
callFunction a Nothing = ([], a)
@ -402,7 +402,7 @@ type' = choice [
, makeTerm <$> symbol FloatingPointType <*> children (pure Type.Float)
, makeTerm <$> symbol BooleanType <*> children (pure Type.Bool)
, symbol ArrayType *> children (array <$> type' <*> dims) -- type rule recurs into itself
, makeTerm <$> symbol ScopedTypeIdentifier <*> children (Expression.MemberAccess <$> term type' <*> identifier)
, makeTerm <$> symbol ScopedTypeIdentifier <*> children (Expression.MemberAccess <$> term type' <*> identifier')
, wildcard
, identifier
, typeIdentifier
@ -638,7 +638,7 @@ castExpression :: Assignment Term
castExpression = makeTerm <$> symbol CastExpression <*> children (flip Type.Annotation <$> type' <*> term expression)
fieldAccess :: Assignment Term
fieldAccess = makeTerm <$> symbol FieldAccess <*> children (Expression.MemberAccess <$> term expression <*> identifier)
fieldAccess = makeTerm <$> symbol FieldAccess <*> children (Expression.MemberAccess <$> term expression <*> identifier')
spreadParameter :: Assignment Term
spreadParameter = makeTerm <$> symbol Grammar.SpreadParameter <*> children (Java.Syntax.SpreadParameter <$> (makeSingleDecl <$> manyTerm modifier <*> type' <*> variableDeclarator))

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

@ -303,7 +303,7 @@ parenthesizedExpression :: Assignment Term
parenthesizedExpression = symbol ParenthesizedExpression *> children (term expression)
classConstantAccessExpression :: Assignment Term
classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> name)
classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> name')
variable :: Assignment Term
variable = callableVariable <|> scopedPropertyAccessExpression <|> memberAccessExpression <|> castExpression
@ -318,11 +318,11 @@ callableVariable = choice [
]
memberCallExpression :: Assignment Term
memberCallExpression = makeTerm <$> symbol MemberCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term dereferencableExpression <*> memberName) <*> arguments <*> emptyTerm)
memberCallExpression = makeTerm <$> symbol MemberCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term dereferencableExpression <*> memberName') <*> arguments <*> emptyTerm)
where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName)
scopedCallExpression :: Assignment Term
scopedCallExpression = makeTerm <$> symbol ScopedCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term scopeResolutionQualifier <*> memberName) <*> arguments <*> emptyTerm)
scopedCallExpression = makeTerm <$> symbol ScopedCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term scopeResolutionQualifier <*> memberName') <*> arguments <*> emptyTerm)
where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName)
functionCallExpression :: Assignment Term
@ -340,13 +340,13 @@ subscriptExpression :: Assignment Term
subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term dereferencableExpression <*> (pure <$> (term expression <|> emptyTerm)))
memberAccessExpression :: Assignment Term
memberAccessExpression = makeTerm <$> symbol MemberAccessExpression <*> children (Expression.MemberAccess <$> term dereferencableExpression <*> memberName)
memberAccessExpression = makeTerm <$> symbol MemberAccessExpression <*> children (Expression.MemberAccess <$> term dereferencableExpression <*> memberName')
dereferencableExpression :: Assignment Term
dereferencableExpression = symbol DereferencableExpression *> children (term (variable <|> expression <|> arrayCreationExpression <|> string))
scopedPropertyAccessExpression :: Assignment Term
scopedPropertyAccessExpression = makeTerm <$> symbol ScopedPropertyAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> simpleVariable')
scopedPropertyAccessExpression = makeTerm <$> symbol ScopedPropertyAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> simpleVariable'')
scopeResolutionQualifier :: Assignment Term
scopeResolutionQualifier = choice [

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

@ -32,6 +32,7 @@ import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import qualified Data.Text as T
import Language.Python.Grammar as Grammar
import Language.Python.Syntax as Python.Syntax
import Prologue
@ -114,7 +115,6 @@ type Syntax =
, Syntax.Error
, Syntax.Identifier
, Type.Annotation
, Python.Syntax.Alias
, []
]
@ -377,6 +377,9 @@ yield = makeTerm <$> symbol Yield <*> (Statement.Yield <$> children (term ( expr
identifier :: Assignment Term
identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source)
identifier' :: Assignment Name
identifier' = (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) *> (name <$> source)
set :: Assignment Term
set = makeTerm <$> symbol Set <*> children (Literal.Set <$> manyTerm expression)
@ -412,11 +415,11 @@ import' = makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliase
-- `import a as b`
aliasedImport = makeTerm <$> symbol AliasedImport <*> children (Python.Syntax.QualifiedAliasedImport <$> importPath <*> expression)
-- `import a`
plainImport = makeTerm <$> symbol DottedName <*> children (Python.Syntax.QualifiedImport <$> NonEmpty.some1 identifier)
plainImport = makeTerm <$> symbol DottedName <*> children (Python.Syntax.QualifiedImport . NonEmpty.map T.unpack <$> NonEmpty.some1 identifierSource)
-- `from a import foo `
importSymbol = makeNameAliasPair <$> (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) <*> (mkIdentifier <$> location <*> source)
importSymbol = makeNameAliasPair <$> aliasIdentifier <*> pure Nothing
-- `from a import foo as bar`
aliasImportSymbol = makeTerm <$> symbol AliasedImport <*> children (Python.Syntax.Alias <$> identifier <*> identifier)
aliasImportSymbol = symbol AliasedImport *> children (makeNameAliasPair <$> aliasIdentifier <*> (Just <$> aliasIdentifier))
-- `from a import *`
wildcard = symbol WildcardImport *> (name <$> source) $> []
@ -426,8 +429,9 @@ import' = makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliase
importPrefix = symbol ImportPrefix *> source
identifierSource = (symbol Identifier <|> symbol Identifier') *> source
makeNameAliasPair location alias = makeTerm location (Python.Syntax.Alias alias alias)
mkIdentifier location source = makeTerm location (Syntax.Identifier (name source))
aliasIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source) <|> symbol DottedName *> (name <$> source)
makeNameAliasPair from (Just alias) = Python.Syntax.Alias from alias
makeNameAliasPair from Nothing = Python.Syntax.Alias from from
assertStatement :: Assignment Term
assertStatement = makeTerm <$> symbol AssertStatement <*> children (Expression.Call [] <$> (makeTerm <$> symbol AnonAssert <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm)
@ -484,7 +488,7 @@ continueStatement :: Assignment Term
continueStatement = makeTerm <$> symbol ContinueStatement <*> (Statement.Continue <$> emptyTerm <* advance)
memberAccess :: Assignment Term
memberAccess = makeTerm <$> symbol Attribute <*> children (Expression.MemberAccess <$> term expression <*> identifier)
memberAccess = makeTerm <$> symbol Attribute <*> children (Expression.MemberAccess <$> term expression <*> identifier')
subscript :: Assignment Term
subscript = makeTerm <$> symbol Subscript <*> children (Expression.Subscript <$> term expression <*> manyTerm expression)

7
src/Language/Python/Syntax.hs
View File

@ -123,6 +123,7 @@ instance Evaluatable Import where
path <- NonEmpty.last <$> resolvePythonModules (RelativeQualifiedName n (Just (qualifiedName (formatName aliasValue' :| []))))
((moduleScope, moduleFrame), _) <- require path
span <- ask @Span
-- Construct a proxy scope containing an import edge to the imported module's last returned scope.
importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ])
@ -189,7 +190,7 @@ instance Evaluatable QualifiedImport where
eval _ _ (QualifiedImport qualifiedNames) = do
qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths)
let namesAndPaths = toList (NonEmpty.zip (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName) modulePaths)
go namesAndPaths
unit
@ -208,7 +209,7 @@ instance Evaluatable QualifiedImport where
assign aliasSlot val
withFrame objFrame $ do
let (namePaths, rest) = List.partition ((== name) . snd . fst) namesAndPaths
let (namePaths, rest) = List.partition ((== name) . fst) namesAndPaths
for_ namePaths $ \(_, modulePath) -> do
mkScopeMap modulePath $ \scopeMap -> do
withFrame objFrame $ do
@ -231,7 +232,7 @@ instance Evaluatable QualifiedAliasedImport where
span <- ask @Span
scopeAddress <- newScope mempty
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just scopeAddress)
declare (Declaration alias) Default Public span (Just scopeAddress)
objFrame <- newFrame scopeAddress mempty
val <- object objFrame
aliasSlot <- lookupSlot (Declaration alias)

9
src/Language/Ruby/Syntax.hs
View File

@ -77,8 +77,7 @@ instance Evaluatable Send where
lhsFrame <- Abstract.scopedEnvironment lhsValue
let callFunction = do
span <- ask @Span
reference (Reference sel) span ScopeGraph.Call (Declaration sel)
reference (Reference sel) (Declaration sel)
func <- deref =<< lookupSlot (Declaration sel)
args <- traverse eval sendArgs
boundFunc <- bindThis lhsValue func
@ -210,7 +209,7 @@ instance Evaluatable Class where
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Class (Just classScope)
declare (Declaration name) Default Public span (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
childFrame <- newFrame classScope frameEdges
@ -260,7 +259,7 @@ instance Evaluatable Module where
Nothing -> do
let edges = Map.singleton Lexical [ currentScope' ]
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Module (Just classScope)
declare (Declaration name) Default Public span (Just classScope)
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
@ -326,7 +325,7 @@ instance Evaluatable Assignment where
lhsName <- maybeM (throwNoNameError assignmentTarget) (declaredName assignmentTarget)
maybeSlot <- maybeLookupDeclaration (Declaration lhsName)
assignmentSpan <- ask @Span
maybe (declare (Declaration lhsName) Default Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot
maybe (declare (Declaration lhsName) Default Public assignmentSpan Nothing) (const (pure ())) maybeSlot
lhs <- ref assignmentTarget
rhs <- eval assignmentValue

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

@ -298,7 +298,7 @@ ternaryExpression :: Assignment Term
ternaryExpression = makeTerm <$> symbol Grammar.TernaryExpression <*> children (Statement.If <$> term expression <*> term expression <*> term expression)
memberExpression :: Assignment Term
memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier)
memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier')
newExpression :: Assignment Term
newExpression = makeTerm <$> symbol Grammar.NewExpression <*> children (Expression.New <$> term constructableExpression <*> (typeArguments' <|> emptyTerm) <*> (arguments <|> pure []))

15
src/Language/TypeScript/Syntax/Import.hs
View File

@ -13,7 +13,6 @@ import Data.JSON.Fields
import qualified Data.Map.Strict as Map
import Diffing.Algorithm
import Language.TypeScript.Resolution
import Data.Span (emptySpan)
data Import a = Import { importSymbols :: ![Alias], importFrom :: ImportPath }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
@ -36,9 +35,7 @@ instance Evaluatable Import where
-- Insert import references into the import scope starting from the perspective of the import scope.
withScopeAndFrame moduleFrame $ do
for_ symbols $ \Alias{..} ->
-- TODO: Need an easier way to get the span of an Alias. It's difficult because we no longer have a term.
-- Even if we had one we'd have to evaluate it at the moment.
insertImportReference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue) scopeAddress
insertImportReference (Reference aliasName) (Declaration aliasValue) scopeAddress
-- Create edges from the current scope/frame to the import scope/frame.
insertImportEdge scopeAddress
@ -60,7 +57,7 @@ instance Evaluatable QualifiedAliasedImport where
aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap)
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope)
declare (Declaration alias) Default Public span (Just importScope)
aliasSlot <- lookupSlot (Declaration alias)
assign aliasSlot =<< object aliasFrame
@ -90,8 +87,7 @@ instance Evaluatable QualifiedExport where
insertExportEdge exportScope -- Create an export edge from the current scope to the export scope
withScope exportScope .
for_ exportSymbols $ \Alias{..} -> do
-- TODO: Replace Alias in QualifedExport with terms and use a real span
reference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue)
reference (Reference aliasName) (Declaration aliasValue)
-- Create an export edge from a new scope to the qualifed export's scope.
unit
@ -117,8 +113,7 @@ instance Evaluatable QualifiedExportFrom where
withScopeAndFrame moduleFrame .
for_ exportSymbols $ \Alias{..} -> do
-- TODO: Replace Alias with terms in QualifiedExportFrom and use a real span below.
insertImportReference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue) exportScope
insertImportReference (Reference aliasName) (Declaration aliasValue) exportScope
insertExportEdge exportScope
insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame)
@ -139,7 +134,7 @@ instance Evaluatable DefaultExport where
withScopeAndFrame exportFrame $ do
valueRef <- eval term
let declaration = Declaration $ Name.name "__default"
declare declaration Default Public exportSpan ScopeGraph.DefaultExport Nothing
declare declaration Default Public exportSpan Nothing
defaultSlot <- lookupSlot declaration
assign defaultSlot valueRef

2
src/Language/TypeScript/Syntax/JSX.hs
View File

@ -78,7 +78,7 @@ instance Evaluatable RequiredParameter where
eval eval ref RequiredParameter{..} = do
name <- maybeM (throwNoNameError requiredParameterSubject) (declaredName requiredParameterSubject)
span <- ask @Span
declare (Declaration name) Default Public span ScopeGraph.RequiredParameter Nothing
declare (Declaration name) Default Public span Nothing
lhs <- ref requiredParameterSubject
rhs <- eval requiredParameterValue

3
src/Language/TypeScript/Syntax/JavaScript.hs
View File

@ -3,6 +3,7 @@
module Language.TypeScript.Syntax.JavaScript where
import Prologue
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph hiding (Import)
import Data.Abstract.Evaluatable
@ -25,7 +26,7 @@ instance Evaluatable JavaScriptRequire where
Just alias -> do
span <- ask @Span
importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ])
declare (Declaration alias) Default Public span ScopeGraph.UnqualifiedImport (Just importScope)
declare (Declaration alias) Default Public span (Just importScope)
let scopeMap = Map.singleton moduleScope moduleFrame
aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap)
aliasSlot <- lookupSlot (Declaration alias)

7
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -13,7 +13,6 @@ import Data.Semigroup.App
import Data.Semigroup.Foldable
import qualified Data.Text as T
import Diffing.Algorithm
import qualified Data.Abstract.ScopeGraph as ScopeGraph
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier { contents :: T.Text }
@ -212,7 +211,7 @@ declareModule eval identifier statements = do
Nothing -> do
let edges = Map.singleton Lexical [ currentScope' ]
childScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Module (Just childScope)
declare (Declaration name) Default Public span (Just childScope)
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
@ -268,13 +267,13 @@ instance Evaluatable AbstractClass where
superclassFrame <- scopedEnvironment =<< deref slot
pure $ case (scope, superclassFrame) of
(Just scope, Just frame) -> Just (scope, frame)
_ -> Nothing
_ -> Nothing
let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.AbstractClass (Just classScope)
declare (Declaration name) Default Public span (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
childFrame <- newFrame classScope frameEdges

5
src/Language/TypeScript/Syntax/Types.hs
View File

@ -9,7 +9,6 @@ import Data.Abstract.Evaluatable as Evaluatable
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import qualified Data.Abstract.ScopeGraph as ScopeGraph
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
@ -61,14 +60,12 @@ newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text }
instance Declarations1 TypeIdentifier where
liftDeclaredName _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier)
liftDeclaredAlias _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier)
-- TODO: TypeIdentifier shouldn't evaluate to an address in the heap?
instance Evaluatable TypeIdentifier where
eval _ _ TypeIdentifier{..} = do
-- Add a reference to the type identifier in the current scope.
span <- ask @Span
reference (Reference (Evaluatable.name contents)) span ScopeGraph.TypeIdentifier (Declaration (Evaluatable.name contents))
reference (Reference (Evaluatable.name contents)) (Declaration (Evaluatable.name contents))
unit
data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a }

3
src/Proto3/Google/Timestamp.hs
View File

@ -4,6 +4,7 @@ module Proto3.Google.Timestamp (Timestamp (..)) where
import Prologue
import Data.Aeson
import Proto3.Suite
-- | Predefined timestamp message provided by Google. The schema can be found
@ -11,4 +12,4 @@ import Proto3.Suite
data Timestamp = Timestamp
{ timestampSeconds :: Int64
, timestampNanos :: Int32
} deriving (Eq, Show, Generic, Message, Named, NFData)
} deriving (Eq, Ord, Show, Generic, Message, Named, NFData, FromJSON, ToJSON)

2
src/Proto3/Google/Wrapped.hs
View File

@ -14,7 +14,7 @@ import Proto3.Suite
-- a separate data type for each of these wrappers: we just need to declare 'Named' instances for each instance
-- for which we want to link the Google-named wrapped types.
newtype Wrapped a = Wrapped { value :: a }
deriving (Eq, Show, Generic, NFData)
deriving (Eq, Show, Ord, Generic, NFData)
instance Named (Wrapped Text) where nameOf _ = "StringValue"
instance Named (Wrapped ByteString) where nameOf _ = "BytesValue"

30
src/Rendering/Graph.hs
View File

@ -18,8 +18,10 @@ import Data.Patch
import Data.String (IsString (..))
import Data.Term
import Prologue
import Semantic.API.Helpers
import Semantic.API.Types
import Semantic.Api.Helpers
import Semantic.Api.V1.CodeAnalysisPB
import qualified Data.Text as T
-- TODO: rename as this isn't a render
renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
@ -45,10 +47,10 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId))
{ graphName = fromString (quote name)
, vertexAttributes = vertexAttributes }
where quote a = "\"" <> a <> "\""
vertexAttributes (DiffTreeVertex _ (Just (Deleted (Just DeletedTerm{..})))) = [ "label" := fromString term, "color" := "red" ]
vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString term, "color" := "green" ]
vertexAttributes (DiffTreeVertex _ (Just (Deleted (Just DeletedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "red" ]
vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "green" ]
vertexAttributes (DiffTreeVertex _ (Just (Replaced (Just ReplacedTerm{..})))) = [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ]
vertexAttributes (DiffTreeVertex _ (Just (Merged (Just MergedTerm{..})))) = [ "label" := fromString term ]
vertexAttributes (DiffTreeVertex _ (Just (Merged (Just MergedTerm{..})))) = [ "label" := fromString (T.unpack term) ]
vertexAttributes _ = []
class ToTreeGraph vertex t | t -> vertex where
@ -70,22 +72,22 @@ instance (ConstructorName syntax, Foldable syntax) =>
termAlgebra (In ann syntax) = do
i <- fresh
parent <- ask
let root = vertex (TermVertex i (constructorName syntax) (spanToSpan (locationSpan ann)))
let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (spanToSpan (locationSpan 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 d = case d of
Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (constructorName syntax) (ann a1) (ann a2))))
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (constructorName syntax) (ann a1))))
Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (InsertedTerm (constructorName syntax) (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 (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (InsertedTerm (T.pack (constructorName syntax)) (ann a2))))
Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
i <- fresh
parent <- ask
let (beforeName, beforeSpan) = (constructorName syntax1, ann a1)
let (afterName, afterSpan) = (constructorName syntax2, ann a2)
let replace = vertex (DiffTreeVertex i (Just (Replaced (Just (ReplacedTerm beforeName beforeSpan afterName afterSpan)))))
let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1)
let (afterName, afterSpan) = (T.pack (constructorName syntax2), ann a2)
let replace = vertex (DiffTreeVertex (fromIntegral i) (Just (Replaced (Just (ReplacedTerm beforeName beforeSpan 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)
where
@ -96,10 +98,10 @@ instance (ConstructorName syntax, Foldable syntax) =>
, Member (Reader (Graph DiffTreeVertex)) sig
, Carrier sig m
, Monad m
) => f (m (Graph DiffTreeVertex)) -> DiffTreeTerm -> m (Graph DiffTreeVertex)
) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertexDiffTerm -> m (Graph DiffTreeVertex)
diffAlgebra syntax a = do
i <- fresh
parent <- ask
let root = vertex (DiffTreeVertex i (Just a))
let root = vertex (DiffTreeVertex (fromIntegral i) (Just a))
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)

12
src/Semantic/API.hs
View File

@ -1,4 +1,4 @@
module Semantic.API
module Semantic.Api
(
module DiffsAPI
, module SymbolsAPI
@ -7,8 +7,8 @@ module Semantic.API
, module Types
) where
import Semantic.API.Diffs as DiffsAPI
import Semantic.API.Symbols as SymbolsAPI
import Semantic.API.Terms as TermsAPI
import Semantic.API.TOCSummaries as TOCSummariesAPI
import Semantic.API.Types as Types
import Semantic.Api.Diffs as DiffsAPI
import Semantic.Api.Symbols as SymbolsAPI
import Semantic.Api.Terms as TermsAPI
import Semantic.Api.TOCSummaries as TOCSummariesAPI
import Semantic.Api.V1.CodeAnalysisPB as Types hiding (Language(..))

17
src/Semantic/API/Diffs.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, ConstraintKinds, TypeOperators, RankNTypes #-}
module Semantic.API.Diffs
module Semantic.Api.Diffs
( parseDiffBuilder
, DiffOutputFormat(..)
, diffGraph
@ -26,15 +26,16 @@ import Data.Language
import Data.Location
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Diffing.Algorithm (Diffable)
import Parsing.Parser
import Prologue
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.API.Helpers
import Semantic.API.Types hiding (Blob, BlobPair)
import qualified Semantic.API.Types as API
import Semantic.Api.Helpers
import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair, Language(..))
import qualified Semantic.Api.V1.CodeAnalysisPB as API
import Semantic.Task as Task
import Semantic.Telemetry as Stat
import Serializing.Format hiding (JSON)
@ -72,21 +73,21 @@ renderJSONGraph :: (Applicative m, Functor syntax, Foldable syntax, ConstructorN
renderJSONGraph blobPair = pure . renderJSONAdjDiff blobPair . renderTreeGraph
diffGraph :: (Traversable t, DiffEffects sig m) => t API.BlobPair -> m DiffTreeGraphResponse
diffGraph blobs = DiffTreeGraphResponse . toList <$> distributeFor (apiBlobPairToBlobPair <$> blobs) go
diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor (apiBlobPairToBlobPair <$> blobs) go
where
go :: (DiffEffects sig m) => BlobPair -> m DiffTreeFileGraph
go blobPair = doDiff blobPair (const pure) render
`catchError` \(SomeException e) ->
pure (DiffTreeFileGraph path lang mempty mempty [ParseError (show e)])
pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
where
path = T.pack $ pathForBlobPair blobPair
lang = languageForBlobPair blobPair
lang = languageToApiLanguage $ languageForBlobPair blobPair
render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph
render _ diff =
let graph = renderTreeGraph diff
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
in pure $ DiffTreeFileGraph path lang (vertexList graph) (fmap toEdge (edgeList graph)) mempty
in pure $ DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
sexpDiff :: (DiffEffects sig m) => BlobPair -> m Builder

43
src/Semantic/API/Helpers.hs
View File

@ -1,24 +1,27 @@
{-# LANGUAGE LambdaCase #-}
module Semantic.API.Helpers
module Semantic.Api.Helpers
( spanToSpan
, spanToLegacySpan
, toChangeType
, apiBlobToBlob
, apiBlobPairToBlobPair
, apiLanguageToLanguage
, languageToApiLanguage
) where
import Data.Bifunctor.Join
import qualified Data.Blob as Data
import qualified Data.Language as Data
import Data.Source (fromText)
import qualified Data.Span as Data
import qualified Data.Text as T
import Data.These
import qualified Semantic.API.LegacyTypes as Legacy
import qualified Semantic.API.Types as API
import qualified Semantic.Api.LegacyTypes as Legacy
import qualified Semantic.Api.V1.CodeAnalysisPB as API
spanToSpan :: Data.Span -> Maybe API.Span
spanToSpan Data.Span{..} = Just $ API.Span (toPos spanStart) (toPos spanEnd)
where toPos Data.Pos{..} = Just $ API.Position posLine posColumn
where toPos Data.Pos{..} = Just $ API.Position (fromIntegral posLine) (fromIntegral posColumn)
spanToLegacySpan :: Data.Span -> Maybe Legacy.Span
spanToLegacySpan Data.Span{..} = Just $ Legacy.Span (toPos spanStart) (toPos spanEnd)
@ -32,7 +35,37 @@ toChangeType = \case
_ -> API.None
apiBlobToBlob :: API.Blob -> Data.Blob
apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) path language
apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language)
apiLanguageToLanguage :: API.Language -> Data.Language
apiLanguageToLanguage = \case
API.Unknown -> Data.Unknown
API.Go -> Data.Go
API.Haskell -> Data.Haskell
API.Java -> Data.Java
API.Javascript -> Data.JavaScript
API.Json -> Data.JSON
API.Jsx -> Data.JSX
API.Markdown -> Data.Markdown
API.Python -> Data.Python
API.Ruby -> Data.Ruby
API.Typescript -> Data.TypeScript
API.Php -> Data.PHP
languageToApiLanguage :: Data.Language -> API.Language
languageToApiLanguage = \case
Data.Unknown -> API.Unknown
Data.Go -> API.Go
Data.Haskell -> API.Haskell
Data.Java -> API.Java
Data.JavaScript -> API.Javascript
Data.JSON -> API.Json
Data.JSX -> API.Jsx
Data.Markdown -> API.Markdown
Data.Python -> API.Python
Data.Ruby -> API.Ruby
Data.TypeScript -> API.Typescript
Data.PHP -> API.Php
apiBlobPairToBlobPair :: API.BlobPair -> Data.BlobPair
apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Join (These (apiBlobToBlob before) (apiBlobToBlob after))

2
src/Semantic/API/LegacyTypes.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-}
module Semantic.API.LegacyTypes
module Semantic.Api.LegacyTypes
( DiffTreeRequest(..)
, ParseTreeRequest(..)
, ParseTreeSymbolResponse(..)

21
src/Semantic/API/Symbols.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
module Semantic.API.Symbols
module Semantic.Api.Symbols
( legacyParseSymbols
, parseSymbols
, parseSymbolsBuilder
@ -15,14 +15,16 @@ import Data.ByteString.Builder
import Data.Location
import Data.Maybe
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Text (pack)
import Parsing.Parser
import Prologue
import Semantic.API.Helpers
import qualified Semantic.API.LegacyTypes as Legacy
import Semantic.API.Terms (ParseEffects, doParse)
import Semantic.API.Types hiding (Blob)
import qualified Semantic.API.Types as API
import Semantic.Api.Helpers
import qualified Semantic.Api.LegacyTypes as Legacy
import Semantic.Api.Terms (ParseEffects, doParse)
import Semantic.Api.V1.CodeAnalysisPB hiding (Blob)
import qualified Semantic.Api.V1.CodeAnalysisPB as API
import Semantic.Task
import Serializing.Format
import Tags.Taggable
@ -56,18 +58,18 @@ parseSymbolsBuilder blobs
= legacyParseSymbols blobs >>= serialize JSON
parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t API.Blob -> m ParseTreeSymbolResponse
parseSymbols blobs = ParseTreeSymbolResponse . toList <$> distributeFor (apiBlobToBlob <$> blobs) go
parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor (apiBlobToBlob <$> blobs) go
where
go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m File
go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
where
errorFile e = File (pack blobPath) blobLanguage mempty [ParseError e]
errorFile e = File (pack blobPath) (languageToApiLanguage blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File
renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term)
tagsToFile :: Blob -> [Tag] -> File
tagsToFile Blob{..} tags = File (pack blobPath) blobLanguage (fmap tagToSymbol tags) mempty
tagsToFile Blob{..} tags = File (pack blobPath) (languageToApiLanguage blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty
tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..}
@ -76,4 +78,5 @@ parseSymbols blobs = ParseTreeSymbolResponse . toList <$> distributeFor (apiBlob
, kind = kind
, line = fromMaybe mempty line
, span = spanToSpan span
, docs = fmap Docstring docs
}

23
src/Semantic/API/TOCSummaries.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
module Semantic.API.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
import Analysis.TOCSummary (Declaration, declarationAlgebra)
import Control.Effect.Error
@ -10,11 +10,12 @@ import Data.Diff
import qualified Data.Map.Monoidal as Map
import Data.Span (emptySpan)
import qualified Data.Text as T
import qualified Data.Vector as V
import Rendering.TOC
import Semantic.API.Diffs
import Semantic.API.Helpers
import Semantic.API.Types hiding (Blob, BlobPair)
import qualified Semantic.API.Types as API
import Semantic.Api.Diffs
import Semantic.Api.Helpers
import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair)
import qualified Semantic.Api.V1.CodeAnalysisPB as API
import Semantic.Task as Task
import Serializing.Format
@ -37,23 +38,23 @@ legacyDiffSummary = distributeFoldMap go
render blobPair = pure . renderToCDiff blobPair
diffSummary :: (DiffEffects sig m) => [API.BlobPair] -> m DiffTreeTOCResponse
diffSummary blobs = DiffTreeTOCResponse <$> distributeFor (apiBlobPairToBlobPair <$> blobs) go
diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor (apiBlobPairToBlobPair <$> blobs) go
where
go :: (DiffEffects sig m) => BlobPair -> m TOCSummaryFile
go blobPair = doDiff blobPair (decorate . declarationAlgebra) render
`catchError` \(SomeException e) ->
pure $ TOCSummaryFile path lang mempty [TOCSummaryError (T.pack (show e)) Nothing]
pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
where path = T.pack $ pathKeyForBlobPair blobPair
lang = languageForBlobPair blobPair
lang = languageToApiLanguage $ languageForBlobPair blobPair
render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile
render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
where
path = T.pack $ pathKeyForBlobPair blobPair
lang = languageForBlobPair blobPair
lang = languageToApiLanguage $ languageForBlobPair blobPair
go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
go TOCSummary{..} TOCSummaryFile{..}
= TOCSummaryFile path language (TOCSummaryChange summaryCategoryName summaryTermName (spanToSpan summarySpan) (toChangeType summaryChangeType) : changes) errors
= TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (spanToSpan summarySpan) (toChangeType summaryChangeType)) changes) errors
go ErrorSummary{..} TOCSummaryFile{..}
= TOCSummaryFile path language changes (TOCSummaryError errorText (spanToSpan errorSpan) : errors)
= TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (spanToSpan errorSpan)) errors)

21
src/Semantic/API/Terms.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE ConstraintKinds, GADTs, TypeOperators, DerivingStrategies #-}
module Semantic.API.Terms
module Semantic.Api.Terms
(
termGraph
, parseTermBuilder
@ -28,36 +28,37 @@ import Data.JSON.Fields
import Data.Language
import Data.Location
import Data.Quieterm
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Parsing.Parser
import Prologue
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.API.Helpers
import Semantic.API.Types hiding (Blob)
import qualified Semantic.API.Types as API
import Semantic.Api.Helpers
import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, Language (..))
import qualified Semantic.Api.V1.CodeAnalysisPB as API
import Semantic.Task
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
import Tags.Taggable
import Data.Term
termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t API.Blob -> m ParseTreeGraphResponse
termGraph blobs = ParseTreeGraphResponse . toList <$> distributeFor (fmap apiBlobToBlob blobs) go
termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor (fmap apiBlobToBlob blobs) go
where
go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph
go blob = (doParse blob >>= withSomeTerm (pure . render))
`catchError` \(SomeException e) ->
pure (ParseTreeFileGraph path lang mempty mempty [ParseError (show e)])
pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
where
path = T.pack (blobPath blob)
lang = blobLanguage blob
path = T.pack $ blobPath blob
lang = languageToApiLanguage $ blobLanguage blob
render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph
render t = let graph = renderTreeGraph t
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
in ParseTreeFileGraph path lang (vertexList graph) (fmap toEdge (edgeList graph)) mempty
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
data TermOutputFormat
= TermJSONTree

343
src/Semantic/API/Types.hs
View File

@ -1,343 +0,0 @@
{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields, LambdaCase #-}
module Semantic.API.Types
(
-- Parse APIs
ParseTreeRequest(..)
, Blob(..)
, BlobPair(..)
-- Symbols for jump-to-definition
, ParseTreeSymbolResponse(..)
, File(..)
, Symbol(..)
-- Diff APIs
, DiffTreeRequest(..)
-- TOC Summaries
, DiffTreeTOCResponse(..)
, TOCSummaryFile(..)
, TOCSummaryChange(..)
, TOCSummaryError(..)
, ChangeType(..)
-- Diff tree graphs
, DiffTreeGraphResponse(..)
, DiffTreeFileGraph(..)
, DiffTreeEdge(..)
, DiffTreeVertex(..)
, DiffTreeTerm(..)
, DeletedTerm(..)
, InsertedTerm(..)
, ReplacedTerm(..)
, MergedTerm(..)
-- Parse tree graphs
, ParseTreeGraphResponse(..)
, ParseTreeFileGraph(..)
, TermVertex(..)
, TermEdge(..)
, ParseError(..)
-- Health Check
, PingRequest(..)
, PingResponse(..)
-- Common Types
, Span(..)
, Position(..)
-- Mime Types
, Protobuf
) where
import Data.Aeson
import Data.Bifunctor (first)
import Data.ByteString.Lazy.Char8 as BC
import Data.Char (toUpper)
import Data.Graph (VertexTag (..))
import Data.Language
import Data.String
import qualified Data.Text as T
import GHC.Generics
import Network.HTTP.Media ((//))
import Prologue
import Proto3.Suite as Proto3
import Servant.API
-- These types represent the public API of semantic and are used to generate
-- `proto/semantic.proto`.
--
-- Some guidelines:
--
-- * Don't write Message, Named, ToJSON, or FromJSON instances by hand, derive
-- them.
--
-- * For non-primitive types, you'll always want to use Maybe as protobuf
-- fields are always optional.
--
-- * It's usually best to map internal types to these API types so that the
-- API contract can be changed intentionally. This also makes it so that core
-- functionality doesn't have to deal with all the Maybes.
--
-- * Keep field names short and meaningful for external consumers. It's better
-- to skirt Haskell naming conventions in favor of consistency in our proto
-- files.
--
-- Parse/Term APIs
--
newtype ParseTreeRequest = ParseTreeRequest { blobs :: [Blob] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, FromJSON)
data Blob
= Blob
{ content :: T.Text
, path :: FilePath
, language :: Language
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, FromJSON)
data BlobPair
= BlobPair
{ before :: Maybe Blob
, after :: Maybe Blob
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, FromJSON)
--
-- Symbols API
--
newtype ParseTreeSymbolResponse = ParseTreeSymbolResponse { files :: [File] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data File
= File
{ path :: T.Text
, language :: Language
, symbols :: [Symbol]
, errors :: [ParseError]
}
deriving stock (Generic, Eq, Show)
deriving anyclass (Named, Message, ToJSON)
data Symbol
= Symbol
{ symbol :: T.Text
, kind :: T.Text
, line :: T.Text
, span :: Maybe Span
}
deriving stock (Generic, Eq, Show)
deriving anyclass (Named, Message, ToJSON)
--
-- Term Graph API
--
newtype ParseTreeGraphResponse = ParseTreeGraphResponse { files :: [ParseTreeFileGraph] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data ParseTreeFileGraph
= ParseTreeFileGraph
{ path :: T.Text
, language :: Language
, vertices :: [TermVertex]
, edges :: [TermEdge]
, errors :: [ParseError]
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data TermEdge = TermEdge { source :: Int, target :: Int }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data TermVertex = TermVertex { vertexId :: Int, term :: String, span :: Maybe Span }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
instance VertexTag TermVertex where uniqueTag = vertexId
newtype ParseError = ParseError { error :: String }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
--
-- Diff APIs
--
newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, FromJSON)
--
-- TOC Summaries API
--
newtype DiffTreeTOCResponse = DiffTreeTOCResponse { files :: [TOCSummaryFile] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data TOCSummaryFile = TOCSummaryFile
{ path :: T.Text
, language :: Language
, changes :: [TOCSummaryChange]
, errors :: [TOCSummaryError]
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data TOCSummaryChange = TOCSummaryChange
{ category :: T.Text
, term :: T.Text
, span :: Maybe Span
, changeType :: ChangeType
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data ChangeType
= None
| Added
| Removed
| Modified
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass (Named, MessageField, ToJSON)
instance HasDefault ChangeType where def = None
instance Finite ChangeType where
enumerate _ = fmap go [None ..] where
go x = (fromString (fmap toUpper (show x)), fromEnum x)
instance Primitive ChangeType where
primType _ = primType (Proxy @(Enumerated ChangeType))
encodePrimitive f = encodePrimitive f . Enumerated . Right
decodePrimitive = decodePrimitive >>= \case
(Enumerated (Right r)) -> pure r
other -> Prelude.fail ("ChangeType decodeMessageField: unexpected value" <> show other)
data TOCSummaryError = TOCSummaryError
{ error :: T.Text
, span :: Maybe Span
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
--
-- Diff Tree Graph API
--
newtype DiffTreeGraphResponse = DiffTreeGraphResponse { files :: [DiffTreeFileGraph] }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data DiffTreeFileGraph
= DiffTreeFileGraph
{ path :: T.Text
, language :: Language
, vertices :: [DiffTreeVertex]
, edges :: [DiffTreeEdge]
, errors :: [ParseError]
}
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data DiffTreeEdge = DiffTreeEdge { source :: Int, target :: Int }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data DiffTreeVertex = DiffTreeVertex { diffVertexId :: Int, diffTerm :: Maybe DiffTreeTerm }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
instance VertexTag DiffTreeVertex where uniqueTag = diffVertexId
-- NB: Current proto generation only supports sum types with single named fields.
data DiffTreeTerm
= Deleted { deleted :: Maybe DeletedTerm }
| Inserted { inserted :: Maybe InsertedTerm }
| Replaced { replaced :: Maybe ReplacedTerm }
| Merged { merged :: Maybe MergedTerm }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data DeletedTerm = DeletedTerm { term :: String, span :: Maybe Span }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data InsertedTerm = InsertedTerm { term :: String, span :: Maybe Span }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data ReplacedTerm = ReplacedTerm { beforeTerm :: String, beforeSpan :: Maybe Span, afterTerm :: String, afterSpan :: Maybe Span }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data MergedTerm = MergedTerm { term :: String, beforeSpan :: Maybe Span, afterSpan :: Maybe Span }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
--
-- Health Check API
--
newtype PingRequest = PingRequest { service :: String }
deriving stock (Eq, Show, Generic)
deriving anyclass (Message, Named, FromJSON)
data PingResponse
= PingResponse
{ status :: String
, hostname :: String
, timestamp :: String
, sha :: String
}
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
instance MimeRender PlainText PingResponse where
mimeRender _ PingResponse{..} = BC.pack $
status <> " - " <> hostname <> " - " <> sha <> " - " <> timestamp <> "\n"
--
-- Common Types
--
data Position = Position
{ line :: Int
, column :: Int
}
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
data Span = Span
{ start :: Maybe Position
, end :: Maybe Position
}
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, ToJSON)
--
-- Custom Mime Types
--
-- Servant doesn't come with protobuf support out of the box, but it's
-- very easy to add this as a valid type for decoding and encoding: all
-- you have to do is map proto3-suite's encoding and decoding functions
-- to the MimeRender/MimeUnrender typeclasses.
data Protobuf
instance Accept Protobuf where
contentType _ = "application" // "protobuf"
instance Message a => MimeRender Protobuf a where
mimeRender _ = Proto3.toLazyByteString
instance Message a => MimeUnrender Protobuf a where
mimeUnrender _ = first show . Proto3.fromByteString . BC.toStrict

564
src/Semantic/API/V1/CodeAnalysisPB.hs Normal file
View File

@ -0,0 +1,564 @@
-- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT.
{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
module Semantic.Api.V1.CodeAnalysisPB where
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Int
import Data.Text (Text)
import Data.Vector (Vector)
import Data.Word
import GHC.Generics
import Proto3.Suite
import Proto3.Wire (at, oneof)
data PingRequest = PingRequest
{ service :: Text
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message PingRequest where
encodeMessage _ PingRequest{..} = mconcat
[ encodeMessageField 1 service
]
decodeMessage _ = PingRequest
<$> at decodeMessageField 1
dotProto = undefined
data PingResponse = PingResponse
{ status :: Text
, hostname :: Text
, timestamp :: Text
, sha :: Text
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message PingResponse where
encodeMessage _ PingResponse{..} = mconcat
[ encodeMessageField 1 status
, encodeMessageField 2 hostname
, encodeMessageField 3 timestamp
, encodeMessageField 4 sha
]
decodeMessage _ = PingResponse
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
<*> at decodeMessageField 4
dotProto = undefined
data ParseTreeRequest = ParseTreeRequest
{ blobs :: Vector Blob
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ParseTreeRequest where
encodeMessage _ ParseTreeRequest{..} = mconcat
[ encodeMessageField 1 (NestedVec blobs)
]
decodeMessage _ = ParseTreeRequest
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data ParseTreeSymbolResponse = ParseTreeSymbolResponse
{ files :: Vector File
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ParseTreeSymbolResponse where
encodeMessage _ ParseTreeSymbolResponse{..} = mconcat
[ encodeMessageField 1 (NestedVec files)
]
decodeMessage _ = ParseTreeSymbolResponse
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data ParseTreeGraphResponse = ParseTreeGraphResponse
{ files :: Vector ParseTreeFileGraph
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ParseTreeGraphResponse where
encodeMessage _ ParseTreeGraphResponse{..} = mconcat
[ encodeMessageField 1 (NestedVec files)
]
decodeMessage _ = ParseTreeGraphResponse
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data ParseTreeFileGraph = ParseTreeFileGraph
{ path :: Text
, language :: Language
, vertices :: Vector TermVertex
, edges :: Vector TermEdge
, errors :: Vector ParseError
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ParseTreeFileGraph where
encodeMessage _ ParseTreeFileGraph{..} = mconcat
[ encodeMessageField 1 path
, encodeMessageField 2 language
, encodeMessageField 3 (NestedVec vertices)
, encodeMessageField 4 (NestedVec edges)
, encodeMessageField 5 (NestedVec errors)
]
decodeMessage _ = ParseTreeFileGraph
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> (nestedvec <$> at decodeMessageField 3)
<*> (nestedvec <$> at decodeMessageField 4)
<*> (nestedvec <$> at decodeMessageField 5)
dotProto = undefined
data TermEdge = TermEdge
{ source :: Int64
, target :: Int64
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message TermEdge where
encodeMessage _ TermEdge{..} = mconcat
[ encodeMessageField 1 source
, encodeMessageField 2 target
]
decodeMessage _ = TermEdge
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data TermVertex = TermVertex
{ vertexId :: Int64
, term :: Text
, span :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message TermVertex where
encodeMessage _ TermVertex{..} = mconcat
[ encodeMessageField 1 vertexId
, encodeMessageField 2 term
, encodeMessageField 3 (Nested span)
]
decodeMessage _ = TermVertex
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
dotProto = undefined
data ParseError = ParseError
{ error :: Text
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ParseError where
encodeMessage _ ParseError{..} = mconcat
[ encodeMessageField 1 error
]
decodeMessage _ = ParseError
<$> at decodeMessageField 1
dotProto = undefined
data DiffTreeRequest = DiffTreeRequest
{ blobs :: Vector BlobPair
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeRequest where
encodeMessage _ DiffTreeRequest{..} = mconcat
[ encodeMessageField 1 (NestedVec blobs)
]
decodeMessage _ = DiffTreeRequest
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data DiffTreeTOCResponse = DiffTreeTOCResponse
{ files :: Vector TOCSummaryFile
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeTOCResponse where
encodeMessage _ DiffTreeTOCResponse{..} = mconcat
[ encodeMessageField 1 (NestedVec files)
]
decodeMessage _ = DiffTreeTOCResponse
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data TOCSummaryFile = TOCSummaryFile
{ path :: Text
, language :: Language
, changes :: Vector TOCSummaryChange
, errors :: Vector TOCSummaryError
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message TOCSummaryFile where
encodeMessage _ TOCSummaryFile{..} = mconcat
[ encodeMessageField 1 path
, encodeMessageField 2 language
, encodeMessageField 3 (NestedVec changes)
, encodeMessageField 4 (NestedVec errors)
]
decodeMessage _ = TOCSummaryFile
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> (nestedvec <$> at decodeMessageField 3)
<*> (nestedvec <$> at decodeMessageField 4)
dotProto = undefined
data TOCSummaryChange = TOCSummaryChange
{ category :: Text
, term :: Text
, span :: Maybe Span
, changeType :: ChangeType
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message TOCSummaryChange where
encodeMessage _ TOCSummaryChange{..} = mconcat
[ encodeMessageField 1 category
, encodeMessageField 2 term
, encodeMessageField 3 (Nested span)
, encodeMessageField 4 changeType
]
decodeMessage _ = TOCSummaryChange
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
<*> at decodeMessageField 4
dotProto = undefined
data TOCSummaryError = TOCSummaryError
{ error :: Text
, span :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message TOCSummaryError where
encodeMessage _ TOCSummaryError{..} = mconcat
[ encodeMessageField 1 error
, encodeMessageField 2 (Nested span)
]
decodeMessage _ = TOCSummaryError
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data DiffTreeGraphResponse = DiffTreeGraphResponse
{ files :: Vector DiffTreeFileGraph
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeGraphResponse where
encodeMessage _ DiffTreeGraphResponse{..} = mconcat
[ encodeMessageField 1 (NestedVec files)
]
decodeMessage _ = DiffTreeGraphResponse
<$> (nestedvec <$> at decodeMessageField 1)
dotProto = undefined
data DiffTreeFileGraph = DiffTreeFileGraph
{ path :: Text
, language :: Language
, vertices :: Vector DiffTreeVertex
, edges :: Vector DiffTreeEdge
, errors :: Vector ParseError
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeFileGraph where
encodeMessage _ DiffTreeFileGraph{..} = mconcat
[ encodeMessageField 1 path
, encodeMessageField 2 language
, encodeMessageField 3 (NestedVec vertices)
, encodeMessageField 4 (NestedVec edges)
, encodeMessageField 5 (NestedVec errors)
]
decodeMessage _ = DiffTreeFileGraph
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> (nestedvec <$> at decodeMessageField 3)
<*> (nestedvec <$> at decodeMessageField 4)
<*> (nestedvec <$> at decodeMessageField 5)
dotProto = undefined
data DiffTreeEdge = DiffTreeEdge
{ source :: Int64
, target :: Int64
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeEdge where
encodeMessage _ DiffTreeEdge{..} = mconcat
[ encodeMessageField 1 source
, encodeMessageField 2 target
]
decodeMessage _ = DiffTreeEdge
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data DiffTreeVertexDiffTerm
= Deleted { deleted :: Maybe DeletedTerm }
| Inserted { inserted :: Maybe InsertedTerm }
| Replaced { replaced :: Maybe ReplacedTerm }
| Merged { merged :: Maybe MergedTerm }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Message, Named, FromJSON, ToJSON)
data DiffTreeVertex = DiffTreeVertex
{ diffVertexId :: Int64
, diffTerm :: Maybe DiffTreeVertexDiffTerm
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DiffTreeVertex where
encodeMessage _ DiffTreeVertex{..} = mconcat
[ encodeMessageField 1 diffVertexId
, case diffTerm of
Nothing -> mempty
Just (Deleted deleted) -> encodeMessageField 2 deleted
Just (Inserted inserted) -> encodeMessageField 3 inserted
Just (Replaced replaced) -> encodeMessageField 4 replaced
Just (Merged merged) -> encodeMessageField 5 merged
]
decodeMessage _ = DiffTreeVertex
<$> at decodeMessageField 1
<*> oneof
Nothing
[ (2, Just . Deleted <$> decodeMessageField)
, (3, Just . Inserted <$> decodeMessageField)
, (4, Just . Replaced <$> decodeMessageField)
, (5, Just . Merged <$> decodeMessageField)
]
dotProto = undefined
data DeletedTerm = DeletedTerm
{ term :: Text
, span :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message DeletedTerm where
encodeMessage _ DeletedTerm{..} = mconcat
[ encodeMessageField 1 term
, encodeMessageField 2 (Nested span)
]
decodeMessage _ = DeletedTerm
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data InsertedTerm = InsertedTerm
{ term :: Text
, span :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message InsertedTerm where
encodeMessage _ InsertedTerm{..} = mconcat
[ encodeMessageField 1 term
, encodeMessageField 2 (Nested span)
]
decodeMessage _ = InsertedTerm
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data ReplacedTerm = ReplacedTerm
{ beforeTerm :: Text
, beforeSpan :: Maybe Span
, afterTerm :: Text
, afterSpan :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message ReplacedTerm where
encodeMessage _ ReplacedTerm{..} = mconcat
[ encodeMessageField 1 beforeTerm
, encodeMessageField 2 (Nested beforeSpan)
, encodeMessageField 3 afterTerm
, encodeMessageField 4 (Nested afterSpan)
]
decodeMessage _ = ReplacedTerm
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
<*> at decodeMessageField 4
dotProto = undefined
data MergedTerm = MergedTerm
{ term :: Text
, beforeSpan :: Maybe Span
, afterSpan :: Maybe Span
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message MergedTerm where
encodeMessage _ MergedTerm{..} = mconcat
[ encodeMessageField 1 term
, encodeMessageField 2 (Nested beforeSpan)
, encodeMessageField 3 (Nested afterSpan)
]
decodeMessage _ = MergedTerm
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
dotProto = undefined
data Blob = Blob
{ content :: Text
, path :: Text
, language :: Language
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message Blob where
encodeMessage _ Blob{..} = mconcat
[ encodeMessageField 1 content
, encodeMessageField 2 path
, encodeMessageField 3 language
]
decodeMessage _ = Blob
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
dotProto = undefined
data BlobPair = BlobPair
{ before :: Maybe Blob
, after :: Maybe Blob
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message BlobPair where
encodeMessage _ BlobPair{..} = mconcat
[ encodeMessageField 1 (Nested before)
, encodeMessageField 2 (Nested after)
]
decodeMessage _ = BlobPair
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data File = File
{ path :: Text
, language :: Language
, symbols :: Vector Symbol
, errors :: Vector ParseError
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message File where
encodeMessage _ File{..} = mconcat
[ encodeMessageField 1 path
, encodeMessageField 2 language
, encodeMessageField 3 (NestedVec symbols)
, encodeMessageField 4 (NestedVec errors)
]
decodeMessage _ = File
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> (nestedvec <$> at decodeMessageField 3)
<*> (nestedvec <$> at decodeMessageField 4)
dotProto = undefined
data Symbol = Symbol
{ symbol :: Text
, kind :: Text
, line :: Text
, span :: Maybe Span
, docs :: Maybe Docstring
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message Symbol where
encodeMessage _ Symbol{..} = mconcat
[ encodeMessageField 1 symbol
, encodeMessageField 2 kind
, encodeMessageField 3 line
, encodeMessageField 4 (Nested span)
, encodeMessageField 5 (Nested docs)
]
decodeMessage _ = Symbol
<$> at decodeMessageField 1
<*> at decodeMessageField 2
<*> at decodeMessageField 3
<*> at decodeMessageField 4
<*> at decodeMessageField 5
dotProto = undefined
data Docstring = Docstring
{ docstring :: Text
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message Docstring where
encodeMessage _ Docstring{..} = mconcat
[ encodeMessageField 1 docstring
]
decodeMessage _ = Docstring
<$> at decodeMessageField 1
dotProto = undefined
data Position = Position
{ line :: Int64
, column :: Int64
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message Position where
encodeMessage _ Position{..} = mconcat
[ encodeMessageField 1 line
, encodeMessageField 2 column
]
decodeMessage _ = Position
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data Span = Span
{ start :: Maybe Position
, end :: Maybe Position
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Named, FromJSON, ToJSON)
instance Message Span where
encodeMessage _ Span{..} = mconcat
[ encodeMessageField 1 (Nested start)
, encodeMessageField 2 (Nested end)
]
decodeMessage _ = Span
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined
data ChangeType
= None
| Added
| Removed
| Modified
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass (Named, MessageField, FromJSON, ToJSON)
deriving Primitive via PrimitiveEnum ChangeType
instance HasDefault ChangeType where def = None
data Language
= Unknown
| Go
| Haskell
| Java
| Javascript
| Json
| Jsx
| Markdown
| Python
| Ruby
| Typescript
| Php
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass (Named, MessageField, FromJSON, ToJSON)
deriving Primitive via PrimitiveEnum Language
instance HasDefault Language where def = Unknown

2
src/Semantic/Analysis.hs
View File

@ -73,7 +73,7 @@ evaluate lang runModule modules = do
let (scopeEdges, frameLinks) = case (parentScope, parentFrame) of
(Just parentScope, Just parentFrame) -> (Map.singleton Lexical [ parentScope ], Map.singleton Lexical (Map.singleton parentScope parentFrame))
_ -> mempty
scopeAddress <- if Prologue.null scopeEdges then newPreludeScope scopeEdges else newScope scopeEdges
scopeAddress <- newScope scopeEdges
frameAddress <- newFrame scopeAddress frameLinks
val <- runInModule scopeAddress frameAddress m
pure ((scopeAddress, frameAddress), val)

14
src/Semantic/CLI.hs
View File

@ -3,14 +3,14 @@ module Semantic.CLI (main) where
import Control.Exception as Exc (displayException)
import Data.File
import Data.Language (ensureLanguage, languageForFilePath)
import Data.Language (languageForFilePath)
import Data.List (intercalate, uncons)
import Data.List.Split (splitWhen)
import Data.Handle
import Data.Project
import Options.Applicative hiding (style)
import Prologue
import Semantic.API hiding (File)
import Semantic.Api hiding (File)
import qualified Semantic.AST as AST
import Semantic.Config
import qualified Semantic.Graph as Graph
@ -29,7 +29,7 @@ main = do
(options, task) <- customExecParser (prefs showHelpOnEmpty) arguments
config <- defaultConfig options
res <- withTelemetry config $ \ (TelemetryQueues logger statter _) ->
Task.runTask (Task.TaskSession config "-" logger statter) task
Task.runTask (Task.TaskSession config "-" False logger statter) task
either (die . displayException) pure res
-- | A parser for the application's command-line arguments.
@ -84,7 +84,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
pure $ Task.readBlobs filesOrStdin >>= renderer
tsParseCommand :: Mod CommandFields (Task.TaskEff Builder)
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Don't produce output, but show timing stats"))
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Generate raw tree-sitter parse trees for path(s)"))
where
tsParseArgumentsParser = do
format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)")
@ -126,9 +126,9 @@ filePathReader :: ReadM File
filePathReader = eitherReader parseFilePath
where
parseFilePath arg = case splitWhen (== ':') arg of
[a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang)
| Just lang <- readMaybe a >>= ensureLanguage -> Right (File b lang)
[path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path))
[a, b] | Just lang <- readMaybe a -> Right (File a lang)
| Just lang <- readMaybe b -> Right (File b lang)
[path] -> Right (File path (languageForFilePath path))
args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
options :: Eq a => [(String, a)] -> Mod OptionFields a -> Parser a

80
src/Semantic/REPL.hs
View File

@ -54,45 +54,47 @@ instance Exception Quit
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)
homeDir <- liftIO getHomeDirectory
prefs <- liftIO (readPrefs (homeDir <> "/.haskeline"))
let settingsDir = homeDir <> "/.local/semantic"
liftIO $ createDirectoryIfMissing True settingsDir
let settings = Settings
{ complete = noCompletion
, historyFile = Just (settingsDir <> "/repl_history")
, autoAddHistory = True
}
runEvaluator
. runREPL prefs settings
. fmap snd
. runState ([] @Breakpoint)
. runReader Step
. runEvaluator
. id @(Evaluator _ Precise (Value _ Precise) _ _)
. raiseHandler runTraceByPrinting
. runHeap
. runScopeGraph
. raiseHandler runFresh
. fmap reassociate
. runLoadError
. runUnspecialized
. runScopeError
. runHeapError
. runEvalError
. runResolutionError
. runAddressError
. runValueError
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap moduleBody <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules
repl proxy parser paths =
withOptions debugOptions $ \config logger statter ->
runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader (TaskSession config "-" False logger statter) . Files.runFiles . runResolution . runTaskF $ do
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)
homeDir <- liftIO getHomeDirectory
prefs <- liftIO (readPrefs (homeDir <> "/.haskeline"))
let settingsDir = homeDir <> "/.local/semantic"
liftIO $ createDirectoryIfMissing True settingsDir
let settings = Settings
{ complete = noCompletion
, historyFile = Just (settingsDir <> "/repl_history")
, autoAddHistory = True
}
runEvaluator
. runREPL prefs settings
. fmap snd
. runState ([] @Breakpoint)
. runReader Step
. runEvaluator
. id @(Evaluator _ Precise (Value _ Precise) _ _)
. raiseHandler runTraceByPrinting
. runHeap
. runScopeGraph
. raiseHandler runFresh
. fmap reassociate
. runLoadError
. runUnspecialized
. runScopeError
. runHeapError
. runEvalError
. runResolutionError
. runAddressError
. runValueError
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap moduleBody <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules
-- TODO: REPL for typechecking/abstract semantics
-- TODO: drive the flow from within the REPL instead of from without

53
src/Semantic/Task.hs
View File

@ -98,7 +98,7 @@ type TaskEff
= Eff (TaskC
( Eff (ResolutionC
( Eff (Files.FilesC
( Eff (ReaderC Config
( Eff (ReaderC TaskSession
( Eff (TraceInTelemetryC
( Eff (TelemetryC
( Eff (ErrorC SomeException
@ -154,13 +154,14 @@ data TaskSession
= TaskSession
{ config :: Config
, requestID :: String
, isPublic :: Bool
, logger :: LogQueue
, statter :: StatQueue
}
-- | Execute a 'TaskEff' yielding its result value in 'IO'.
runTask :: TaskSession -> TaskEff a -> IO (Either SomeException a)
runTask TaskSession{..} task = do
runTask taskSession@TaskSession{..} task = do
(result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a)
run
@ -171,7 +172,7 @@ runTask TaskSession{..} task = do
. runError
. runTelemetry logger statter
. runTraceInTelemetry
. runReader config
. runReader taskSession
. Files.runFiles
. runResolution
. runTaskF
@ -182,7 +183,7 @@ runTask TaskSession{..} task = do
-- | Execute a 'TaskEff' yielding its result value in 'IO' using all default options and configuration.
runTaskWithOptions :: Options -> TaskEff a -> IO (Either SomeException a)
runTaskWithOptions options task = withOptions options $ \ config logger statter ->
runTask (TaskSession config "-" logger statter) task
runTask (TaskSession config "-" False logger statter) task
-- | Yield config and telemetry queues for options.
withOptions :: Options -> (Config -> LogQueue -> StatQueue -> IO a) -> IO a
@ -229,7 +230,7 @@ instance Effect Task where
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: ( Member (Error SomeException) sig
, Member (Lift IO) sig
, Member (Reader Config) sig
, Member (Reader TaskSession) sig
, Member Resource sig
, Member Telemetry sig
, Member Timeout sig
@ -243,7 +244,7 @@ runTaskF = runTaskC . interpret
newtype TaskC m a = TaskC { runTaskC :: m a }
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
ret = TaskC . ret
eff = TaskC . handleSum (eff . handleCoercible) (\case
Parse parser blob k -> runParser blob parser >>= runTaskC . k
@ -252,19 +253,22 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader
Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
Render renderer input k -> runTaskC (k (renderer input))
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal)
formatStyle <- asks (bool Plain Colourful . configIsTerminal . config)
runTaskC (k (runSerialize formatStyle format input)))
-- | Log an 'Error.Error' at the specified 'Level'.
logError :: (Member Telemetry sig, Carrier sig m)
=> Config
=> TaskSession
-> Level
-> Blob
-> Error.Error String
-> [(String, String)]
-> m ()
logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err)
logError TaskSession{..} level blob err =
let configLogPrintSource' = configLogPrintSource config
configIsTerminal' = configIsTerminal config
in writeLog level (Error.formatError configLogPrintSource' configIsTerminal' blob err)
data ParserCancelled = ParserTimedOut | AssignmentTimedOut
deriving (Show, Typeable)
@ -272,14 +276,14 @@ data ParserCancelled = ParserTimedOut | AssignmentTimedOut
instance Exception ParserCancelled
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m)
runParser :: (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m)
=> Blob
-> Parser term
-> m term
runParser blob@Blob{..} parser = case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- ask
config <- asks config
parseToAST (configTreeSitterParseTimeout config) language blob
>>= maybeM (throwError (SomeException ParserTimedOut))
@ -301,7 +305,7 @@ runParser blob@Blob{..} parser = case parser of
, Element Syntax.Error syntaxes
, Member (Error SomeException) sig
, Member (Lift IO) sig
, Member (Reader Config) sig
, Member (Reader TaskSession) sig
, Member Resource sig
, Member Telemetry sig
, Member Timeout sig
@ -314,34 +318,37 @@ runParser blob@Blob{..} parser = case parser of
-> assignment (Term (Sum syntaxes) Assignment.Location)
-> m (Term (Sum syntaxes) Assignment.Location)
runAssignment assign parser assignment = do
config <- ask
let blobFields = ("path", if configLogPrintSource config then blobPath else "<filtered>") : languageTag
taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession)
let isPublic' = ("github_is_public", show (isPublic taskSession))
let blobFields = ("path", if isPublic taskSession || configLogPrintSource (config taskSession) then blobPath else "<filtered>")
let logFields = requestID' : isPublic' : blobFields : languageTag
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
writeLog Error "failed parsing" (("task", "parse") : logFields)
throwError (toException err)
res <- timeout (configAssignmentTimeout config) . time "parse.assign" languageTag $
res <- timeout (configAssignmentTimeout (config taskSession)) . time "parse.assign" languageTag $
case assign blobSource assignment ast of
Left err -> do
writeStat (increment "parse.assign_errors" languageTag)
logError config Error blob err (("task", "assign") : blobFields)
logError taskSession Error blob err (("task", "assign") : logFields)
throwError (toException err)
Right term -> do
for_ (zip (errors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of
Just "ParseError" -> do
when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag)
logError config Warning blob err (("task", "parse") : blobFields)
when (optionsFailOnParseError (configOptions config)) $ throwError (toException err)
logError taskSession Warning blob err (("task", "parse") : logFields)
when (optionsFailOnParseError (configOptions (config taskSession))) $ throwError (toException err)
_ -> do
when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
logError taskSession Warning blob err (("task", "assign") : logFields)
when (optionsFailOnWarning (configOptions (config taskSession))) $ throwError (toException err)
term <$ writeStat (count "parse.nodes" (length term) languageTag)
case res of
Just r | not (configFailParsingForTesting config)
Just r | not (configFailParsingForTesting (config taskSession))
-> pure r
_ -> do
writeStat (increment "assign.assign_timeouts" languageTag)
writeLog Error "assignment timeout" (("task", "assign") : blobFields)
writeLog Error "assignment timeout" (("task", "assign") : logFields)
throwError (SomeException AssignmentTimedOut)

5
src/Semantic/Util.hs
View File

@ -27,6 +27,7 @@ import Data.Graph.ControlFlowVertex
import qualified Data.Language as Language
import Data.List (uncons)
import Data.Project hiding (readFile)
import Data.Quieterm (Quieterm, quieterm)
import Data.Sum (weaken)
import Data.Term
import qualified Language.Go.Assignment
@ -44,7 +45,6 @@ import System.Exit (die)
import System.FilePath.Posix (takeDirectory)
import Data.Location
import Data.Quieterm
-- The type signatures in these functions are pretty gnarly, but these functions
-- are hit sufficiently often in the CLI and test suite so as to merit avoiding
@ -583,7 +583,7 @@ type LanguageSyntax lang syntax = ( Language.SLanguage lang
, Apply FreeVariables1 syntax)
evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger statter ->
evaluateProject' (TaskSession config "-" logger statter) proxy parser paths
evaluateProject' (TaskSession config "-" False logger statter) proxy parser paths
-- Evaluate a project consisting of the listed paths.
-- TODO: This is used by our specs and should be moved into SpecHelpers.hs
@ -663,7 +663,6 @@ 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
, LanguageSyntax lang syntax

1
src/Tags/Taggable.hs
View File

@ -496,7 +496,6 @@ instance Taggable Java.TryWithResources
instance Taggable Java.AssertStatement
instance Taggable Java.AnnotationTypeElement
instance Taggable Python.Alias
instance Taggable Python.Ellipsis
instance Taggable Python.FutureImport
instance Taggable Python.Import

4
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -35,9 +35,9 @@ spec = parallel $ do
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
x = SpecHelpers.name "x"
associatedScope <- newScope lexicalEdges
declare (ScopeGraph.Declaration "identity") Default Public emptySpan ScopeGraph.Unknown (Just associatedScope)
declare (ScopeGraph.Declaration "identity") Default Public emptySpan (Just associatedScope)
withScope associatedScope $ do
declare (Declaration x) Default Public emptySpan ScopeGraph.Unknown Nothing
declare (Declaration x) Default Public emptySpan Nothing
identity <- function "identity" [ x ]
(SpecEff (Heap.lookupSlot (ScopeGraph.Declaration (SpecHelpers.name "x")) >>= deref)) associatedScope
val <- integer 123

4
test/Examples.hs
View File

@ -17,7 +17,7 @@ import Data.Quieterm
import Data.Typeable (cast)
import Data.Void
import Parsing.Parser
import Semantic.API (TermOutputFormat (..), parseTermBuilder)
import Semantic.Api (TermOutputFormat (..), parseTermBuilder)
import Semantic.Config (Config (..), Options (..), defaultOptions)
import qualified Semantic.IO as IO
import Semantic.Task
@ -32,7 +32,7 @@ import Test.Hspec
main :: IO ()
main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
let args = TaskSession config "-" logger statter
let args = TaskSession config "-" False logger statter
runIO setupExampleRepos

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

@ -24,7 +24,7 @@ import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Rendering.TOC
import Semantic.Config
import Semantic.API (diffSummaryBuilder)
import Semantic.Api (diffSummaryBuilder)
import Serializing.Format as Format
import SpecHelpers

2
test/Semantic/CLI/Spec.hs
View File

@ -4,7 +4,7 @@ import Control.Monad (when)
import qualified Data.ByteString as B
import Data.ByteString.Builder
import Data.Foldable (for_)
import Semantic.API hiding (File, Blob, BlobPair)
import Semantic.Api hiding (File, Blob, BlobPair)
import Semantic.CLI
import Semantic.IO
import Semantic.Task

2
test/Semantic/Spec.hs
View File

@ -2,7 +2,7 @@ module Semantic.Spec (spec) where
import Data.Diff
import Data.Patch
import Semantic.API hiding (Blob)
import Semantic.Api hiding (Blob)
import System.Exit
import SpecHelpers

2
test/Spec.hs
View File

@ -40,7 +40,7 @@ import Test.Hspec
main :: IO ()
main = do
withOptions defaultOptions { optionsLogLevel = Nothing } $ \ config logger statter -> hspec $ do
let args = TaskSession config "-" logger statter
let args = TaskSession config "-" False logger statter
describe "Semantic.Stat" Semantic.Stat.Spec.spec
parallel $ do
describe "Analysis.Go" (Analysis.Go.Spec.spec args)

6
test/SpecHelpers.hs
View File

@ -51,7 +51,7 @@ import Data.List.NonEmpty as X (NonEmpty(..))
import Data.Range as X
import Data.Semilattice.Lower as X
import Data.Source as X
import Data.Span as X hiding (start, end)
import Data.Span as X hiding (HasSpan(..))
import Data.String
import Data.Sum
import Data.Term as X
@ -82,7 +82,7 @@ import Data.Set (Set)
import qualified Semantic.IO as IO
import Semantic.Config (Config(..), optionsLogLevel)
import Semantic.Telemetry (LogQueue, StatQueue)
import Semantic.API hiding (File, Blob, BlobPair)
import Semantic.Api hiding (File, Blob, BlobPair)
import System.Exit (die)
import Control.Exception (displayException)
@ -112,7 +112,7 @@ parseTestFile parser path = runTaskOrDie $ do
term <- parse parser blob
pure (blob, term)
-- Run a Task and call `die` if it returns an Exception.
-- Run a Task and call `die` if it returns an Exception.
runTaskOrDie :: TaskEff a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure