github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 09:55:52 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into explicit-integer-parser

Browse Source
This commit is contained in:
Josh Vera 2018-06-26 17:10:21 -04:00 committed by GitHub
commit 5538c6b490
38 changed files with 1160 additions and 527 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
proto/code_analysis.proto
View File

@ -1,6 +1,10 @@
syntax = "proto3";
import "types.proto";
package github.semantic.v1alpha1;
import "error_details.proto";
option java_package = "com.github.semantic.analysis";
option go_package = "github.com/semantic/analysis/;analysis";
package github.semantic;
// Semantic's CodeAnalysis service provides endpoints for parsing, analyzing, and
// comparing source code.
@ -8,7 +12,7 @@ service CodeAnalysis {
// Parsing
//
// Parse source code blobs and return abstract syntax trees.
rpc Parse (ParseTreeRequest) returns (ParseTreeResponse);
rpc ParseTree(ParseTreeRequest) returns (ParseTreeResponse);
// Diffing
//
@ -20,7 +24,8 @@ service CodeAnalysis {
// Analyzing
//
// Calculate an import graph for a project.
// rpc GraphImports (ImportGraphRequest) returns (ImportGraphResponse);
rpc GraphImports (ImportGraphRequest) returns (ImportGraphResponse);
// rpc GraphCalls (CallGraphRequest) returns (CallGraphResponse);
// Check health & status of the service.
@ -45,6 +50,15 @@ message SummarizeDiffResponse {
repeated ParseError errors = 2;
}
message ImportGraphRequest {
Project project = 1;
}
message ImportGraphResponse {
ImportGraph graph = 1;
DebugInfo error_info = 2;
}
message BlobPair {
Blob before = 1;
Blob after = 2;

203
proto/error_details.proto Normal file
View File

@ -0,0 +1,203 @@
// Copyright 2017 Google Inc.
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
syntax = "proto3";
package google.rpc;
// import "google/protobuf/duration.proto";
option go_package = "google.golang.org/genproto/googleapis/rpc/errdetails;errdetails";
option java_multiple_files = true;
option java_outer_classname = "ErrorDetailsProto";
option java_package = "com.google.rpc";
option objc_class_prefix = "RPC";
// Describes when the clients can retry a failed request. Clients could ignore
// the recommendation here or retry when this information is missing from error
// responses.
//
// It's always recommended that clients should use exponential backoff when
// retrying.
//
// Clients should wait until `retry_delay` amount of time has passed since
// receiving the error response before retrying. If retrying requests also
// fail, clients should use an exponential backoff scheme to gradually increase
// the delay between retries based on `retry_delay`, until either a maximum
// number of retries have been reached or a maximum retry delay cap has been
// reached.
// Commented out for the semantic code API for the time being
// message RetryInfo {
// // Clients should wait at least this long between retrying the same request.
// google.protobuf.Duration retry_delay = 1;
// }
// Describes additional debugging info.
message DebugInfo {
// The stack trace entries indicating where the error occurred.
repeated string stack_entries = 1;
// Additional debugging information provided by the server.
string detail = 2;
}
// Describes how a quota check failed.
//
// For example if a daily limit was exceeded for the calling project,
// a service could respond with a QuotaFailure detail containing the project
// id and the description of the quota limit that was exceeded. If the
// calling project hasn't enabled the service in the developer console, then
// a service could respond with the project id and set `service_disabled`
// to true.
//
// Also see RetryDetail and Help types for other details about handling a
// quota failure.
message QuotaFailure {
// A message type used to describe a single quota violation. For example, a
// daily quota or a custom quota that was exceeded.
message Violation {
// The subject on which the quota check failed.
// For example, "clientip:<ip address of client>" or "project:<Google
// developer project id>".
string subject = 1;
// A description of how the quota check failed. Clients can use this
// description to find more about the quota configuration in the service's
// public documentation, or find the relevant quota limit to adjust through
// developer console.
//
// For example: "Service disabled" or "Daily Limit for read operations
// exceeded".
string description = 2;
}
// Describes all quota violations.
repeated Violation violations = 1;
}
// Describes what preconditions have failed.
//
// For example, if an RPC failed because it required the Terms of Service to be
// acknowledged, it could list the terms of service violation in the
// PreconditionFailure message.
message PreconditionFailure {
// A message type used to describe a single precondition failure.
message Violation {
// The type of PreconditionFailure. We recommend using a service-specific
// enum type to define the supported precondition violation types. For
// example, "TOS" for "Terms of Service violation".
string type = 1;
// The subject, relative to the type, that failed.
// For example, "google.com/cloud" relative to the "TOS" type would
// indicate which terms of service is being referenced.
string subject = 2;
// A description of how the precondition failed. Developers can use this
// description to understand how to fix the failure.
//
// For example: "Terms of service not accepted".
string description = 3;
}
// Describes all precondition violations.
repeated Violation violations = 1;
}
// Describes violations in a client request. This error type focuses on the
// syntactic aspects of the request.
message BadRequest {
// A message type used to describe a single bad request field.
message FieldViolation {
// A path leading to a field in the request body. The value will be a
// sequence of dot-separated identifiers that identify a protocol buffer
// field. E.g., "field_violations.field" would identify this field.
string field = 1;
// A description of why the request element is bad.
string description = 2;
}
// Describes all violations in a client request.
repeated FieldViolation field_violations = 1;
}
// Contains metadata about the request that clients can attach when filing a bug
// or providing other forms of feedback.
message RequestInfo {
// An opaque string that should only be interpreted by the service generating
// it. For example, it can be used to identify requests in the service's logs.
string request_id = 1;
// Any data that was used to serve this request. For example, an encrypted
// stack trace that can be sent back to the service provider for debugging.
string serving_data = 2;
}
// Describes the resource that is being accessed.
message ResourceInfo {
// A name for the type of resource being accessed, e.g. "sql table",
// "cloud storage bucket", "file", "Google calendar"; or the type URL
// of the resource: e.g. "type.googleapis.com/google.pubsub.v1.Topic".
string resource_type = 1;
// The name of the resource being accessed. For example, a shared calendar
// name: "example.com_4fghdhgsrgh@group.calendar.google.com", if the current
// error is [google.rpc.Code.PERMISSION_DENIED][google.rpc.Code.PERMISSION_DENIED].
string resource_name = 2;
// The owner of the resource (optional).
// For example, "user:<owner email>" or "project:<Google developer project
// id>".
string owner = 3;
// Describes what error is encountered when accessing this resource.
// For example, updating a cloud project may require the `writer` permission
// on the developer console project.
string description = 4;
}
// Provides links to documentation or for performing an out of band action.
//
// For example, if a quota check failed with an error indicating the calling
// project hasn't enabled the accessed service, this can contain a URL pointing
// directly to the right place in the developer console to flip the bit.
message Help {
// Describes a URL link.
message Link {
// Describes what the link offers.
string description = 1;
// The URL of the link.
string url = 2;
}
// URL(s) pointing to additional information on handling the current error.
repeated Link links = 1;
}
// Provides a localized error message that is safe to return to the user
// which can be attached to an RPC error.
message LocalizedMessage {
// The locale used following the specification defined at
// http://www.rfc-editor.org/rfc/bcp/bcp47.txt.
// Examples are: "en-US", "fr-CH", "es-MX"
string locale = 1;
// The localized error message in the above locale.
string message = 2;
}

38
proto/types.proto
View File

@ -1,17 +1,20 @@
syntax = "proto3";
package github.semantic.v1alpha1;
enum Language {Unknown = 0;
Go = 1;
Haskell = 2;
Java = 3;
JavaScript = 4;
package github.semantic;
enum Language {UNKNOWN = 0;
GO = 1;
HASKELL = 2;
JAVA = 3;
JAVASCRIPT = 4;
JSON = 5;
JSX = 6;
Markdown = 7;
Python = 8;
Ruby = 9;
TypeScript = 10;
MARKDOWN = 7;
PYTHON = 8;
RUBY = 9;
TYPESCRIPT = 10;
PHP = 11;}
enum VertexType {PACKAGE = 0;
MODULE = 1;
VARIABLE = 2;}
message Blob { bytes blobSource = 1;
string blobPath = 2;
Language blobLanguage = 3;
@ -22,6 +25,21 @@ message Pos { int64 posLine = 1;
message Span { Pos spanStart = 1;
Pos spanEnd = 2;
}
message ImportGraph { repeated Vertex graphVertices = 1;
repeated Edge graphEdges = 2;
}
message Vertex { VertexType vertexType = 1;
string vertexContents = 2;
uint64 vertexTag = 3;
}
message Edge { uint64 edgeFrom = 1;
uint64 edgeTo = 2;
}
message Project { string projectRootDir = 1;
repeated Blob projectBlobs = 2;
Language projectLanguage = 3;
repeated string projectExcludeDirs = 4 [packed = false];
}
message Array { repeated Term arrayElements = 1;
}
message Boolean { bool booleanContent = 1;

4
semantic.cabal
View File

@ -22,7 +22,6 @@ library
Analysis.Abstract.Caching
, Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.Evaluating
, Analysis.Abstract.Graph
, Analysis.Abstract.Tracing
, Analysis.ConstructorName
@ -76,6 +75,8 @@ library
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Data.Graph
, Data.Graph.Adjacency.Import
, Data.Graph.Vertex
, Data.JSON.Fields
, Data.Language
, Data.Map.Monoidal
@ -220,6 +221,7 @@ library
, time
, unix
, unordered-containers
, vector
, proto3-suite
, proto3-wire
, haskell-tree-sitter

31
src/Analysis/Abstract/Evaluating.hs
View File

@ -1,31 +0,0 @@
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Evaluating
( EvaluatingState(..)
, evaluating
) where
import Control.Abstract
import Prologue
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
data EvaluatingState address value = EvaluatingState
{ heap :: Heap address (Cell address) value
, modules :: ModuleTable (Maybe (address, Environment address))
}
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
deriving instance (Ord (Cell address value), Ord address, Ord value) => Ord (EvaluatingState address value)
deriving instance (Show (Cell address value), Show address, Show value) => Show (EvaluatingState address value)
evaluating :: Evaluator address value
( Fresh
': State (Heap address (Cell address) value)
': State (ModuleTable (Maybe (address, Environment address)))
': effects) result
-> Evaluator address value effects (result, EvaluatingState address value)
evaluating
= fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules))
. runState lowerBound -- State (ModuleTable (Maybe (address, Environment address)))
. runState lowerBound -- State (Heap address (Cell address) value)
. runFresh 0

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

@ -2,6 +2,7 @@
module Analysis.Abstract.Graph
( Graph(..)
, Vertex(..)
, moduleVertex
, style
, appendGraph
, variableDefinition
@ -10,6 +11,7 @@ module Analysis.Abstract.Graph
, graphingTerms
, graphingPackages
, graphingModules
, graphingModuleInfo
, graphing
) where
@ -19,22 +21,14 @@ import Data.Abstract.Address
import Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..))
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo(..))
import Data.Aeson hiding (Result)
import Data.ByteString.Builder
import Data.Graph
import Data.Graph.Vertex
import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prologue hiding (packageName, project)
-- | A vertex of some specific type.
data Vertex
= Package { vertexName :: Text }
| Module { vertexName :: Text }
| Variable { vertexName :: Text }
deriving (Eq, Ord, Show)
import Prologue hiding (project)
style :: Style Vertex Builder
style = (defaultStyle (T.encodeUtf8Builder . vertexName))
@ -67,6 +61,7 @@ graphingTerms recur term@(In _ syntax) = do
_ -> pure ()
recur term
-- | Add vertices to the graph for evaluated modules and the packages containing them.
graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph Vertex)) effects
)
@ -74,26 +69,37 @@ graphingPackages :: ( Member (Reader PackageInfo) effects
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m
-- | Add vertices to the graph for evaluated modules and the packages containing them.
-- | Add vertices to the graph for imported modules.
graphingModules :: forall term address value effects a
. ( Member (Modules address value) effects
. ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph Vertex)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingModules recur m = interpose @(Modules address value) pure (\ m yield -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
_ -> send m >>= yield)
(recur m)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingModules recur m = do
appendGraph (vertex (moduleVertex (moduleInfo m)))
interpose @(Modules address) pure (\ m yield -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
_ -> send m >>= yield)
(recur m)
packageVertex :: PackageInfo -> Vertex
packageVertex = Package . formatName . packageName
moduleVertex :: ModuleInfo -> Vertex
moduleVertex = Module . T.pack . modulePath
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: forall term address value effects a
. ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph ModuleInfo)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
interpose @(Modules address) pure (\ eff yield -> case eff of
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield
_ -> send eff >>= yield)
(recur m)
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Effectful m
@ -129,21 +135,9 @@ variableDefinition name = do
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
appendGraph (vertex (Variable (formatName name)) `connect` graph)
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()
appendGraph :: (Effectful m, Member (State (Graph v)) effects) => Graph v -> m effects ()
appendGraph = modify' . (<>)
instance ToJSON Vertex where
toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
vertexToText :: Vertex -> Text
vertexToText = vertexName
vertexToType :: Vertex -> Text
vertexToType Package{} = "package"
vertexToType Module{} = "module"
vertexToType Variable{} = "variable"
graphing :: Effectful m => m (State (Graph Vertex) ': effects) result -> m effects (result, Graph Vertex)
graphing = runState mempty

115
src/Control/Abstract/Modules.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.Modules
( lookupModule
, resolve
@ -23,115 +23,88 @@ import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Language
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Set as Set
import Prologue
import System.FilePath.Posix (takeDirectory)
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (address, Environment address)))
-- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
lookupModule = sendModules . Lookup
-- | Resolve a list of module paths to a possible module table entry.
resolve :: forall address value effects . Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve @address @value
resolve :: Member (Modules address) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
listModulesInDir :: forall address value effects . Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List @address @value
listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List
-- | Require/import another module by name and return its environment and value.
--
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
require :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (address, Environment address)
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
load :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (address, Environment address)
load path = sendModules (Load path)
data Modules address value return where
Load :: ModulePath -> Modules address value (Maybe (address, Environment address))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (address, Environment address)))
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
List :: FilePath -> Modules address value [ModulePath]
data Modules address return where
Load :: ModulePath -> Modules address (address, Environment address)
Lookup :: ModulePath -> Modules address (Maybe (address, Environment address))
Resolve :: [FilePath] -> Modules address (Maybe ModulePath)
List :: FilePath -> Modules address [ModulePath]
sendModules :: Member (Modules address value) effects => Modules address value return -> Evaluator address value effects return
sendModules :: Member (Modules address) effects => Modules address return -> Evaluator address value effects return
sendModules = send
runModules :: forall term address value effects a
. ( Member (Resumable (LoadError address value)) effects
, Member (State (ModuleTable (Maybe (address, Environment address)))) effects
, Member Trace effects
runModules :: ( Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
, Member (Resumable (LoadError address)) effects
)
=> (Module term -> Evaluator address value (Modules address value ': effects) (address, Environment address))
-> Evaluator address value (Modules address value ': effects) a
-> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a
runModules evaluateModule = go
where go :: forall a . Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a
go = reinterpret (\ m -> case m of
Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name
where
evalAndCache x = do
let mPath = modulePath (moduleInfo x)
loading <- loadingModule mPath
if loading
then trace ("load (skip evaluating, circular load): " <> show mPath) $> Nothing
else do
_ <- cacheModule name Nothing
result <- trace ("load (evaluating): " <> show mPath) *> go (evaluateModule x) <* trace ("load done:" <> show mPath)
cacheModule name (Just result)
=> Set ModulePath
-> Evaluator address value (Modules address ': effects) a
-> Evaluator address value effects a
runModules paths = interpret $ \case
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (moduleNotFound name)
Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Resolve names -> pure (find (`Set.member` paths) names)
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
loadingModule path = isJust . ModuleTable.lookup path <$> getModuleTable
Lookup path -> ModuleTable.lookup path <$> get
Resolve names -> do
isMember <- flip ModuleTable.member <$> askModuleTable @term
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (address, Environment address)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => ModulePath -> Maybe (address, Environment address) -> Evaluator address value effects (Maybe (address, Environment address))
cacheModule path result = modify' (ModuleTable.insert path result) $> result
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module term)))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module term)))
askModuleTable = ask
askModuleTable :: Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
askModuleTable = get
newtype Merging m address value = Merging { runMerging :: m (Maybe (address, Environment address)) }
newtype Merging address = Merging { runMerging :: (address, Environment address) }
instance Applicative m => Semigroup (Merging m address value) where
Merging a <> Merging b = Merging (merge <$> a <*> b)
where merge a b = mergeJusts <$> a <*> b <|> a <|> b
mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2)
instance Applicative m => Monoid (Merging m address value) where
mappend = (<>)
mempty = Merging (pure Nothing)
instance Semigroup (Merging address) where
Merging (_, env1) <> Merging (addr, env2) = Merging (addr, mergeEnvs env1 env2)
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
data LoadError address value resume where
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (address, Environment address))
data LoadError address resume where
ModuleNotFound :: ModulePath -> LoadError address (address, Environment address)
deriving instance Eq (LoadError address value resume)
deriving instance Show (LoadError address value resume)
instance Show1 (LoadError address value) where
deriving instance Eq (LoadError address resume)
deriving instance Show (LoadError address resume)
instance Show1 (LoadError address) where
liftShowsPrec _ _ = showsPrec
instance Eq1 (LoadError address value) where
instance Eq1 (LoadError address) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
moduleNotFound :: forall address value effects . Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
moduleNotFound = throwResumable . ModuleNotFound @address @value
moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (address, Environment address)
moduleNotFound = throwResumable . ModuleNotFound
resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a
resumeLoadError :: Member (Resumable (LoadError address)) effects => Evaluator address value effects a -> (forall resume . LoadError address resume -> Evaluator address value effects resume) -> Evaluator address value effects a
resumeLoadError = catchResumable
runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address value) ': effects) a -> m address value effects (Either (SomeExc (LoadError address value)) a)
runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a)
runLoadError = runResumable
runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address value resume -> m address value effects resume) -> m address value (Resumable (LoadError address value) ': effects) a -> m address value effects a
runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address resume -> m address value effects resume) -> m address value (Resumable (LoadError address) ': effects) a -> m address value effects a
runLoadErrorWith = runResumableWith

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

@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, evaluatePackageWith
, evaluate
, traceResolve
-- * Preludes
, HasPrelude(..)
@ -17,7 +17,7 @@ module Data.Abstract.Evaluatable
, Cell
) where
import Control.Abstract
import Control.Abstract hiding (Load)
import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
@ -30,8 +30,8 @@ import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Package as Package
import Data.Abstract.Ref as X
import Data.Coerce
import Data.Language
import Data.Scientific (Scientific)
import Data.Semigroup.App
@ -49,7 +49,7 @@ class Show1 constr => Evaluatable constr where
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (LoopControl address) effects
, Member (Modules address value) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
@ -64,77 +64,58 @@ class Show1 constr => Evaluatable constr where
eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr ""))
-- | Evaluate a given package.
evaluatePackageWith :: forall proxy lang address term value inner inner' inner'' outer
. ( AbstractValue address value inner
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that?
, Addressable address inner'
, Declarations term
, Evaluatable (Base term)
, Foldable (Cell address)
, FreeVariables term
, HasPrelude lang
, Member Fresh outer
, Member (Resumable (AddressError address value)) outer
, Member (Resumable (EnvironmentError address)) outer
, Member (Resumable EvalError) outer
, Member (Resumable (LoadError address value)) outer
, Member (Resumable ResolutionError) outer
, Member (Resumable (Unspecialized value)) outer
, Member (State (Heap address (Cell address) value)) outer
, Member (State (ModuleTable (Maybe (address, Environment address)))) outer
, Member Trace outer
, Recursive term
, Reducer value (Cell address value)
, ValueRoots address value
, inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': inner')
, inner' ~ (Reader ModuleInfo ': inner'')
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
-> Package term
-> TermEvaluator term address value outer [(address, Environment address)]
evaluatePackageWith lang analyzeModule analyzeTerm package
= runReader (packageInfo package)
. runReader lowerBound
. runReader (packageModules (packageBody package))
. withPrelude package
$ \ preludeEnv
-> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv))
. traverse (uncurry (evaluateEntryPoint preludeEnv))
$ ModuleTable.toPairs (packageEntryPoints (packageBody package))
where
evalModule preludeEnv m
= runInModule preludeEnv (moduleInfo m)
. analyzeModule (subtermRef . moduleBody)
$ evalTerm <$> m
evalTerm term = Subterm term (TermEvaluator (address =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
evaluate :: ( AbstractValue address value inner
, Addressable address (Reader ModuleInfo ': effects)
, Declarations term
, Evaluatable (Base term)
, Foldable (Cell address)
, FreeVariables term
, HasPrelude lang
, Member Fresh effects
, Member (Modules address) effects
, Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (AddressError address value)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Recursive term
, Reducer value (Cell address value)
, ValueRoots address value
, inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': Reader ModuleInfo ': effects)
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
-> [Module term]
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
evaluate lang analyzeModule analyzeTerm modules = do
(_, preludeEnv) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
defineBuiltins
definePrelude lang
box unit
foldr (run preludeEnv) get modules
where run preludeEnv m rest = do
evaluated <- coerce
(runInModule preludeEnv (moduleInfo m))
(analyzeModule (subtermRef . moduleBody)
(evalTerm <$> m))
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
modify' (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| []))
rest
evalTerm term = Subterm term (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address)
runInModule preludeEnv info
= runReader info
. raiseHandler runAllocator
. raiseHandler (runEnv preludeEnv)
. raiseHandler runReturn
. raiseHandler runLoopControl
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (address, Environment address)
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
addr <- box unit -- TODO don't *always* allocate - use maybeM instead
(ptr, env) <- fromMaybe (addr, lowerBound) <$> require m
bindAll env
maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym
withPrelude :: Package term
-> (Environment address -> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a)
-> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a
withPrelude _ f = do
(_, preludeEnv) <- raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) . runInModule lowerBound moduleInfoFromCallStack . TermEvaluator $ do
defineBuiltins
definePrelude lang
box unit
f preludeEnv
. runAllocator
. runEnv preludeEnv
. runReturn
. runLoopControl
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()

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

@ -12,11 +12,11 @@ import GHC.Stack
import Prologue
import System.FilePath.Posix
data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
data Module body = Module { moduleInfo :: ModuleInfo, moduleBody :: body }
deriving (Eq, Foldable, Functor, Ord, Traversable)
instance Show (Module term) where
showsPrec _ Module{..} = shows moduleInfo
instance Show body => Show (Module body) where
showsPrec d Module{..} = showsBinaryWith showsPrec showsPrec "Module" d (modulePath moduleInfo) moduleBody
-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'.
@ -32,7 +32,10 @@ moduleForBlob rootDir Blob{..} = Module info
type ModulePath = FilePath
newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
deriving (Eq, Ord, Show)
deriving (Eq, Ord)
instance Show ModuleInfo where
showsPrec d = showsUnaryWith showsPrec "ModuleInfo" d . modulePath
moduleInfoFromSrcLoc :: SrcLoc -> ModuleInfo
moduleInfoFromSrcLoc = ModuleInfo . srcLocModule

4
src/Data/Abstract/ModuleTable.hs
View File

@ -5,6 +5,7 @@ module Data.Abstract.ModuleTable
, singleton
, lookup
, member
, modulePaths
, modulePathsInDir
, insert
, keys
@ -26,6 +27,9 @@ newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
singleton :: ModulePath -> a -> ModuleTable a
singleton name = ModuleTable . Map.singleton name
modulePaths :: ModuleTable a -> Set ModulePath
modulePaths = Map.keysSet . unModuleTable
modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath]
modulePathsInDir k = filter (\e -> k == takeDirectory e) . Map.keys . unModuleTable

21
src/Data/Abstract/Package.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE TupleSections #-}
module Data.Abstract.Package where
import Data.Abstract.Module
@ -12,30 +11,16 @@ type PackageName = Name
-- | Metadata for a package (name and version).
data PackageInfo = PackageInfo
{ packageName :: PackageName
, packageVersion :: Maybe Version
, packageResolutions :: Map.Map FilePath FilePath
}
deriving (Eq, Ord, Show)
newtype Version = Version { versionString :: String }
deriving (Eq, Ord, Show)
data PackageBody term = PackageBody
{ packageModules :: ModuleTable (NonEmpty (Module term))
, packageEntryPoints :: ModuleTable (Maybe Name)
}
deriving (Eq, Functor, Ord, Show)
-- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed.
data Package term = Package
{ packageInfo :: PackageInfo
, packageBody :: PackageBody term
, packageModules :: ModuleTable (NonEmpty (Module term))
}
deriving (Eq, Functor, Ord, Show)
fromModules :: PackageName -> Maybe Version -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term
fromModules name version entryPoints modules resolutions =
Package (PackageInfo name version resolutions) (PackageBody (ModuleTable.fromModules modules) entryPoints')
where
entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules
fromModules :: PackageName -> [Module term] -> Map.Map FilePath FilePath -> Package term
fromModules name modules resolutions = Package (PackageInfo name resolutions) (ModuleTable.fromModules modules)

75
src/Data/Graph.hs
View File

@ -1,32 +1,93 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
module Data.Graph
( Graph(..)
, Class.overlay
, Class.connect
, Class.vertex
, overlay
, connect
, vertex
, Lower(..)
, simplify
, topologicalSort
) where
import qualified Algebra.Graph as G
import qualified Algebra.Graph.AdjacencyMap as A
import Algebra.Graph.Class (connect, overlay, vertex)
import qualified Algebra.Graph.Class as Class
import Control.Monad.Effect
import Control.Monad.Effect.State
import Data.Aeson
import qualified Data.Set as Set
import Prologue
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph (G.Graph vertex)
deriving (Eq, Foldable, Functor, Class.Graph, Show, Class.ToGraph, Traversable)
newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
deriving (Alternative, Applicative, Eq, Foldable, Functor, Class.Graph, Monad, Show, Class.ToGraph, Traversable)
simplify :: Ord vertex => Graph vertex -> Graph vertex
simplify (Graph graph) = Graph (G.simplify graph)
-- | Sort a graph’s vertices topologically.
--
-- >>> topologicalSort (Class.path "ab")
-- "ba"
--
-- >>> topologicalSort (Class.path "abc")
-- "cba"
--
-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c')
-- "cba"
--
-- >>> topologicalSort (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c'))
-- "cba"
--
-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c'))
-- "cba"
--
-- >>> topologicalSort (Class.path "abd" <> Class.path "acd")
-- "dcba"
--
-- >>> topologicalSort (Class.path "aba")
-- "ab"
topologicalSort :: forall v . Ord v => Graph v -> [v]
topologicalSort = go . toAdjacencyMap . G.transpose . unGraph
where go :: A.AdjacencyMap v -> [v]
go graph
= visitedOrder . snd
. run
. runState (Visited lowerBound [])
. traverse_ visit
. A.vertexList
$ graph
where visit :: v -> Eff '[State (Visited v)] ()
visit v = do
isMarked <- Set.member v . visitedVertices <$> get
if isMarked then
pure ()
else do
modify' (extendVisited (Set.insert v))
traverse_ visit (Set.toList (A.postSet v graph))
modify' (extendOrder (v :))
data Visited v = Visited { visitedVertices :: !(Set v), visitedOrder :: [v] }
extendVisited :: (Set v -> Set v) -> Visited v -> Visited v
extendVisited f (Visited a b) = Visited (f a) b
extendOrder :: ([v] -> [v]) -> Visited v -> Visited v
extendOrder f (Visited a b) = Visited a (f b)
toAdjacencyMap :: Ord v => G.Graph v -> A.AdjacencyMap v
toAdjacencyMap = Class.toGraph
instance Lower (Graph vertex) where
lowerBound = Class.empty
instance Semigroup (Graph vertex) where
(<>) = Class.overlay
(<>) = overlay
instance Monoid (Graph vertex) where
mempty = Class.empty

157
src/Data/Graph/Adjacency/Import.hs Normal file
View File

@ -0,0 +1,157 @@
{-# LANGUAGE DeriveAnyClass, LambdaCase, TupleSections #-}
module Data.Graph.Adjacency.Import
( ImportGraph (..)
, Edge (..)
, Tag
, Vertex (..)
, VertexType (..)
, graphToImportGraph
, importGraphToGraph
, tagGraph
, isCoherent
) where
import Prologue
import Algebra.Graph.AdjacencyMap (adjacencyMap)
import Algebra.Graph.Class (ToGraph (..), edges, vertices)
import Control.Monad.Effect
import Control.Monad.Effect.Fresh
import Data.Aeson
import Data.Coerce
import Data.HashMap.Strict ((!))
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as Vec
import Data.Word
import GHC.Exts (fromList)
import qualified Proto3.Suite as PB
import Data.Graph
import qualified Data.Graph.Vertex as V
-- | Sum type corresponding to a protobuf enum for vertex types.
data VertexType
= PACKAGE
| MODULE
| VARIABLE
deriving (Eq, Ord, Show, Enum, Bounded, Generic, ToJSON, FromJSON, PB.Named, PB.Finite, PB.MessageField)
-- | Defaults to 'PACKAGE'.
instance PB.HasDefault VertexType where def = PACKAGE
-- | Piggybacks on top of the 'Enumerated' instance, as the generated code would.
-- This instance will get easier when we have DerivingVia, or a Generic instance
-- that hooks into Enumerated.
instance PB.Primitive VertexType where
primType _ = PB.primType (Proxy @(PB.Enumerated VertexType))
encodePrimitive f = PB.encodePrimitive f . PB.Enumerated . Right
decodePrimitive = PB.decodePrimitive >>= \case
(PB.Enumerated (Right r)) -> pure r
other -> Prelude.fail ("VertexType decodeMessageField: unexpected value" <> show other)
-- | A tag used on each vertext of a 'Graph' to convert to an 'ImportGraph'.
type Tag = Word64
-- | A protobuf-compatible vertex type, with a unique 'Tag' identifier.
data Vertex = Vertex
{ vertexType :: VertexType
, vertexContents :: Text
, vertexTag :: Tag
} deriving (Eq, Ord, Show, Generic, PB.Message, PB.Named)
-- | A protobuf-compatible edge type. Only tag information is carried;
-- consumers are expected to look up nodes in the vertex list when necessary.
data Edge = Edge { edgeFrom :: Tag, edgeTo :: Tag }
deriving (Eq, Ord, Show, Generic, Hashable, PB.Named, PB.Message)
-- | An adjacency list-representation of a graph. You generally build these by calling
-- 'graphToImportGraph' on an algebraic 'Graph'. This representation is less efficient and
-- fluent than an ordinary 'Graph', but is more amenable to serialization.
data ImportGraph = ImportGraph
{ graphVertices :: PB.NestedVec Vertex
, graphEdges :: PB.NestedVec Edge
} deriving (Eq, Ord, Show, Generic, PB.Named, PB.Message)
-- | Convert an algebraic graph to an adjacency list.
graphToImportGraph :: Graph V.Vertex -> ImportGraph
graphToImportGraph = taggedGraphToImportGraph . tagGraph
-- * Internal interface stuff
-- Using a PBGraph as the accumulator for the fold would incur
-- significant overhead associated with Vector concatenation.
-- We use this and then pay the O(v + e) to-Vector cost once.
-- The fields are strict because we have StrictData on.
data Acc = Acc [Vertex] (HashSet Edge)
-- Convert a graph with tagged members to a protobuf-compatible adjacency list.
-- The Tag is necessary to build a canonical adjacency list.
-- Since import graphs can be very large, this is written with speed in mind, in
-- that we convert the graph to algebraic-graphs's 'AdjacencyMap' and then fold
-- to build a 'Graph', avoiding inefficient vector concatenation.
-- Time complexity, given V vertices and E edges, is at least O(2V + 2E + (V * E * log E)),
-- plus whatever overhead converting the graph to 'AdjacencyMap' may entail.
taggedGraphToImportGraph :: Graph (V.Vertex, Tag) -> ImportGraph
taggedGraphToImportGraph = accumToAdj . adjMapToAccum . adjacencyMap . toGraph . simplify
where adjMapToAccum :: Map (V.Vertex, Tag) (Set (V.Vertex, Tag)) -> Acc
adjMapToAccum = Map.foldlWithKey go (Acc [] mempty)
go :: Acc -> (V.Vertex, Tag) -> Set (V.Vertex, Tag) -> Acc
go (Acc vs es) (v, from) edges = Acc (vertexToPB v from : vs) (Set.foldr' (add . snd) es edges)
where add = HashSet.insert . Edge from
accumToAdj :: Acc -> ImportGraph
accumToAdj (Acc vs es) = ImportGraph (fromList vs) (fromList (toList es))
vertexToPB :: V.Vertex -> Tag -> Vertex
vertexToPB s = Vertex t (V.vertexName s) where
t = case s of
V.Package{} -> PACKAGE
V.Module{} -> MODULE
V.Variable{} -> VARIABLE
-- Annotate all vertices of a 'Graph' with a 'Tag', starting from 1.
tagGraph :: Graph vertex -> Graph (vertex, Tag)
tagGraph = run . runFresh 1 . go where
go :: Graph vertex -> Eff '[Fresh] (Graph (vertex, Tag))
go = traverse (\v -> (v, ) . fromIntegral <$> fresh)
-- | This is the reverse of 'graphToImportGraph'. Don't use this outside of a testing context.
-- N.B. @importGraphToGraph . graphToImportGraph@ is 'id', but @graphToImportGraph . importGraphToGraph@ is not.
importGraphToGraph :: ImportGraph -> Graph V.Vertex
importGraphToGraph (ImportGraph vs es) = simplify built
where built = allEdges <> vertices unreferencedVertices
allEdges :: Graph V.Vertex
allEdges = fmap fst (edges (foldr addEdge [] es))
addEdge (Edge f t) xs = ((adjMap ! f, f), (adjMap ! t, t)) : xs
adjMap = foldMap (\v -> HashMap.singleton (vertexTag v) (pbToVertex v)) vs
unreferencedVertices :: [V.Vertex]
unreferencedVertices = pbToVertex <$> toList (Vec.filter isUnreferenced (coerce vs))
isUnreferenced :: Vertex -> Bool
isUnreferenced v = not (vertexTag v `HashSet.member` edgedTags)
edgedTags :: HashSet Tag
edgedTags = HashSet.fromList $ concatMap unEdge es where unEdge (Edge f t) = [f, t]
pbToVertex :: Vertex -> V.Vertex
pbToVertex (Vertex t c _) = case t of
MODULE -> V.Module c
PACKAGE -> V.Package c
VARIABLE -> V.Variable c
-- | For debugging: returns True if all edges reference a valid vertex tag.
isCoherent :: ImportGraph -> Bool
isCoherent (ImportGraph vs es) = all edgeValid es where
edgeValid (Edge a b) = HashSet.member a allTags && HashSet.member b allTags
allTags = HashSet.fromList (toList (vertexTag <$> vs))

37
src/Data/Graph/Vertex.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Graph.Vertex
( Vertex (..)
, moduleVertex
, packageVertex
, vertexToType
) where
import Prologue hiding (packageName)
import Data.Aeson
import qualified Data.Text as T
import Data.Abstract.Module (ModuleInfo (..))
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo (..))
-- | A vertex of some specific type.
data Vertex
= Package { vertexName :: Text }
| Module { vertexName :: Text }
| Variable { vertexName :: Text }
deriving (Eq, Ord, Show, Generic, Hashable)
packageVertex :: PackageInfo -> Vertex
packageVertex = Package . formatName . packageName
moduleVertex :: ModuleInfo -> Vertex
moduleVertex = Module . T.pack . modulePath
instance ToJSON Vertex where
toJSON v = object [ "name" .= vertexName v, "type" .= vertexToType v ]
vertexToType :: Vertex -> Text
vertexToType Package{} = "package"
vertexToType Module{} = "module"
vertexToType Variable{} = "variable"

9
src/Data/Language.hs
View File

@ -2,6 +2,8 @@
module Data.Language where
import Data.Aeson
import Data.Char (toUpper)
import Data.String
import qualified Data.Text as T
import Prologue
import Proto3.Suite
@ -23,7 +25,12 @@ data Language
| Ruby
| TypeScript
| PHP
deriving (Eq, Generic, Ord, Read, Show, Bounded, ToJSON, Named, Enum, Finite, MessageField)
deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Named, Enum, MessageField)
-- This ensures that the protobuf file is generated with ALL_CAPS_NAMES.
instance Finite Language where
enumerate _ = fmap go [Unknown ..] where
go x = (fromString (fmap toUpper (show x)), fromEnum x)
instance FromJSON Language where
parseJSON = withText "Language" $ \l -> pure $ case T.toLower l of

95
src/Data/Project.hs
View File

@ -1,18 +1,68 @@
module Data.Project where
{-# LANGUAGE DeriveAnyClass, KindSignatures, MultiWayIf #-}
import Data.Text as T (pack)
import Data.Language
import Prologue
import System.FilePath.Posix
module Data.Project (
-- * Projects
ProjectF (..)
, Project
, PBProject
, ProjectException (..)
, fromPB
, projectExtensions
, projectName
, projectFiles
, readFile
-- * Files
, File (..)
, file
) where
data Project = Project
{ projectRootDir :: FilePath
, projectFiles :: [File]
import Prelude hiding (readFile)
import Prologue hiding (throwError)
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Data.Blob
import Data.Language
import qualified Data.Text as T
import Proto3.Suite
import System.FilePath.Posix
-- | A 'ProjectF' contains all the information that semantic needs
-- to execute an analysis, diffing, or graphing pass. It is higher-kinded
-- in terms of the container type for paths and blobs, as well as the
-- path type (this is necessary because protobuf uses different vector
-- representations for @repeated string@ and @repeated Blob@.
-- You probably want to use the 'Project' or 'PB' type aliases.
data ProjectF (blobs :: * -> *) (paths :: * -> *) path = Project
{ projectRootDir :: path
, projectBlobs :: blobs Blob
, projectLanguage :: Language
, projectEntryPoints :: [File]
, projectExcludeDirs :: [FilePath]
, projectExcludeDirs :: paths path
} deriving (Functor, Generic)
deriving instance (Eq path, Eq (blobs Blob), Eq (paths path)) => Eq (ProjectF blobs paths path)
deriving instance (Show path, Show (blobs Blob), Show (paths path)) => Show (ProjectF blobs paths path)
-- | This 'Project' type is the one used during semantic's normal
-- course of diffing, evaluation, and graphing. You probably want to
-- use this one.
type Project = ProjectF [] [] FilePath
-- | This 'Project' type is protobuf-compatible, and corresponds with
-- the @Project@ message declaration present in types.proto.
type PBProject = ProjectF NestedVec UnpackedVec Text
deriving instance Message PBProject
instance Named PBProject where nameOf _ = "Project"
-- | Convert from a packed protobuf representation to a more useful one.
fromPB :: PBProject -> Project
fromPB Project {..} = Project
{ projectRootDir = T.unpack projectRootDir
, projectBlobs = toList projectBlobs
, projectLanguage = projectLanguage
, projectExcludeDirs = T.unpack <$> toList projectExcludeDirs
}
deriving (Eq, Ord, Show)
projectName :: Project -> Text
projectName = T.pack . dropExtensions . takeFileName . projectRootDir
@ -20,6 +70,8 @@ projectName = T.pack . dropExtensions . takeFileName . projectRootDir
projectExtensions :: Project -> [String]
projectExtensions = extensionsForLanguage . projectLanguage
projectFiles :: Project -> [File]
projectFiles = fmap toFile . projectBlobs
data File = File
{ filePath :: FilePath
@ -29,3 +81,24 @@ data File = File
file :: FilePath -> File
file path = File path (languageForFilePath path)
where languageForFilePath = languageForType . takeExtension
-- This is kind of a wart; Blob and File should be two views of
-- the same higher-kinded datatype.
toFile :: Blob -> File
toFile (Blob _ p l) = File p l
newtype ProjectException
= FileNotFound FilePath
deriving (Show, Eq, Typeable, Exception)
readFile :: Member (Exc SomeException) effs
=> Project
-> File
-> Eff effs (Maybe Blob)
readFile Project{..} f =
let p = filePath f
candidate = find (\b -> blobPath b == p) projectBlobs
in if
| p == "/dev/null" -> pure Nothing
| isJust candidate -> pure candidate
| otherwise -> throwError (SomeException (FileNotFound p))

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

@ -27,7 +27,7 @@ importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathT
defaultAlias :: ImportPath -> Name
defaultAlias = name . T.pack . takeFileName . unPath
resolveGoImport :: ( Member (Modules address value) effects
resolveGoImport :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Package.PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -66,7 +66,7 @@ instance Evaluatable Import where
paths <- resolveGoImport importPath
for_ paths $ \path -> do
traceResolve (unPath importPath) path
importedEnv <- maybe lowerBound snd <$> require path
importedEnv <- snd <$> require path
bindAll importedEnv
rvalBox unit
@ -88,7 +88,7 @@ instance Evaluatable QualifiedImport where
void . letrec' alias $ \addr -> do
for_ paths $ \p -> do
traceResolve (unPath importPath) p
importedEnv <- maybe lowerBound snd <$> require p
importedEnv <- snd <$> require p
bindAll importedEnv
makeNamespace alias addr Nothing
rvalBox unit

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

@ -35,7 +35,7 @@ instance Evaluatable VariableName
-- file, the complete contents of the included file are treated as though it
-- were defined inside that function.
resolvePHPName :: ( Member (Modules address value) effects
resolvePHPName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
)
=> T.Text
@ -49,20 +49,19 @@ resolvePHPName n = do
include :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError address)) effects
, Member Trace effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> (ModulePath -> Evaluator address value effects (Maybe (address, Environment address)))
-> (ModulePath -> Evaluator address value effects (address, Environment address))
-> Evaluator address value effects (ValueRef address)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
traceResolve name path
unitPtr <- box unit -- TODO don't always allocate, use maybeM
(v, importedEnv) <- fromMaybe (unitPtr, lowerBound) <$> f path
(v, importedEnv) <- f path
bindAll importedEnv
pure (Rval v)

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

@ -50,7 +50,7 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju
-- Subsequent imports of `parent.two` or `parent.three` will execute
-- `parent/two/__init__.py` and
-- `parent/three/__init__.py` respectively.
resolvePythonModules :: ( Member (Modules address value) effects
resolvePythonModules :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Resumable ResolutionError) effects
, Member Trace effects
@ -113,7 +113,7 @@ instance Evaluatable Import where
-- Last module path is the one we want to import
let path = NonEmpty.last modulePaths
importedEnv <- maybe lowerBound snd <$> require path
importedEnv <- snd <$> require path
bindAll (select importedEnv)
rvalBox unit
where
@ -126,11 +126,11 @@ instance Evaluatable Import where
evalQualifiedImport :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Modules address) effects
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do
importedEnv <- maybe lowerBound snd <$> require path
importedEnv <- snd <$> require path
bindAll importedEnv
unit <$ makeNamespace name addr Nothing
@ -174,7 +174,7 @@ instance Evaluatable QualifiedAliasedImport where
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
rvalBox =<< letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
importedEnv <- maybe lowerBound snd <$> require path
importedEnv <- snd <$> require path
bindAll importedEnv
unit <$ makeNamespace alias addr Nothing)

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

@ -16,7 +16,7 @@ import System.FilePath.Posix
-- TODO: Fully sort out ruby require/load mechanics
--
-- require "json"
resolveRubyName :: ( Member (Modules address value) effects
resolveRubyName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
)
=> Text
@ -28,7 +28,7 @@ resolveRubyName name = do
maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules address value) effects
resolveRubyPath :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
)
=> Text
@ -73,14 +73,14 @@ instance Evaluatable Require where
rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
doRequire :: ( AbstractValue address value effects
, Member (Modules address value) effects
, Member (Modules address) effects
)
=> M.ModulePath
-> Evaluator address value effects (value, Environment address)
doRequire path = do
result <- join <$> lookupModule path
result <- lookupModule path
case result of
Nothing -> (,) (boolean True) . maybe lowerBound snd <$> load path
Nothing -> (,) (boolean True) . snd <$> load path
Just (_, env) -> pure (boolean False, env)
@ -102,7 +102,7 @@ instance Evaluatable Load where
doLoad :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member Trace effects
)
@ -112,7 +112,7 @@ doLoad :: ( AbstractValue address value effects
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'
importedEnv <- maybe lowerBound snd <$> load path'
importedEnv <- snd <$> load path'
unless shouldWrap $ bindAll importedEnv
pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load

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

@ -35,7 +35,7 @@ toName = name . T.pack . unPath
--
-- NB: TypeScript has a couple of different strategies, but the main one (and the
-- only one we support) mimics Node.js.
resolveWithNodejsStrategy :: ( Member (Modules address value) effects
resolveWithNodejsStrategy :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -54,7 +54,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ
-- /root/src/moduleB.ts
-- /root/src/moduleB/package.json (if it specifies a "types" property)
-- /root/src/moduleB/index.ts
resolveRelativePath :: ( Member (Modules address value) effects
resolveRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -82,7 +82,7 @@ resolveRelativePath relImportPath exts = do
--
-- /root/node_modules/moduleB.ts, etc
-- /node_modules/moduleB.ts, etc
resolveNonRelativePath :: ( Member (Modules address value) effects
resolveNonRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -107,7 +107,7 @@ resolveNonRelativePath name exts = do
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
-- | Resolve a module name to a ModulePath.
resolveModule :: ( Member (Modules address value) effects
resolveModule :: ( Member (Modules address) effects
, Member (Reader PackageInfo) effects
, Member Trace effects
)
@ -133,13 +133,13 @@ javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Modules address) effects
)
=> M.ModulePath
-> Name
-> Evaluator address value effects value
evalRequire modulePath alias = letrec' alias $ \addr -> do
importedEnv <- maybe lowerBound snd <$> require modulePath
importedEnv <- snd <$> require modulePath
bindAll importedEnv
unit <$ makeNamespace alias addr Nothing
@ -154,7 +154,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where
eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe lowerBound snd <$> require modulePath
importedEnv <- snd <$> require modulePath
bindAll (renamed importedEnv)
rvalBox unit
where
@ -230,7 +230,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe lowerBound snd <$> require modulePath
importedEnv <- snd <$> require modulePath
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv

2
src/Rendering/Renderer.hs
View File

@ -52,8 +52,6 @@ data TermRenderer output where
SExpressionTermRenderer :: TermRenderer Builder
-- | Render to a list of symbols.
SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON)
-- | Render to a list of modules that represent the import graph.
ImportsTermRenderer :: TermRenderer ImportSummary
-- | Render to a 'ByteString' formatted as a DOT description of the term.
DOTTermRenderer :: TermRenderer (Graph (Vertex ()))
-- | Render to a 'ByteString' formatted using the 'Show' instance.

3
src/Semantic/CLI.hs
View File

@ -69,7 +69,6 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
<> help "Comma delimited list of specific fields to return (symbols output only)."
<> metavar "FIELDS")
<|> pure defaultSymbolFields)
<|> flag' (Parse.runParse ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph")
<|> flag' (Parse.runParse DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees")
<|> flag' (Parse.runParse ShowTermRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
@ -83,7 +82,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point"))
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module"))
graphArgumentsParser = do
graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph")

3
src/Semantic/Config.hs
View File

@ -44,6 +44,9 @@ data Options
defaultOptions :: Options
defaultOptions = Options (Just Warning) Nothing False
debugOptions :: Options
debugOptions = Options (Just Debug) Nothing False
defaultConfig :: Options -> IO Config
defaultConfig options@Options{..} = do
pid <- getProcessID

161
src/Semantic/Graph.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE GADTs, TypeOperators #-}
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
module Semantic.Graph
( runGraph
, runImportGraph
, GraphType(..)
, Graph
, Vertex
, GraphEff(..)
, ImportGraphEff(..)
, style
, parsePackage
, withTermSpans
@ -17,13 +19,15 @@ module Semantic.Graph
, resumingEnvironmentError
) where
import Analysis.Abstract.Evaluating
import Analysis.Abstract.Graph
import Prelude hiding (readFile)
import Analysis.Abstract.Graph as Graph
import Control.Abstract
import Control.Monad.Effect (reinterpret)
import Data.Abstract.Address
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package as Package
import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith)
import Data.Graph
@ -33,40 +37,48 @@ import Data.Term
import Data.Text (pack)
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Semantic.IO (Files)
import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph
runGraph :: ( Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Functor, Ord1, Show1 ]
runGraph :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
=> GraphType
-> Bool
-> Project
-> Eff effs (Graph Vertex)
runGraph graphType includePackages project
| SomeAnalysisParser parser lang <- someAnalysisParser
(Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
runGraph ImportGraph _ project
| SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
package <- parsePackage parser project
let analyzeTerm = withTermSpans . case graphType of
ImportGraph -> id
CallGraph -> graphingTerms
fmap (Graph.moduleVertex . moduleInfo) <$> runImportGraph lang package
runGraph CallGraph includePackages project
| SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
package <- parsePackage parser project
modules <- runImportGraph lang package
let analyzeTerm = withTermSpans . graphingTerms
analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
analyze runGraphAnalysis (evaluatePackageWith lang analyzeModule analyzeTerm package) >>= extractGraph
where extractGraph result = case result of
(((_, graph), _), _) -> pure (simplify graph)
runGraphAnalysis
= run
. evaluating
. runIgnoringTrace
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _))
. graphing
extractGraph (((_, graph), _), _) = simplify graph
runGraphAnalysis
= run
. runState lowerBound
. runFresh 0
. runIgnoringTrace
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _))
. graphing
. runReader (packageInfo package)
. runReader lowerBound
. fmap fst
. runState lowerBound
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules))
-- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids.
newtype GraphEff address a = GraphEff
@ -75,7 +87,9 @@ newtype GraphEff address a = GraphEff
, Env address
, Allocator address (Value address (GraphEff address))
, Reader ModuleInfo
, Modules address (Value address (GraphEff address))
, Modules address
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
, Reader Span
, Reader PackageInfo
, State (Graph Vertex)
@ -85,14 +99,80 @@ newtype GraphEff address a = GraphEff
, Resumable EvalError
, Resumable (EnvironmentError address)
, Resumable (Unspecialized (Value address (GraphEff address)))
, Resumable (LoadError address (Value address (GraphEff address)))
, Resumable (LoadError address)
, Trace
, Fresh
, State (Heap address Latest (Value address (GraphEff address)))
, State (ModuleTable (Maybe (address, Environment address)))
] a
}
runImportGraph :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, Member Task effs
, Member Trace effs
, Recursive term
)
=> Proxy lang
-> Package term
-> Eff effs (Graph (Module term))
runImportGraph lang (package :: Package term)
-- Optimization for the common (when debugging) case of one-and-only-one module.
| [m :| []] <- toList (packageModules package) = vertex m <$ trace ("single module, skipping import graph computation for " <> modulePath (moduleInfo m))
| otherwise =
let analyzeModule = graphingModuleInfo
extractGraph (((_, graph), _), _) = do
info <- graph
maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package))
runImportGraphAnalysis
= run
. runState lowerBound
. runFresh 0
. runIgnoringTrace
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runState lowerBound
. fmap fst
. runState lowerBound
. runModules (ModuleTable.modulePaths (packageModules package))
. runTermEvaluator @_ @_ @(Value (Hole Precise) (ImportGraphEff term (Hole Precise)))
. runReader (packageInfo package)
. runReader lowerBound
in extractGraph <$> analyze runImportGraphAnalysis (evaluate @_ @_ @_ @_ @term lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd))
newtype ImportGraphEff term address a = ImportGraphEff
{ runImportGraphEff :: Eff '[ LoopControl address
, Return address
, Env address
, Allocator address (Value address (ImportGraphEff term address))
, Reader ModuleInfo
, Reader Span
, Reader PackageInfo
, Modules address
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
, State (Graph ModuleInfo)
, Resumable (ValueError address (ImportGraphEff term address))
, Resumable (AddressError address (Value address (ImportGraphEff term address)))
, Resumable ResolutionError
, Resumable EvalError
, Resumable (EnvironmentError address)
, Resumable (Unspecialized (Value address (ImportGraphEff term address)))
, Resumable (LoadError address)
, Trace
, Fresh
, State (Heap address Latest (Value address (ImportGraphEff term address)))
] a
}
-- | Parse a list of files into a 'Package'.
parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs)
=> Parser term -- ^ A parser.
@ -101,22 +181,23 @@ parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, M
parsePackage parser project@Project{..} = do
p <- parseModules parser project
resMap <- Task.resolutionMap project
let pkg = Package.fromModules n Nothing (length projectEntryPoints) p resMap
pkg <$ trace ("project: " <> show pkg)
let pkg = Package.fromModules n p resMap
pkg <$ trace ("project: " <> show (() <$ pkg))
where
n = name (projectName project)
-- | Parse all files in a project into 'Module's.
parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term]
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
parseModules parser p@Project{..} = distributeFor (projectFiles p) (WrapTask . parseModule p parser)
-- | Parse a file into a 'Module'.
parseModule :: (Member Files effs, Member Task effs) => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
parseModule parser rootDir file = do
blob <- readBlob file
moduleForBlob rootDir blob <$> parse parser blob
parseModule :: (Member (Exc SomeException) effs, Member Task effs) => Project -> Parser term -> File -> Eff effs (Module term)
parseModule proj parser file = do
mBlob <- readFile proj file
case mBlob of
Just blob -> moduleForBlob (Just (projectRootDir proj)) blob <$> parse parser blob
Nothing -> throwError (SomeException (FileNotFound (filePath file)))
withTermSpans :: ( HasField fields Span
, Member (Reader Span) effects
@ -130,8 +211,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: Member Trace effects => Evaluator address value (Resumable (LoadError address value) ': effects) a -> Evaluator address value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing)
resumingLoadError :: (Member Trace effects, AbstractHole address) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (hole, lowerBound))
resumingEvalError :: Member Trace effects => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of

14
src/Semantic/IO.hs
View File

@ -14,6 +14,7 @@ module Semantic.IO
, noLanguageForBlob
, openFileForReading
, readBlob
, readBlobFromPath
, readBlobPairs
, readBlobPairsFromHandle
, readBlobs
@ -39,7 +40,7 @@ import Control.Monad.IO.Class
import Data.Aeson
import Data.Blob
import Data.Bool
import Data.Project
import Data.Project hiding (readFile)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
@ -100,12 +101,13 @@ readBlobFromPath file = do
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do
isDir <- isDirectory path
let (filterFun, entryPoints, rootDir) = if isDir
then (id, [], fromMaybe path maybeRoot)
else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot)
let rootDir = if isDir
then fromMaybe path maybeRoot
else fromMaybe (takeDirectory path) maybeRoot
paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs
pure $ Project rootDir (toFile <$> paths) lang entryPoints excludeDirs
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
blobs <- liftIO $ traverse (readBlobFromPath . toFile) paths
pure $ Project rootDir blobs lang excludeDirs
where
toFile path = File path lang
exts = extensionsForLanguage lang

