diff --git a/preludes/javascript.js b/preludes/javascript.js deleted file mode 100644 index dcb78c77a..000000000 --- a/preludes/javascript.js +++ /dev/null @@ -1,2 +0,0 @@ -// can't quite define console.log in a way we can evaluate yet, but... -// function log(x) { return __semantic_print(x) } diff --git a/preludes/python.py b/preludes/python.py deleted file mode 100644 index e5df32aca..000000000 --- a/preludes/python.py +++ /dev/null @@ -1,3 +0,0 @@ -def print(x): - __semantic_print(x) - return x diff --git a/preludes/ruby.rb b/preludes/ruby.rb deleted file mode 100644 index e557acc1e..000000000 --- a/preludes/ruby.rb +++ /dev/null @@ -1,13 +0,0 @@ -class Object - def new - self - end - - def inspect - return "" - end -end - -def puts(obj) - __semantic_print(obj) -end diff --git a/semantic.cabal b/semantic.cabal index 930d08c60..f14a44b12 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -127,7 +127,6 @@ library , Language.PHP.Assignment , Language.PHP.Grammar , Language.PHP.Syntax - , Language.Preluded , Language.Python.Assignment , Language.Python.Grammar , Language.Python.Syntax diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index a624c2e78..470fb7d43 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -5,25 +5,42 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.Value +import qualified Data.Abstract.Environment as Env import Data.Abstract.Name -import Data.Text (pack, unpack) +import Data.Text (unpack) import Prologue -builtin :: ( HasCallStack - , Member (Allocator address value) effects - , Member (Env address) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - ) - => String - -> Evaluator address value effects value - -> Evaluator address value effects () -builtin s def = withCurrentCallStack callStack $ do - let name' = name ("__semantic_" <> pack s) - addr <- alloc name' - bind name' addr +define :: ( HasCallStack + , Member (Allocator address value) effects + , Member (Env address) effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + ) + => Name + -> Evaluator address value effects value + -> Evaluator address value effects () +define name def = withCurrentCallStack callStack $ do + addr <- alloc name + bind name addr def >>= assign addr +defineClass :: ( AbstractValue address value effects + , HasCallStack + , Member (Allocator address value) effects + , Member (Env address) effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + ) + => Name + -> [Name] + -> Evaluator address value effects a + -> Evaluator address value effects () +defineClass name superclasses scope = define name $ do + env <- locally $ do + void scope + Env.head <$> getEnv + klass name (map (string . formatName) superclasses) env + lambda :: (AbstractFunction address value effects, Member Fresh effects) => (Name -> Evaluator address value effects address) -> Evaluator address value effects value @@ -43,4 +60,4 @@ defineBuiltins :: ( AbstractValue address value effects ) => Evaluator address value effects () defineBuiltins = - builtin "print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) + define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d32f93e93..06184761d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , Evaluatable(..) , evaluatePackageWith , traceResolve --- | Effects +-- * Preludes +, HasPrelude(..) +-- * Effects , EvalError(..) , throwEvalError , runEvalError @@ -30,6 +32,7 @@ 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.Language import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -62,7 +65,7 @@ class Show1 constr => Evaluatable constr where -- | Evaluate a given package. -evaluatePackageWith :: forall address term value inner inner' inner'' outer +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' @@ -70,6 +73,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Evaluatable (Base term) , Foldable (Cell address) , FreeVariables term + , HasPrelude lang , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (EnvironmentError address)) outer @@ -87,15 +91,16 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) ) - => (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address)) + => 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 analyzeModule analyzeTerm package +evaluatePackageWith lang analyzeModule analyzeTerm package = runReader (packageInfo package) . runReader lowerBound . runReader (packageModules (packageBody package)) - . withPrelude (packagePrelude (packageBody package)) + . withPrelude package $ \ preludeEnv -> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv)) . traverse (uncurry (evaluateEntryPoint preludeEnv)) @@ -121,13 +126,14 @@ evaluatePackageWith analyzeModule analyzeTerm package bindAll env maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym - evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) $ do - (_, builtinsEnv) <- runInModule lowerBound moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit)) - second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude - - withPrelude Nothing f = f lowerBound - withPrelude (Just prelude) f = do - (_, preludeEnv) <- evalPrelude prelude + 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 @@ -135,6 +141,55 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator ad traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) +-- Preludes + +class HasPrelude (language :: Language) where + definePrelude :: ( AbstractValue address value effects + , HasCallStack + , Member (Allocator address value) effects + , Member (Env address) effects + , Member Fresh effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + , Member (Resumable (EnvironmentError address)) effects + , Member Trace effects + ) + => proxy language + -> Evaluator address value effects () + definePrelude _ = pure () + +instance HasPrelude 'Go +instance HasPrelude 'Haskell +instance HasPrelude 'Java +instance HasPrelude 'JavaScript +instance HasPrelude 'PHP + +builtInPrint :: ( AbstractIntro value + , AbstractFunction address value effects + , Member (Resumable (EnvironmentError address)) effects + , Member (Env address) effects, Member (Allocator address value) effects) + => Name + -> Evaluator address value effects address +builtInPrint v = do + print <- variable "__semantic_print" >>= deref + void $ call print [variable v] + box unit + +instance HasPrelude 'Python where + definePrelude _ = + define "print" (lambda builtInPrint) + +instance HasPrelude 'Ruby where + definePrelude _ = do + define "puts" (lambda builtInPrint) + + defineClass "Object" [] $ do + define "inspect" (lambda (const (box (string "")))) + +instance HasPrelude 'TypeScript + -- FIXME: define console.log using __semantic_print + + -- Effects -- | The type of error thrown when failing to evaluate a term. diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 60e1ddb9d..e604698e2 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -22,7 +22,6 @@ newtype Version = Version { versionString :: String } data PackageBody term = PackageBody { packageModules :: ModuleTable (NonEmpty (Module term)) - , packagePrelude :: Maybe (Module term) , packageEntryPoints :: ModuleTable (Maybe Name) } deriving (Eq, Functor, Ord, Show) @@ -35,8 +34,8 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term -fromModules name version prelude entryPoints modules resolutions = - Package (PackageInfo name version resolutions) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints') +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 diff --git a/src/Language/Preluded.hs b/src/Language/Preluded.hs deleted file mode 100644 index 2400d6887..000000000 --- a/src/Language/Preluded.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies #-} - -module Language.Preluded - ( Preluded (..) - ) where - -import GHC.TypeLits -import qualified Language.Python.Assignment as Python -import qualified Language.Ruby.Assignment as Ruby -import qualified Language.TypeScript.Assignment as TypeScript - -class Preluded syntax where - type PreludePath syntax :: Symbol - -instance Preluded Ruby.Term where - type PreludePath Ruby.Term = "preludes/ruby.rb" - -instance Preluded Python.Term where - type PreludePath Python.Term = "preludes/python.py" - -instance Preluded TypeScript.Term where - type PreludePath TypeScript.Term = "preludes/javascript.js" diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index b2b0f6c10..6f969bf82 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -25,6 +25,7 @@ module Parsing.Parser import Assigning.Assignment import qualified CMarkGFM +import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Kind import Data.Language @@ -32,16 +33,13 @@ import Data.Record import Data.Sum import qualified Data.Syntax as Syntax import Data.Term -import Data.Project import Foreign.Ptr -import qualified GHC.TypeLits as TypeLevel import qualified Language.Go.Assignment as Go import qualified Language.Haskell.Assignment as Haskell import qualified Language.Java.Assignment as Java import qualified Language.JSON.Assignment as JSON import qualified Language.Markdown.Assignment as Markdown import qualified Language.PHP.Assignment as PHP -import Language.Preluded import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript @@ -63,10 +61,12 @@ type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) -- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. data SomeAnalysisParser typeclasses ann where - SomeAnalysisParser :: ( Element Syntax.Identifier fs - , ApplyAll' typeclasses fs) + SomeAnalysisParser :: ( ApplyAll' typeclasses fs + , Element Syntax.Identifier fs + , HasPrelude lang + ) => Parser (Term (Sum fs) ann) -- ^ A parser. - -> Maybe File -- ^ Maybe path to prelude. + -> Proxy lang -> SomeAnalysisParser typeclasses ann -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. @@ -81,14 +81,14 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. -> Language -- ^ The 'Language' to select. -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced. -someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing -someAnalysisParser _ Java = SomeAnalysisParser javaParser Nothing -someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) JavaScript) -someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser Nothing -someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing -someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Python) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Ruby) -someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing +someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go) +someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell) +someAnalysisParser _ Java = SomeAnalysisParser javaParser (Proxy :: Proxy 'Java) +someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'JavaScript) +someAnalysisParser _ PHP = SomeAnalysisParser phpParser (Proxy :: Proxy 'PHP) +someAnalysisParser _ Python = SomeAnalysisParser pythonParser (Proxy :: Proxy 'Python) +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser (Proxy :: Proxy 'Ruby) +someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'TypeScript) someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 87fc45f20..28c48c8f5 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -12,7 +12,6 @@ module Rendering.Renderer , renderToSymbols , ImportSummary(..) , renderToImports -, renderToTags , renderTreeGraph , Summaries(..) , TOCSummary(..) @@ -21,7 +20,6 @@ module Rendering.Renderer , parseSymbolFields ) where -import Data.Aeson (Value) import Data.ByteString.Builder import Data.Graph import Rendering.Graph as R @@ -52,8 +50,6 @@ data TermRenderer output where JSONTermRenderer :: TermRenderer (JSON "trees" SomeJSON) -- | Render to a 'ByteString' formatted as nested s-expressions. SExpressionTermRenderer :: TermRenderer Builder - -- | Render to a list of tags (deprecated). - TagsTermRenderer :: TermRenderer [Value] -- | Render to a list of symbols. SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON) -- | Render to a list of modules that represent the import graph. diff --git a/src/Rendering/Symbol.hs b/src/Rendering/Symbol.hs index 97fdcb29f..5ed34d636 100644 --- a/src/Rendering/Symbol.hs +++ b/src/Rendering/Symbol.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Rendering.Symbol ( renderToSymbols -, renderToTags , SymbolFields(..) , defaultSymbolFields , parseSymbolFields @@ -20,18 +19,6 @@ import qualified Data.Text as T import Rendering.TOC --- | Render a 'Term' to a ctags like output (See 'Tag'). --- --- This format is going away. Prefer the new 'renderToSymbols' as it provides a --- more compact data representation and custom field selection. This exists to --- back support the staff shipped tag generation in github/github. -renderToTags :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> [Value] -renderToTags Blob{..} = fmap toJSON . termToC blobPath - where - termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => FilePath -> Term f (Record fields) -> [Symbol] - termToC path = mapMaybe (symbolSummary defaultTagSymbolFields path "unchanged") . termTableOfContentsBy declaration - - -- | Render a 'Term' to a list of symbols (See 'Symbol'). renderToSymbols :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => SymbolFields -> Blob -> Term f (Record fields) -> [Value] renderToSymbols fields Blob{..} term = [toJSON (termToC fields blobPath term)] @@ -100,9 +87,6 @@ data SymbolFields = SymbolFields defaultSymbolFields :: SymbolFields defaultSymbolFields = SymbolFields True False False True False True -defaultTagSymbolFields :: SymbolFields -defaultTagSymbolFields = SymbolFields True True True True True True - parseSymbolFields :: String -> SymbolFields parseSymbolFields arg = let fields = splitWhen (== ',') arg in diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index a62521022..77572ffd9 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -64,7 +64,6 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar parseArgumentsParser = do renderer <- flag (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") <|> flag' (Parse.runParse JSONTermRenderer) (long "json" <> help "Output JSON parse trees") - <|> flag' (Parse.runParse TagsTermRenderer) (long "tags" <> help "Output JSON tags") <|> flag' (Parse.runParse . SymbolsTermRenderer) (long "symbols" <> help "Output JSON symbol list") <*> (option symbolFieldsReader ( long "fields" <> help "Comma delimited list of specific fields to return (symbols output only)." diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 47fda0872..78f81ace1 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -38,20 +38,20 @@ import Semantic.Task as Task data GraphType = ImportGraph | CallGraph -runGraph :: ( Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs) +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 prelude <- someAnalysisParser + | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do - package <- parsePackage parser prelude project + package <- parsePackage parser project let analyzeTerm = withTermSpans . case graphType of ImportGraph -> id CallGraph -> graphingTerms analyzeModule = (if includePackages then graphingPackages else id) . graphingModules - analyze runGraphAnalysis (evaluatePackageWith analyzeModule analyzeTerm package) >>= extractGraph + analyze runGraphAnalysis (evaluatePackageWith lang analyzeModule analyzeTerm package) >>= extractGraph where extractGraph result = case result of (((_, graph), _), _) -> pure (simplify graph) runGraphAnalysis @@ -94,16 +94,14 @@ newtype GraphEff address a = GraphEff } -- | Parse a list of files into a 'Package'. -parsePackage :: (Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs) +parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs) => Parser term -- ^ A parser. - -> Maybe File -- ^ Prelude (optional). -> Project -- ^ Project to parse into a package. -> Eff effs (Package term) -parsePackage parser preludeFile project@Project{..} = do - prelude <- traverse (parseModule parser Nothing) preludeFile +parsePackage parser project@Project{..} = do p <- parseModules parser project resMap <- Task.resolutionMap project - let pkg = Package.fromModules n Nothing prelude (length projectEntryPoints) p resMap + let pkg = Package.fromModules n Nothing (length projectEntryPoints) p resMap pkg <$ trace ("project: " <> show pkg) where diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index eb8d4f8f1..398a976b8 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -22,7 +22,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 TagsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)) >=> serialize JSON 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")) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b63f6b996..94280abff 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -17,10 +17,8 @@ import Data.Functor.Foldable import qualified Data.Language as Language import Data.Sum (weaken) import Data.Term -import qualified GHC.TypeLits as TypeLevel import Language.Haskell.HsColour import Language.Haskell.HsColour.Colourise -import Language.Preluded import Parsing.Parser import Prologue hiding (weaken) import Semantic.Graph @@ -29,10 +27,6 @@ import Semantic.Task import Text.Show (showListWith) import Text.Show.Pretty (ppShow) -import qualified Language.Python.Assignment as Python -import qualified Language.Ruby.Assignment as Ruby -import qualified Language.TypeScript.Assignment as TypeScript - justEvaluating = runM . evaluating @@ -87,22 +81,18 @@ checking . runAddressError . runTypeError -evalGoProject path = justEvaluating =<< evaluateProject goParser Language.Go Nothing path -evalRubyProject path = justEvaluating =<< evaluateProject rubyParser Language.Ruby rubyPrelude path -evalPHPProject path = justEvaluating =<< evaluateProject phpParser Language.PHP Nothing path -evalPythonProject path = justEvaluating =<< evaluateProject pythonParser Language.Python pythonPrelude path -evalJavaScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.JavaScript javaScriptPrelude path -evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.TypeScript Nothing path +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 -typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path - -rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Language.Ruby -pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Language.Python -javaScriptPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) Language.JavaScript +typecheckGoFile path = checking =<< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go path -- Evaluate a project, starting at a single entrypoint. -evaluateProject parser lang prelude path = evaluatePackageWith id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude) -evaluateProjectWithCaching parser lang prelude path = evaluatePackageWith convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude) +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) parseFile :: Parser term -> FilePath -> IO term diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 7c4cfd105..08a4ebf3c 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -25,4 +25,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = testEvaluating <$> evaluateProject goParser Language.Go Nothing path + evalGoProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 168139d48..d6bb2e589 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -32,4 +32,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = testEvaluating <$> evaluateProject phpParser Language.PHP Nothing path + evalPHPProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 66ad0df48..753da4932 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -46,4 +46,4 @@ spec = parallel $ do ns n = Just . Latest . Last . Just . Namespace n fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) - evalPythonProject path = testEvaluating <$> evaluateProject pythonParser Language.Python pythonPrelude path + evalPythonProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 83958cde8..72cb00929 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -77,4 +77,4 @@ spec = parallel $ do ns n = Just . Latest . Last . Just . Namespace n fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) - evalRubyProject path = testEvaluating <$> evaluateProject rubyParser Language.Ruby rubyPrelude path + evalRubyProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index d1f09dbb1..7dca4e0aa 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -40,4 +40,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = testEvaluating <$> evaluateProject typescriptParser Language.TypeScript Nothing path + evalTypeScriptProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 2a9b1e539..a64a12d29 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -37,7 +37,6 @@ parseFixtures = , (show JSONTermRenderer, runParse JSONTermRenderer, path', prefix "parse-trees.json") , (show JSONTermRenderer, runParse JSONTermRenderer, [], prefix "parse-tree-empty.json") , (show (SymbolsTermRenderer defaultSymbolFields), runParse (SymbolsTermRenderer defaultSymbolFields), path'', prefix "parse-tree.symbols.json") - , (show TagsTermRenderer, runParse TagsTermRenderer, path'', prefix "parse-tree.tags.json") ] where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby] path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby] diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index d1d2d6702..79db79118 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -32,6 +32,7 @@ import Data.Blob as X import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy (toStrict) import Data.Project as X +import Data.Proxy as X import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) diff --git a/test/fixtures/cli/parse-tree.tags.json b/test/fixtures/cli/parse-tree.tags.json deleted file mode 100644 index dd1281eaa..000000000 --- a/test/fixtures/cli/parse-tree.tags.json +++ /dev/null @@ -1,13 +0,0 @@ -[ -{ - "span": - { - "start": [1, 1], - "end": [2, 4] - }, - "path": "test/fixtures/ruby/corpus/method-declaration.A.rb", - "kind": "Method", - "symbol": "foo", - "line": "def foo", - "language": "Ruby" -}]