3
src/Semantic/Parse.hs
View File

@ -3,7 +3,7 @@ module Semantic.Parse where
import Analysis.ConstructorName (ConstructorName)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Analysis.PackageDef (HasPackageDef, packageDefAlgebra)
import Analysis.PackageDef (HasPackageDef)
import Data.AST
import Data.Blob
import Data.JSON.Fields
@ -21,7 +21,6 @@ runParse :: (Member (Distribute WrappedTask) effs, Member Task effs) => TermRend
runParse JSONTermRenderer = withParsedBlobs (render . renderJSONTerm) >=> serialize JSON
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show))
runParse ImportsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)) >=> serialize JSON
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))

1
src/Semantic/Task.hs
View File

@ -31,6 +31,7 @@ module Semantic.Task
, distributeFor
, distributeFoldMap
-- * Configuration
, debugOptions
, defaultConfig
, terminalFormatter
, logfmtFormatter

67
src/Semantic/Util.hs
View File

@ -2,19 +2,25 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Semantic.Util where
import Prelude hiding (readFile)
import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting
import Analysis.Abstract.Evaluating
import Control.Abstract
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address
import Data.Abstract.Evaluatable
import Data.Abstract.Value
import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Type
import Data.Blob
import Data.Project
import Data.Functor.Foldable
import Data.Graph (topologicalSort)
import qualified Data.Language as Language
import Data.List (uncons)
import Data.Project hiding (readFile)
import Data.Sum (weaken)
import Data.Term
import Language.Haskell.HsColour
@ -24,12 +30,14 @@ import Prologue hiding (weaken)
import Semantic.Graph
import Semantic.IO as IO
import Semantic.Task
import System.FilePath.Posix (takeDirectory)
import Text.Show (showListWith)
import Text.Show.Pretty (ppShow)
justEvaluating
= runM
. evaluating
. runState lowerBound
. runFresh 0
. runPrintingTrace
. fmap reassociate
. runLoadError
@ -38,7 +46,6 @@ justEvaluating
. runEnvironmentError
. runEvalError
. runAddressError
. runTermEvaluator @_ @Precise @(Value Precise (UtilEff _))
. runValueError
newtype UtilEff address a = UtilEff
@ -47,7 +54,8 @@ newtype UtilEff address a = UtilEff
, Env address
, Allocator address (Value address (UtilEff address))
, Reader ModuleInfo
, Modules address (Value address (UtilEff address))
, Modules address
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
, Reader Span
, Reader PackageInfo
, Resumable (ValueError address (UtilEff address))
@ -56,18 +64,18 @@ newtype UtilEff address a = UtilEff
, Resumable (EnvironmentError address)
, Resumable ResolutionError
, Resumable (Unspecialized (Value address (UtilEff address)))
, Resumable (LoadError address (Value address (UtilEff address)))
, Resumable (LoadError address)
, Trace
, Fresh
, State (Heap address Latest (Value address (UtilEff address)))
, State (ModuleTable (Maybe (address, Environment address)))
, IO
] a
}
checking
= runM @_ @IO
. evaluating
. runState (lowerBound @(Heap Monovariant All Type))
. runFresh 0
. runPrintingTrace
. runTermEvaluator @_ @Monovariant @Type
. caching @[]
@ -81,18 +89,41 @@ checking
. runAddressError
. runTypeError
evalGoProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path
evalRubyProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path
evalPHPProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path
evalPythonProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path
evalJavaScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript path
evalTypeScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path
evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go
evalRubyProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby
evalPHPProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP
evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python
evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript
evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript
typecheckGoFile path = checking =<< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go path
typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go
-- Evaluate a project, starting at a single entrypoint.
evaluateProject proxy parser lang path = evaluatePackageWith proxy id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser)
evaluateProjectWithCaching proxy parser lang path = evaluatePackageWith proxy convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser)
-- Evaluate a project consisting of the listed paths.
evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
package <- fmap quieterm <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
modules <- topologicalSort <$> runImportGraph proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise))
(runReader (packageInfo package)
(runReader (lowerBound @Span)
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
(fmap fst
(runState (lowerBound @(ModuleTable (NonEmpty (Module (Precise, Environment Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans modules)))))))
evaluateProjectWithCaching proxy parser lang path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path lang []
package <- fmap quieterm <$> parsePackage parser project
modules <- topologicalSort <$> runImportGraph proxy package
pure (runReader (packageInfo package)
(runReader (lowerBound @Span)
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
(fmap fst
(runState (lowerBound @(ModuleTable (NonEmpty (Module (Monovariant, Environment Monovariant)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans modules))))))
parseFile :: Parser term -> FilePath -> IO term

27
test/Analysis/Go/Spec.hs
View File

@ -2,6 +2,7 @@ module Analysis.Go.Spec (spec) where
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Language as Language
import qualified Language.Go.Assignment as Go
import SpecHelpers
@ -9,20 +10,24 @@ import SpecHelpers
spec :: Spec
spec = parallel $ do
describe "evaluates Go" $ do
describe "Go" $ do
it "imports and wildcard imports" $ do
((Right [(_, env)], state), _) <- evaluate "main.go"
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
((res, heap), _) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main.go" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName heap ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
other -> expectationFailure (show other)
it "imports with aliases (and side effects only)" $ do
((Right [(_, env)], state), _) <- evaluate "main1.go"
Env.names env `shouldBe` [ "f", "main" ]
(derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
((res, heap), _) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main1.go" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldBe` [ "f", "main" ]
(derefQName heap ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
other -> expectationFailure (show other)
where
fixtures = "test/fixtures/go/analysis/"
evaluate entry = evalGoProject (fixtures <> entry)
evalGoProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path
evaluate = evalGoProject . map (fixtures <>)
evalGoProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go

36
test/Analysis/PHP/Spec.hs
View File

@ -4,6 +4,7 @@ import Control.Abstract
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Language as Language
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Language.PHP.Assignment as PHP
import SpecHelpers
@ -12,24 +13,33 @@ spec :: Spec
spec = parallel $ do
describe "PHP" $ do
it "evaluates include and require" $ do
((Right [(res, env)], state), _) <- evaluate "main.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
((res, heap), _) <- evaluate ["main.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main.php" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [unit]
Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "evaluates include_once and require_once" $ do
((Right [(res, env)], state), _) <- evaluate "main_once.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
((res, heap), _) <- evaluate ["main_once.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main_once.php" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [unit]
Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "evaluates namespaces" $ do
((Right [(_, env)], state), _) <- evaluate "namespaces.php"
Env.names env `shouldBe` [ "Foo", "NS1" ]
((res, heap), _) <- evaluate ["namespaces.php"]
case ModuleTable.lookup "namespaces.php" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldBe` [ "Foo", "NS1" ]
(derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
(derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
(derefQName heap ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
(derefQName heap ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
(derefQName heap ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
other -> expectationFailure (show other)
where
fixtures = "test/fixtures/php/analysis/"
evaluate entry = evalPHPProject (fixtures <> entry)
evalPHPProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path
evaluate = evalPHPProject . map (fixtures <>)
evalPHPProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP

54
test/Analysis/Python/Spec.hs
View File

@ -2,8 +2,8 @@ module Analysis.Python.Spec (spec) where
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Value
import Data.Map
import qualified Language.Python.Assignment as Python
import qualified Data.Language as Language
@ -12,38 +12,52 @@ import SpecHelpers
spec :: Spec
spec = parallel $ do
describe "evaluates Python" $ do
describe "Python" $ do
it "imports" $ do
((Right [(_, env)], state), _) <- evaluate "main.py"
Env.names env `shouldContain` [ "a", "b" ]
((res, heap), _) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldContain` [ "a", "b" ]
(derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"])
(derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"])
(derefQName heap ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
(derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"])
(derefQName heap ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"])
other -> expectationFailure (show other)
it "imports with aliases" $ do
((Right [(_, env)], _), _) <- evaluate "main1.py"
Env.names env `shouldContain` [ "b", "e" ]
((res, _), _) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main1.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "b", "e" ]
other -> expectationFailure (show other)
it "imports using 'from' syntax" $ do
((Right [(_, env)], _), _) <- evaluate "main2.py"
Env.names env `shouldContain` [ "bar", "foo" ]
((res, _), _) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main2.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "imports with relative syntax" $ do
((Right [(_, env)], state), _) <- evaluate "main3.py"
Env.names env `shouldContain` [ "utils" ]
(derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
((res, heap), _) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"]
case ModuleTable.lookup "main3.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldContain` [ "utils" ]
(derefQName heap ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
other -> expectationFailure (show other)
it "subclasses" $ do
((res, _), _) <- evaluate "subclass.py"
fmap fst <$> res `shouldBe` Right [String "\"bar\""]
((res, heap), _) <- evaluate ["subclass.py"]
case ModuleTable.lookup "subclass.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""]
other -> expectationFailure (show other)
it "handles multiple inheritance left-to-right" $ do
((res, _), _) <- evaluate "multiple_inheritance.py"
fmap fst <$> res `shouldBe` Right [String "\"foo!\""]
((res, heap), _) <- evaluate ["multiple_inheritance.py"]
case ModuleTable.lookup "multiple_inheritance.py" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""]
other -> expectationFailure (show other)
where
ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/python/analysis/"
evaluate entry = evalPythonProject (fixtures <> entry)
evalPythonProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path
evaluate = evalPythonProject . map (fixtures <>)
evalPythonProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python

93
test/Analysis/Ruby/Spec.hs
View File

@ -3,12 +3,11 @@ module Analysis.Ruby.Spec (spec) where
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Value as Value
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Number as Number
import Data.AST
import Control.Monad.Effect (SomeExc(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map
import Data.Map.Monoidal as Map
import Data.Sum
import qualified Language.Ruby.Assignment as Ruby
import qualified Data.Language as Language
@ -20,61 +19,89 @@ spec :: Spec
spec = parallel $ do
describe "Ruby" $ do
it "evaluates require_relative" $ do
((Right [(res, env)], state), _) <- evaluate "main.rb"
res `shouldBe` Value.Integer (Number.Integer 1)
Env.names env `shouldContain` ["foo"]
((res, heap), _) <- evaluate ["main.rb", "foo.rb"]
case ModuleTable.lookup "main.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
it "evaluates load" $ do
((Right [(_, env)], _), _) <- evaluate "load.rb"
Env.names env `shouldContain` ["foo"]
((res, heap), _) <- evaluate ["load.rb", "foo.rb"]
case ModuleTable.lookup "load.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
it "evaluates load with wrapper" $ do
((res, state), _) <- evaluate "load-wrap.rb"
((res, _), _) <- evaluate ["load-wrap.rb", "foo.rb"]
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
it "evaluates subclass" $ do
((Right [(res, env)], state), _) <- evaluate "subclass.rb"
res `shouldBe` String "\"<bar>\""
Env.names env `shouldContain` [ "Bar", "Foo" ]
((res, heap), _) <- evaluate ["subclass.rb"]
case ModuleTable.lookup "subclass.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<bar>\""]
Env.names env `shouldContain` [ "Bar", "Foo" ]
(derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
(derefQName heap ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
other -> expectationFailure (show other)
it "evaluates modules" $ do
((Right [(res, env)], state), _) <- evaluate "modules.rb"
res `shouldBe` String "\"<hello>\""
Env.names env `shouldContain` [ "Bar" ]
((res, heap), _) <- evaluate ["modules.rb"]
case ModuleTable.lookup "modules.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<hello>\""]
Env.names env `shouldContain` [ "Bar" ]
other -> expectationFailure (show other)
it "handles break correctly" $ do
((res, _), _) <- evaluate "break.rb"
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)]
((res, heap), _) <- evaluate ["break.rb"]
case ModuleTable.lookup "break.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
other -> expectationFailure (show other)
it "handles break correctly" $ do
((res, _), _) <- evaluate "next.rb"
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)]
it "handles next correctly" $ do
((res, heap), _) <- evaluate ["next.rb"]
case ModuleTable.lookup "next.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)]
other -> expectationFailure (show other)
it "calls functions with arguments" $ do
((res, _), _) <- evaluate "call.rb"
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)]
((res, heap), _) <- evaluate ["call.rb"]
case ModuleTable.lookup "call.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)]
other -> expectationFailure (show other)
it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.rb"
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)]
((res, heap), _) <- evaluate ["early-return.rb"]
case ModuleTable.lookup "early-return.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
other -> expectationFailure (show other)
it "has prelude" $ do
((res, _), _) <- evaluate "preluded.rb"
fmap fst <$> res `shouldBe` Right [String "\"<foo>\""]
((res, heap), _) <- evaluate ["preluded.rb"]
case ModuleTable.lookup "preluded.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
other -> expectationFailure (show other)
it "evaluates __LINE__" $ do
((res, _), _) <- evaluate "line.rb"
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)]
((res, heap), _) <- evaluate ["line.rb"]
case ModuleTable.lookup "line.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
other -> expectationFailure (show other)
it "resolves builtins used in the prelude" $ do
((res, _), traces) <- evaluate "puts.rb"
fmap fst <$> res `shouldBe` Right [Unit]
traces `shouldContain` [ "\"hello\"" ]
((res, heap), traces) <- evaluate ["puts.rb"]
case ModuleTable.lookup "puts.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Unit]
traces `shouldContain` [ "\"hello\"" ]
other -> expectationFailure (show other)
where
ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/ruby/analysis/"
evaluate entry = evalRubyProject (fixtures <> entry)
evalRubyProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path
evaluate = evalRubyProject . map (fixtures <>)
evalRubyProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby

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

@ -3,41 +3,50 @@ module Analysis.TypeScript.Spec (spec) where
import Control.Arrow ((&&&))
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import qualified Language.TypeScript.Assignment as TypeScript
import Data.Abstract.Value as Value
import Data.Abstract.Number as Number
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Language as Language
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sum
import SpecHelpers
spec :: Spec
spec = parallel $ do
describe "evaluates TypeScript" $ do
describe "TypeScript" $ do
it "imports with aliased symbols" $ do
((Right [(_, env)], _), _) <- evaluate "main.ts"
Env.names env `shouldBe` [ "bar", "quz" ]
((res, _), _) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
case ModuleTable.lookup "main.ts" <$> res of
Right (Just (Module _ (_, env) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ]
other -> expectationFailure (show other)
it "imports with qualified names" $ do
((Right [(_, env)], state), _) <- evaluate "main1.ts"
Env.names env `shouldBe` [ "b", "z" ]
((res, heap), _) <- evaluate ["main1.ts", "foo.ts", "a.ts"]
case ModuleTable.lookup "main1.ts" <$> res of
Right (Just (Module _ (_, env) :| [])) -> do
Env.names env `shouldBe` [ "b", "z" ]
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
(derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
(derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
(derefQName heap ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
other -> expectationFailure (show other)
it "side effect only imports" $ do
((res, _), _) <- evaluate "main2.ts"
fmap snd <$> res `shouldBe` Right [lowerBound]
((res, _), _) <- evaluate ["main2.ts", "a.ts", "foo.ts"]
case ModuleTable.lookup "main2.ts" <$> res of
Right (Just (Module _ (_, env) :| [])) -> env `shouldBe` lowerBound
other -> expectationFailure (show other)
it "fails exporting symbols not defined in the module" $ do
((res, _), _) <- evaluate "bad-export.ts"
((res, _), _) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"]
res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip"))))
it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.ts"
fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)]
((res, heap), _) <- evaluate ["early-return.ts"]
case ModuleTable.lookup "early-return.ts" <$> res of
Right (Just (Module _ (addr, _) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)]
other -> expectationFailure (show other)
where
fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = evalTypeScriptProject (fixtures <> entry)
evalTypeScriptProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path
evaluate = evalTypeScriptProject . map (fixtures <>)
evalTypeScriptProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript

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

@ -4,7 +4,6 @@ module Control.Abstract.Evaluator.Spec
, SpecEff(..)
) where
import Analysis.Abstract.Evaluating (evaluating)
import Control.Abstract
import Data.Abstract.Module
import qualified Data.Abstract.Number as Number
@ -30,14 +29,15 @@ spec = parallel $ do
evaluate
= runM
. evaluating @Precise @Val
. runReader (PackageInfo (name "test") Nothing mempty)
. runState (lowerBound @(Heap Precise Latest Val))
. runFresh 0
. runReader (PackageInfo (name "test") mempty)
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
. fmap reassociate
. runValueError
. runEnvironmentError
. runAddressError
. runAllocator
. runAllocator @Precise @_ @Val
. (>>= deref . fst)
. runEnv lowerBound
. runReturn
@ -59,7 +59,6 @@ newtype SpecEff a = SpecEff
, Reader PackageInfo
, Fresh
, State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Precise, Environment Precise)))
, IO
] a
}

1
test/Doctests.hs
View File

@ -9,6 +9,7 @@ defaultFiles =
[ "src/Data/Abstract/Address.hs"
, "src/Data/Abstract/Environment.hs"
, "src/Data/Abstract/Name.hs"
, "src/Data/Graph.hs"
, "src/Data/Range.hs"
, "src/Data/Semigroup/App.hs"
]

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

@ -16,7 +16,7 @@ import qualified TreeSitter.Node as TS
import qualified TreeSitter.Parser as TS
import qualified TreeSitter.Tree as TS
import SpecHelpers
import SpecHelpers hiding (readFile)
spec :: Spec

98
test/SpecHelpers.hs
View File

@ -9,12 +9,10 @@ module SpecHelpers
, derefQName
, verbatim
, TermEvaluator(..)
, TestEff(..)
, Verbatim(..)
, toList
) where
import Analysis.Abstract.Evaluating
import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
import Control.Abstract
import Control.Arrow ((&&&))
import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace)
@ -24,6 +22,7 @@ import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X
import Data.Abstract.Heap as X
import Data.Abstract.Module as X
import Data.Abstract.ModuleTable as X hiding (lookup)
import Data.Abstract.Name as X
import Data.Abstract.Value (Value(..), ValueError, runValueError)
@ -33,6 +32,7 @@ import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Project as X
import Data.Proxy as X
import Data.Foldable (toList)
import Data.Functor.Listable as X
import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..))
@ -81,38 +81,39 @@ readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith IO.readFilePair paths'
testEvaluating :: TermEvaluator term Precise
Val
'[ Resumable (ValueError Precise TestEff)
, Resumable (AddressError Precise Val)
, Resumable EvalError, Resumable (EnvironmentError Precise)
, Resumable ResolutionError
, Resumable (Unspecialized Val)
, Resumable (LoadError Precise Val)
, Fresh
, State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Precise, Environment Precise)))
, Trace
]
[(Precise, Environment Precise)]
-> ((Either
(SomeExc
(Data.Sum.Sum
'[ ValueError Precise TestEff
, AddressError Precise Val
, EvalError
, EnvironmentError Precise
, ResolutionError
, Unspecialized Val
, LoadError Precise Val
]))
[(Value Precise TestEff, Environment Precise)],
EvaluatingState Precise Val),
[String])
type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
, Resumable (AddressError Precise Val)
, Resumable EvalError, Resumable (EnvironmentError Precise)
, Resumable ResolutionError
, Resumable (Unspecialized Val)
, Resumable (LoadError Precise)
, Trace
, Fresh
, State (Heap Precise Latest Val)
, IO
]
type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise)
, AddressError Precise Val
, EvalError
, EnvironmentError Precise
, ResolutionError
, Unspecialized Val
, LoadError Precise
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
-> IO
( ( Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
(ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
, Heap Precise Latest Val
)
, [String]
)
testEvaluating
= run
= runM
. fmap (\ ((res, traces), heap) -> ((res, heap), traces))
. runState lowerBound
. runFresh 0
. runReturningTrace
. evaluating
. fmap reassociate
. runLoadError
. runUnspecialized
@ -120,37 +121,10 @@ testEvaluating
. runEnvironmentError
. runEvalError
. runAddressError
. runValueError
. (>>= traverse deref1)
. runTermEvaluator @_ @_ @Val
. runValueError @_ @Precise @(UtilEff Precise)
type Val = Value Precise TestEff
newtype TestEff a = TestEff
{ runTestEff :: Eff '[ LoopControl Precise
, Return Precise
, Env Precise
, Allocator Precise Val
, Reader ModuleInfo
, Modules Precise Val
, Reader Span
, Reader PackageInfo
, Resumable (ValueError Precise TestEff)
, Resumable (AddressError Precise Val)
, Resumable EvalError
, Resumable (EnvironmentError Precise)
, Resumable ResolutionError
, Resumable (Unspecialized Val)
, Resumable (LoadError Precise Val)
, Fresh
, State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Precise, Environment Precise)))
, Trace
] a
}
type Val = Value Precise (UtilEff Precise)
deref1 (ptr, env) = runAllocator $ do
val <- deref ptr
pure (val, env)
deNamespace :: Value Precise term -> Maybe (Name, [Name])
deNamespace (Namespace name scope) = Just (name, Env.names scope)