From 868651a5294fb2709b673d97c662c17c143659bf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 19 Apr 2018 15:54:48 -0700 Subject: [PATCH 01/23] Move graphImports and read/parse with distribute --- src/Semantic/Graph.hs | 70 ++++++++++++++++++++++++++++++++++++++++- src/Semantic/Task.hs | 73 ------------------------------------------- src/Semantic/Util.hs | 72 +++++++++++++++++++++--------------------- 3 files changed, 105 insertions(+), 110 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3d3eeb73e..5f6eb2e9a 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -5,8 +5,21 @@ import qualified Analysis.Abstract.ImportGraph as Abstract import qualified Data.Abstract.Evaluatable as Analysis import Data.Abstract.FreeVariables import qualified Data.Abstract.ModuleTable as ModuleTable -import Data.Abstract.Package +import Data.Abstract.Package as Package +import qualified Control.Exception as Exc +import Data.Abstract.Module import Data.Blob +import Data.Term +import qualified Data.Syntax as Syntax +import Data.Abstract.Value (Value) +import Data.Abstract.Located +import Data.Abstract.Address +import Analysis.Abstract.BadAddresses +import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadValues +import Analysis.Abstract.BadVariables +import Analysis.Abstract.Evaluating +import Analysis.Abstract.Quiet import Data.List (intercalate) import Data.ByteString.Char8 as BC (pack) import Data.Output @@ -14,6 +27,7 @@ import Parsing.Parser import Prologue hiding (MonadError (..)) import Rendering.Renderer import Semantic.IO (Files, NoLanguageForBlob (..)) +import qualified Semantic.IO as IO import Semantic.Task import System.FilePath.Posix @@ -41,3 +55,57 @@ graph maybeRootDir renderer Blob{..} | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) where packageName = name . BC.pack . dropExtensions . takeFileName + + +-- | Parse a list of files into a 'Package'. +parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term) +parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths + +-- | Parse a list of files into 'Module's. +parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term] +parseModules parser rootDir paths = distributeFor paths (WrapTask . parseModule parser (Just rootDir)) + +-- | Parse a file into a 'Module'. +parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term) +parseModule parser rootDir path = do + blob <- readBlob (path, IO.languageForFilePath path) + moduleForBlob rootDir blob <$> parse parser blob + + +type ImportGraphAnalysis term effects value = + Abstract.ImportGraphing + (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) + effects + value + +-- | Render the import graph for a given 'Package'. +graphImports :: ( + Show ann + , Ord ann + , Apply Analysis.Declarations1 syntax + , Apply Analysis.Evaluatable syntax + , Apply FreeVariables1 syntax + , Apply Functor syntax + , Apply Ord1 syntax + , Apply Eq1 syntax + , Apply Show1 syntax + , Member Syntax.Identifier syntax + , Members '[Exc SomeException, Task] effs + , term ~ Term (Union syntax) ann + ) + => Maybe (Module term) -> Package term -> Eff effs Abstract.ImportGraph +graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelude (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package))) >>= extractGraph + where + asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value + -> Package term + -> ImportGraphAnalysis term effs value + asAnalysisForTypeOfPackage = const + + extractGraph result = case result of + (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph + _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) + + withPrelude Nothing a = a + withPrelude (Just prelude) a = do + preludeEnv <- Analysis.evaluateModule prelude *> Analysis.getEnv + Analysis.withDefaultEnvironment preludeEnv a diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 0e5c9c4dd..44c9aac96 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -18,14 +18,10 @@ module Semantic.Task , time -- * High-level flow , parse -, parseModule -, parseModules -, parsePackage , analyze , decorate , diff , render -, graphImports -- * Concurrency , distribute , distributeFor @@ -47,29 +43,14 @@ module Semantic.Task , Telemetry ) where -import Analysis.Abstract.BadAddresses -import Analysis.Abstract.BadModuleResolutions -import Analysis.Abstract.BadValues -import Analysis.Abstract.BadVariables -import Analysis.Abstract.Evaluating -import qualified Analysis.Abstract.ImportGraph as Abstract -import Analysis.Abstract.Quiet import Analysis.Decorator (decoratorWithAlgebra) import qualified Assigning.Assignment as Assignment import qualified Control.Abstract.Analysis as Analysis -import qualified Control.Exception as Exc import Control.Monad import Control.Monad.Effect.Exception import Control.Monad.Effect.Internal as Eff hiding (run) import Control.Monad.Effect.Reader import Control.Monad.Effect.Run as Run -import Data.Abstract.Address -import qualified Data.Abstract.Evaluatable as Analysis -import Data.Abstract.FreeVariables -import Data.Abstract.Located -import Data.Abstract.Module -import Data.Abstract.Package as Package -import Data.Abstract.Value (Value) import Data.Blob import Data.Diff import qualified Data.Error as Error @@ -106,21 +87,6 @@ type Renderer i o = i -> o parse :: Member Task effs => Parser term -> Blob -> Eff effs term parse parser = send . Parse parser --- | Parse a file into a 'Module'. -parseModule :: Members '[IO.Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term) -parseModule parser rootDir path = do - blob <- head <$> IO.readBlobs (Right [(path, IO.languageForFilePath path)]) - moduleForBlob rootDir blob <$> parse parser blob - --- | Parse a list of files into 'Module's. -parseModules :: Members '[IO.Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term] -parseModules parser rootDir = traverse (parseModule parser (Just rootDir)) - --- | Parse a list of files into a 'Package'. -parsePackage :: Members '[IO.Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term) -parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths - - -- | A task running some 'Analysis.MonadAnalysis' to completion. analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result analyze = send . Analyze @@ -137,45 +103,6 @@ diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2) render :: Member Task effs => Renderer input output -> input -> Eff effs output render renderer = send . Render renderer - -type ImportGraphAnalysis term effects value = - Abstract.ImportGraphing - (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) - effects - value - --- | Render the import graph for a given 'Package'. -graphImports :: ( - Show ann - , Ord ann - , Apply Analysis.Declarations1 syntax - , Apply Analysis.Evaluatable syntax - , Apply FreeVariables1 syntax - , Apply Functor syntax - , Apply Ord1 syntax - , Apply Eq1 syntax - , Apply Show1 syntax - , Member Syntax.Identifier syntax - , Members '[Exc SomeException, Task] effs - , term ~ Term (Union syntax) ann - ) - => Maybe (Module term) -> Package term -> Eff effs Abstract.ImportGraph -graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelude (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package))) >>= extractGraph - where - asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value - -> Package term - -> ImportGraphAnalysis term effs value - asAnalysisForTypeOfPackage = const - - extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph - _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) - - withPrelude Nothing a = a - withPrelude (Just prelude) a = do - preludeEnv <- Analysis.evaluateModule prelude *> Analysis.getEnv - Analysis.withDefaultEnvironment preludeEnv a - -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- -- > runTask = runTaskWithOptions defaultOptions diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca020feb0..63fe69bcd 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,44 +46,44 @@ import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript --- Ruby -evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"] -evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path)) - -evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path)) - -evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths - -evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths - --- Go -evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path -evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path - -typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path - --- Python -evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"] -evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path)) -evalPythonProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))))))) <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluatePackageBody <$> parseProject pythonParser ["py"] path)) - -typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path -evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path - --- PHP -evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path -evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path - --- TypeScript -evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path -evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path -typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path +-- -- Ruby +-- evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"] +-- evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path)) +-- +-- evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path)) +-- +-- evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths +-- +-- evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths +-- +-- -- Go +-- evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path +-- evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path +-- +-- typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path +-- +-- -- Python +-- evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"] +-- evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path)) +-- evalPythonProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))))))) <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluatePackageBody <$> parseProject pythonParser ["py"] path)) +-- +-- typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path +-- tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path +-- evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path +-- +-- -- PHP +-- evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path +-- evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path +-- +-- -- TypeScript +-- evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path +-- evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path +-- typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path -- JavaScript evalJavaScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) . evaluatePackageBody <$> parseProject typescriptParser ["js"] path -runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) +-- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) @@ -129,8 +129,8 @@ parseFile parser rootDir path = runTask $ do parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) -parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term) -parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir +-- parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term) +-- parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir -- Read a file from the filesystem into a Blob. From 156246e4771089603b1effd1a743a30545bc4360 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 11:10:27 -0700 Subject: [PATCH 02/23] Finding a need for a File datatype --- semantic.cabal | 1 + src/Data/File.hs | 10 ++++++++++ 2 files changed, 11 insertions(+) create mode 100644 src/Data/File.hs diff --git a/semantic.cabal b/semantic.cabal index 1e359f98e..108fded1a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -74,6 +74,7 @@ library , Data.Diff , Data.Empty , Data.Error + , Data.File , Data.Functor.Both , Data.Functor.Classes.Generic , Data.JSON.Fields diff --git a/src/Data/File.hs b/src/Data/File.hs new file mode 100644 index 000000000..373da99da --- /dev/null +++ b/src/Data/File.hs @@ -0,0 +1,10 @@ +module Data.File where + +import Data.Language + +data File = File + { filePath :: FilePath + , fileLanguage :: Maybe Language + } + deriving (Eq, Ord, Show) + From ede5773b243899d5e9a9dfaf8a539731e3e6e8da Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 11:11:06 -0700 Subject: [PATCH 03/23] Refactor how we build up a Package and eval the prelude --- src/Data/Abstract/Evaluatable.hs | 15 ++++++---- src/Data/Abstract/Package.hs | 18 ++++++----- src/Semantic/CLI.hs | 3 +- src/Semantic/Graph.hs | 51 ++++++++++++++------------------ 4 files changed, 44 insertions(+), 43 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 5285199be..66866d84d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -263,11 +263,16 @@ evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBo evaluatePackageBody :: MonadEvaluatable location term value m => PackageBody term -> m [value] -evaluatePackageBody body = localModuleTable (<> packageModules body) - (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) - where evaluateEntryPoint (m, sym) = do - (_, v) <- require m - maybe (pure v) ((`call` []) <=< variable) sym +evaluatePackageBody body = withPrelude (packagePrelude body) $ + localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) + where + evaluateEntryPoint (m, sym) = do + (_, v) <- require m + maybe (pure v) ((`call` []) <=< variable) sym + withPrelude Nothing a = a + withPrelude (Just prelude) a = do + preludeEnv <- evaluateModule prelude *> getEnv + withDefaultEnvironment preludeEnv a -- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package. pushOrigin :: ( Effectful m diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 3864a4426..4e577d2bd 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -18,6 +18,7 @@ newtype Version = Version { versionString :: String } data PackageBody term = PackageBody { packageModules :: ModuleTable [Module term] + , packagePrelude :: Maybe (Module term) , packageEntryPoints :: ModuleTable (Maybe Name) } deriving (Eq, Functor, Ord, Show) @@ -30,11 +31,12 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -fromModules :: [Module term] -> PackageBody term -fromModules [] = PackageBody mempty mempty -fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath (moduleInfo m)) - -fromModulesWithEntryPoint :: [Module term] -> FilePath -> PackageBody term -fromModulesWithEntryPoint ms path = PackageBody (ModuleTable.fromModules ms) entryPoints - where entryPoints = ModuleTable.singleton path Nothing - +fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> [Module term] -> Package term +fromModules name version prelude = Package (PackageInfo name version) . go prelude + where + go :: Maybe (Module term) -> [Module term] -> PackageBody term + go p [] = PackageBody mempty p mempty + go p (m:ms) = PackageBody (ModuleTable.fromModules (m : ms)) p entryPoints + where + entryPoints = ModuleTable.singleton path Nothing + path = modulePath (moduleInfo m) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 76154b5ed..c828b3be3 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -8,6 +8,7 @@ module Semantic.CLI import Prologue import Data.Language +import Data.File import Data.List (intercalate) import Data.List.Split (splitWhen) import Data.Version (showVersion) @@ -35,7 +36,7 @@ runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Languag runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> (FilePath, Maybe Language) -> Task.TaskEff ByteString -runGraph (SomeRenderer r) rootDir = Semantic.graph rootDir r <=< Task.readBlob +runGraph (SomeRenderer r) rootDir (p, l) = Semantic.graph rootDir r (File p l) -- | A parser for the application's command-line arguments. -- diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 5f6eb2e9a..af717019b 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -4,11 +4,10 @@ module Semantic.Graph where import qualified Analysis.Abstract.ImportGraph as Abstract import qualified Data.Abstract.Evaluatable as Analysis import Data.Abstract.FreeVariables -import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package import qualified Control.Exception as Exc import Data.Abstract.Module -import Data.Blob +import Data.File import Data.Term import qualified Data.Syntax as Syntax import Data.Abstract.Value (Value) @@ -20,7 +19,6 @@ import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables import Analysis.Abstract.Evaluating import Analysis.Abstract.Quiet -import Data.List (intercalate) import Data.ByteString.Char8 as BC (pack) import Data.Output import Parsing.Parser @@ -34,32 +32,32 @@ import System.FilePath.Posix graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => Maybe FilePath -> GraphRenderer output - -> Blob + -> File -> Eff effs ByteString -graph maybeRootDir renderer Blob{..} +graph root renderer file@File{..} | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser - (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do - let rootDir = fromMaybe (takeDirectory blobPath) maybeRootDir - paths <- filter (/= blobPath) <$> listFiles rootDir exts - prelude <- traverse (parseModule parser Nothing) preludePath - let name = packageName blobPath - package <- parsePackage name parser rootDir (blobPath : paths) - - let modulePaths = intercalate "," $ ModuleTable.keys (packageModules (packageBody package)) - writeLog Info ("Package " <> show name <> " loaded") [("paths", modulePaths)] - - graphImports prelude package >>= case renderer of + (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> fileLanguage = do + parsePackage parser exts preludePath root file >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput DOTGraphRenderer -> pure . Abstract.renderImportGraph - | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) - - where packageName = name . BC.pack . dropExtensions . takeFileName - + | otherwise = throwError (SomeException (NoLanguageForBlob filePath)) -- | Parse a list of files into a 'Package'. -parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term) -parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths +parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs + => Parser term -- ^ A parser + -> [String] -- ^ List of file extensions + -> Maybe FilePath -- ^ Prelude (optional). + -> Maybe FilePath -- ^ Root directory of this package. If you pass 'Nothing' it will be the parent directory of the entry point. + -> File -- ^ Entry point + -> Eff effs (Package term) +parsePackage parser exts preludePath root File{..} = do + paths <- filter (/= filePath) <$> listFiles rootDir exts + prelude <- traverse (parseModule parser Nothing) preludePath + Package.fromModules (nameFromRoot rootDir) Nothing prelude <$> parseModules parser rootDir paths + where + rootDir = fromMaybe (takeDirectory filePath) root + nameFromRoot = name . BC.pack . dropExtensions . takeFileName -- | Parse a list of files into 'Module's. parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term] @@ -93,8 +91,8 @@ graphImports :: ( , Members '[Exc SomeException, Task] effs , term ~ Term (Union syntax) ann ) - => Maybe (Module term) -> Package term -> Eff effs Abstract.ImportGraph -graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelude (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package))) >>= extractGraph + => Package term -> Eff effs Abstract.ImportGraph +graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph where asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value -> Package term @@ -104,8 +102,3 @@ graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelu extractGraph result = case result of (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) - - withPrelude Nothing a = a - withPrelude (Just prelude) a = do - preludeEnv <- Analysis.evaluateModule prelude *> Analysis.getEnv - Analysis.withDefaultEnvironment preludeEnv a From 7ef36ea18f1f5b3b8b4422b5e9b116b7e391e9b4 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 13:30:17 -0700 Subject: [PATCH 04/23] Slowly start to rework reading, parsing of a project to a package --- src/Data/File.hs | 29 +++++++++++++++ src/Data/Language.hs | 11 ++++++ src/Parsing/Parser.hs | 7 ++-- src/Semantic/CLI.hs | 20 +++++------ src/Semantic/Graph.hs | 41 ++++++++++------------ src/Semantic/IO.hs | 63 +++++++++++++++++++++------------ src/Semantic/Task.hs | 1 + src/Semantic/Util.hs | 82 ++++++++++++++++++++++--------------------- 8 files changed, 156 insertions(+), 98 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 373da99da..9679d7697 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -1,6 +1,10 @@ module Data.File where +import Prologue import Data.Language +import qualified Data.List.NonEmpty as NonEmpty +import Data.ByteString.Char8 as BC (pack) +import System.FilePath.Posix data File = File { filePath :: FilePath @@ -8,3 +12,28 @@ data File = File } deriving (Eq, Ord, Show) +fileDetectingLanguage :: FilePath -> File +fileDetectingLanguage path = File path (languageForFilePath path) + where languageForFilePath = languageForType . takeExtension + +data Project = Project + { projectEntryPoints :: NonEmpty File + , projectRootDir :: FilePath + , projectFiles :: [File] + } + deriving (Eq, Ord, Show) + +projectAllFiles :: Project -> [File] +projectAllFiles Project{..} = NonEmpty.toList projectEntryPoints <> projectFiles + +projectName :: Project -> ByteString +projectName = BC.pack . dropExtensions . takeFileName . projectRootDir + +projectLanguage :: Project -> Maybe Language +projectLanguage = fileLanguage. projectEntryPoint + +projectEntryPoint :: Project -> File +projectEntryPoint = NonEmpty.head . projectEntryPoints + +projectExtensions :: Project -> [String] +projectExtensions = extensionsForLanguage . projectLanguage diff --git a/src/Data/Language.hs b/src/Data/Language.hs index e3df96d84..471c5a43c 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -32,3 +32,14 @@ languageForType mediaType = case mediaType of ".php" -> Just PHP ".phpt" -> Just PHP _ -> Nothing + +extensionsForLanguage :: Maybe Language -> [String] +extensionsForLanguage Nothing = [] +extensionsForLanguage (Just language) = case language of + Go -> ["go"] + JavaScript -> ["js"] + PHP -> ["php"] + Python -> ["py"] + Ruby -> ["rb"] + TypeScript -> ["ts", "tsx", "d.tsx"] + _ -> [] diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 5341fe54a..c324cc58b 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -25,6 +25,7 @@ import Data.Language import Data.Record import qualified Data.Syntax as Syntax import Data.Term +import Data.File import Foreign.Ptr import qualified GHC.TypeLits as TypeLevel import qualified Language.Go.Assignment as Go @@ -55,7 +56,7 @@ data SomeAnalysisParser typeclasses ann where , ApplyAll' typeclasses fs) => Parser (Term (Union fs) ann) -- ^ A parser. -> [String] -- ^ List of valid file extensions to be used for module resolution. - -> Maybe String -- ^ Maybe path to prelude. + -> Maybe File -- ^ Maybe path to prelude. -> SomeAnalysisParser typeclasses ann -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. @@ -71,8 +72,8 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax someAnalysisParser _ Go = SomeAnalysisParser goParser ["go"] Nothing someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser ["js"] Nothing someAnalysisParser _ PHP = SomeAnalysisParser phpParser ["php"] Nothing -someAnalysisParser _ Python = SomeAnalysisParser pythonParser ["py"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term)))) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser ["rb"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term)))) +someAnalysisParser _ Python = SomeAnalysisParser pythonParser ["py"] $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser ["rb"] $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser ["ts", "tsx", "d.tsx"] Nothing someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index c828b3be3..1a18ae58c 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -7,10 +7,10 @@ module Semantic.CLI ) where import Prologue -import Data.Language import Data.File import Data.List (intercalate) import Data.List.Split (splitWhen) +import qualified Data.List.NonEmpty as NonEmpty import Data.Version (showVersion) import Development.GitRev import Options.Applicative @@ -29,14 +29,14 @@ import Text.Read main :: IO () main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions -runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.TaskEff ByteString +runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs -runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString +runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> (FilePath, Maybe Language) -> Task.TaskEff ByteString -runGraph (SomeRenderer r) rootDir (p, l) = Semantic.graph rootDir r (File p l) +runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString +runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir -- | A parser for the application's command-line arguments. -- @@ -95,14 +95,14 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <$> ( flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") ) - <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY")) - <*> argument filePathReader (metavar "ENTRY_FILE") + <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to first entry file's directory." <> metavar "DIRECTORY")) + <*> NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)")) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | Just lang <- readMaybe a -> Right (b, Just lang) - | Just lang <- readMaybe b -> Right (a, Just lang) - [path] -> Right (path, languageForFilePath path) + [a, b] | Just lang <- readMaybe a -> Right (File b (Just lang)) + | Just lang <- readMaybe b -> Right (File a (Just lang)) + [path] -> Right (File path (languageForFilePath path)) _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE") optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index af717019b..b6ac17bdf 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -30,43 +30,38 @@ import Semantic.Task import System.FilePath.Posix graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) - => Maybe FilePath - -> GraphRenderer output - -> File + => GraphRenderer output + -> Project -> Eff effs ByteString -graph root renderer file@File{..} +graph renderer project | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser - (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> fileLanguage = do - parsePackage parser exts preludePath root file >>= graphImports >>= case renderer of + (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do + parsePackage parser project preludePath >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput DOTGraphRenderer -> pure . Abstract.renderImportGraph - | otherwise = throwError (SomeException (NoLanguageForBlob filePath)) + | otherwise = throwError (SomeException (NoLanguageForBlob (filePath (projectEntryPoint project)))) -- | Parse a list of files into a 'Package'. parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -- ^ A parser - -> [String] -- ^ List of file extensions - -> Maybe FilePath -- ^ Prelude (optional). - -> Maybe FilePath -- ^ Root directory of this package. If you pass 'Nothing' it will be the parent directory of the entry point. - -> File -- ^ Entry point + -> Project + -> Maybe File -- ^ Prelude (optional). -> Eff effs (Package term) -parsePackage parser exts preludePath root File{..} = do - paths <- filter (/= filePath) <$> listFiles rootDir exts - prelude <- traverse (parseModule parser Nothing) preludePath - Package.fromModules (nameFromRoot rootDir) Nothing prelude <$> parseModules parser rootDir paths - where - rootDir = fromMaybe (takeDirectory filePath) root - nameFromRoot = name . BC.pack . dropExtensions . takeFileName +parsePackage parser project@Project{..} preludeFile = do + prelude <- traverse (parseModule parser Nothing) preludeFile + Package.fromModules n Nothing prelude <$> parseModules parser project + where n = name (projectName project) -- | Parse a list of files into 'Module's. -parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term] -parseModules parser rootDir paths = distributeFor paths (WrapTask . parseModule parser (Just rootDir)) +parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term] +parseModules parser project@Project{..} = distributeFor allFiles (WrapTask . parseModule parser (Just projectRootDir)) + where allFiles = projectAllFiles project -- | Parse a file into a 'Module'. -parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term) -parseModule parser rootDir path = do - blob <- readBlob (path, IO.languageForFilePath path) +parseModule :: Members '[Files, 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 diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index c7a3140c0..ab5c6710b 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -9,8 +9,9 @@ module Semantic.IO , readBlobsFromDir , languageForFilePath , NoLanguageForBlob(..) -, listFiles , readBlob +, readProject +, listFiles , readBlobs , readBlobPairs , writeToOutput @@ -27,10 +28,12 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.Blob as Blob import Data.Bool +import Data.File import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Language import Data.Source +import qualified Data.List.NonEmpty as NonEmpty import Prelude hiding (readFile) import Prologue hiding (MonadError (..), fail) import System.Directory (doesDirectoryExist) @@ -41,16 +44,16 @@ import System.IO (Handle) import Text.Read -- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob) -readFile "/dev/null" _ = pure Nothing -readFile path language = do +readFile :: forall m. MonadIO m => File -> m (Maybe Blob.Blob) +readFile (File "/dev/null" _) = pure Nothing +readFile (File path language) = do raw <- liftIO (Just <$> B.readFile path) pure $ Blob.sourceBlob path language . fromBytes <$> raw -readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair +readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair readFilePair a b = do - before <- uncurry readFile a - after <- uncurry readFile b + before <- readFile a + after <- readFile b case (before, after) of (Just a, Nothing) -> pure (Join (This a)) (Nothing, Just b) -> pure (Join (That b)) @@ -77,19 +80,30 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readBlobFromPath :: MonadIO m => (FilePath, Maybe Language) -> m Blob.Blob +readBlobFromPath :: MonadIO m => File -> m Blob.Blob readBlobFromPath file = do - maybeFile <- uncurry readFile file + maybeFile <- readFile file maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile -readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob] -readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files +readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob] +readBlobsFromPaths files = catMaybes <$> traverse readFile files + +readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> m Project +readProjectFromPaths root files = do + paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) + pure $ Project files rootDir (toFile <$> paths) + where + toFile path = File path (languageForFilePath path) + exts = extensionsForLanguage (fileLanguage entryPoint) + entryPoint = NonEmpty.head files + entryPointPath = filePath entryPoint + rootDir = fromMaybe (takeDirectory entryPointPath) root readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) - let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths - blobs <- traverse (uncurry readFile) paths' + let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths + blobs <- traverse readFile paths' pure (catMaybes blobs) readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a @@ -136,18 +150,21 @@ instance FromJSON BlobPair where newtype NoLanguageForBlob = NoLanguageForBlob FilePath deriving (Eq, Exception, Ord, Show, Typeable) +readBlob :: Member Files effs => File -> Eff effs Blob.Blob +readBlob = send . ReadBlob + +readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project +readProject dir files = send (ReadProject dir files) + listFiles :: Member Files effs => FilePath -> [String] -> Eff effs [FilePath] listFiles dir exts = send (ListFiles dir exts) -readBlob :: Member Files effs => (FilePath, Maybe Language) -> Eff effs Blob.Blob -readBlob = send . ReadBlob - -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob] +readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob] readBlobs = send . ReadBlobs -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: Member Files effs => Either Handle [Both (FilePath, Maybe Language)] -> Eff effs [Blob.BlobPair] +readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair] readBlobPairs = send . ReadBlobPairs -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. @@ -157,21 +174,23 @@ writeToOutput path = send . WriteToOutput path -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's. data Files out where - ReadBlob :: (FilePath, Maybe Language) -> Files Blob.Blob + ReadBlob :: File -> Files Blob.Blob + ReadProject :: Maybe FilePath -> NonEmpty File -> Files Project ListFiles :: FilePath -> [String] -> Files [FilePath] - ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob] - ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair] + ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] + ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a runFiles = interpret $ \ files -> case files of ReadBlob path -> rethrowing (readBlobFromPath path) + ReadProject dir files -> rethrowing (readProjectFromPaths dir files) ListFiles directory exts -> liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) directory) ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle) - ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) + ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 44c9aac96..b855eb4ef 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -8,6 +8,7 @@ module Semantic.Task , Differ -- * I/O , IO.listFiles +, IO.readProject , IO.readBlob , IO.readBlobs , IO.readBlobPairs diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 63fe69bcd..82cfe46bd 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -23,6 +23,7 @@ import Data.Abstract.Package as Package import Data.Abstract.Type import Data.Abstract.Value import Data.Blob +import Data.File import Data.Diff import Data.Range import Data.Record @@ -81,7 +82,8 @@ import qualified Language.TypeScript.Assignment as TypeScript -- typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path -- JavaScript -evalJavaScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) . evaluatePackageBody <$> parseProject typescriptParser ["js"] path +-- evalJavaScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) . evaluatePackageBody <$> parseProject typescriptParser ["js"] path +-- evalJavaScriptProject path = parsePackage Nothing typescriptParser (takeDirectory path) -- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) @@ -89,45 +91,45 @@ type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Q type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) --- TODO: Remove this by exporting EvaluatingEffects -runEvaluating :: forall term effects a. - ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects - , Corecursive term - , Recursive term ) - => Evaluating Precise term (Value Precise) effects a - -> Final effects a -runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise)) +-- -- TODO: Remove this by exporting EvaluatingEffects +-- runEvaluating :: forall term effects a. +-- ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects +-- , Corecursive term +-- , Recursive term ) +-- => Evaluating Precise term (Value Precise) effects a +-- -> Final effects a +-- runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise)) +-- +-- parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term) +-- parsePrelude parser = do +-- let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) +-- parseFile parser Nothing preludePath -parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term) -parsePrelude parser = do - let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) - parseFile parser Nothing preludePath - -parseProject :: Parser term - -> [Prelude.String] - -> FilePath - -> IO (PackageBody term) -parseProject parser exts entryPoint = do - let rootDir = takeDirectory entryPoint - paths <- getPaths exts rootDir - modules <- parseFiles parser rootDir paths - pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint) - -withPrelude prelude a = do - preludeEnv <- evaluateModule prelude *> getEnv - withDefaultEnvironment preludeEnv a - -getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts) - - --- Read and parse a file. -parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) -parseFile parser rootDir path = runTask $ do - blob <- file path - moduleForBlob rootDir blob <$> parse parser blob - -parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] -parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) +-- parseProject :: Parser term +-- -> [Prelude.String] +-- -> FilePath +-- -> IO (PackageBody term) +-- parseProject parser exts entryPoint = do +-- let rootDir = takeDirectory entryPoint +-- paths <- getPaths exts rootDir +-- modules <- parseFiles parser rootDir paths +-- pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint) +-- +-- withPrelude prelude a = do +-- preludeEnv <- evaluateModule prelude *> getEnv +-- withDefaultEnvironment preludeEnv a +-- +-- getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts) +-- +-- +-- -- Read and parse a file. +-- parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) +-- parseFile parser rootDir path = runTask $ do +-- blob <- file path +-- moduleForBlob rootDir blob <$> parse parser blob +-- +-- parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] +-- parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) -- parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term) -- parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir @@ -135,7 +137,7 @@ parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) -- Read a file from the filesystem into a Blob. file :: MonadIO m => FilePath -> m Blob -file path = fromJust <$> IO.readFile path (languageForFilePath path) +file path = fromJust <$> IO.readFile (fileDetectingLanguage path) -- Diff helpers diffWithParser :: ( HasField fields Data.Span.Span From 01703684cc5c9ec82390ae3d264eadf97d6a4669 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 14:15:23 -0700 Subject: [PATCH 05/23] Remove evaluateModules --- src/Data/Abstract/Evaluatable.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 66866d84d..f04262c8b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -10,7 +10,6 @@ module Data.Abstract.Evaluatable , variable , evaluateTerm , evaluateModule -, evaluateModules , evaluatePackage , evaluatePackageBody , throwLoadError @@ -244,12 +243,6 @@ evaluateModule :: MonadEvaluatable location term value m -> m value evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) --- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: MonadEvaluatable location term value m - => [Module term] - -> m value -evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules - -- | Evaluate a given package. evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From 402172c0fb5dc4ef045a9f2bc52780ae7752b121 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 14:15:51 -0700 Subject: [PATCH 06/23] Don't carry extensions in here --- src/Data/File.hs | 4 ++++ src/Parsing/Parser.hs | 13 ++++++------- src/Semantic/Graph.hs | 32 +++++++++++++++----------------- 3 files changed, 25 insertions(+), 24 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 9679d7697..581699a0e 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -2,6 +2,7 @@ module Data.File where import Prologue import Data.Language +import Data.String import qualified Data.List.NonEmpty as NonEmpty import Data.ByteString.Char8 as BC (pack) import System.FilePath.Posix @@ -12,6 +13,9 @@ data File = File } deriving (Eq, Ord, Show) +instance IsString File where + fromString = fileDetectingLanguage + fileDetectingLanguage :: FilePath -> File fileDetectingLanguage path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index c324cc58b..687d3aef4 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -55,7 +55,6 @@ data SomeAnalysisParser typeclasses ann where SomeAnalysisParser :: ( Member Syntax.Identifier fs , ApplyAll' typeclasses fs) => Parser (Term (Union fs) ann) -- ^ A parser. - -> [String] -- ^ List of valid file extensions to be used for module resolution. -> Maybe File -- ^ Maybe path to prelude. -> SomeAnalysisParser typeclasses ann @@ -69,12 +68,12 @@ 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 ["go"] Nothing -someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser ["js"] Nothing -someAnalysisParser _ PHP = SomeAnalysisParser phpParser ["php"] Nothing -someAnalysisParser _ Python = SomeAnalysisParser pythonParser ["py"] $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser ["rb"] $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) -someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser ["ts", "tsx", "d.tsx"] Nothing +someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing +someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser Nothing +someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing +someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) +someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b6ac17bdf..d349360f7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -19,24 +19,21 @@ import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables import Analysis.Abstract.Evaluating import Analysis.Abstract.Quiet -import Data.ByteString.Char8 as BC (pack) import Data.Output import Parsing.Parser import Prologue hiding (MonadError (..)) import Rendering.Renderer import Semantic.IO (Files, NoLanguageForBlob (..)) -import qualified Semantic.IO as IO import Semantic.Task -import System.FilePath.Posix graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => GraphRenderer output -> Project -> Eff effs ByteString graph renderer project - | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser + | Just (SomeAnalysisParser parser prelude) <- someAnalysisParser (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do - parsePackage parser project preludePath >>= graphImports >>= case renderer of + parsePackage parser project prelude >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput DOTGraphRenderer -> pure . Abstract.renderImportGraph @@ -44,25 +41,26 @@ graph renderer project -- | Parse a list of files into a 'Package'. parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs - => Parser term -- ^ A parser - -> Project + => Parser term -- ^ A parser. + -> Project -- ^ Project to parse into a package. -> Maybe File -- ^ Prelude (optional). -> Eff effs (Package term) parsePackage parser project@Project{..} preludeFile = do prelude <- traverse (parseModule parser Nothing) preludeFile Package.fromModules n Nothing prelude <$> parseModules parser project - where n = name (projectName project) + where + n = name (projectName project) --- | Parse a list of files into 'Module's. -parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term] -parseModules parser project@Project{..} = distributeFor allFiles (WrapTask . parseModule parser (Just projectRootDir)) - where allFiles = projectAllFiles project + -- | Parse all files in a project into 'Module's. + parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term] + parseModules parser project@Project{..} = distributeFor allFiles (WrapTask . parseModule parser (Just projectRootDir)) + where allFiles = projectAllFiles project --- | Parse a file into a 'Module'. -parseModule :: Members '[Files, 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 + -- | Parse a file into a 'Module'. + parseModule :: Members '[Files, 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 type ImportGraphAnalysis term effects value = From bdeb67d29f47dcbbc59246d6653846c377a2aefa Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 14:15:55 -0700 Subject: [PATCH 07/23] WIP Utils --- src/Semantic/Util.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 82cfe46bd..ca8a142ea 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,6 +1,7 @@ -- MonoLocalBinds is to silence a warning about a simplifiable constraint. {-# LANGUAGE DataKinds, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Semantic.Util where import Analysis.Abstract.BadVariables @@ -39,6 +40,7 @@ import Prologue import Semantic.Diff (diffTermPair) import Semantic.IO as IO import Semantic.Task +import Semantic.Graph import qualified Semantic.Task as Task import System.FilePath.Posix @@ -87,6 +89,21 @@ import qualified Language.TypeScript.Assignment as TypeScript -- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) +-- evalProject path = runTask $ do +-- project <- readProject Nothing (fileDetectingLanguage path :| []) +-- let Just (SomeAnalysisParser parser prelude) = someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project +-- package <- parsePackage parser project prelude +-- analyze @(EvaluatingWithHoles TypeScript.Term) (evaluatePackage package) + -- where + -- asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value + -- -> Package term + -- -> ImportGraphAnalysis term effs value + -- asAnalysisForTypeOfPackage = const + + -- + -- package <- parsePackage typescriptParser project prelude + -- runAnalysis @(EvaluatingWithHoles TypeScript.Term) package + type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From 0d05742b2419fb1112e6e2bd32cf369eb4c70876 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 14:16:03 -0700 Subject: [PATCH 08/23] Remove listFiles --- src/Semantic/IO.hs | 18 +++++------------- src/Semantic/Task.hs | 3 +-- 2 files changed, 6 insertions(+), 15 deletions(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index ab5c6710b..c9f588622 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -11,7 +11,6 @@ module Semantic.IO , NoLanguageForBlob(..) , readBlob , readProject -, listFiles , readBlobs , readBlobPairs , writeToOutput @@ -153,12 +152,6 @@ newtype NoLanguageForBlob = NoLanguageForBlob FilePath readBlob :: Member Files effs => File -> Eff effs Blob.Blob readBlob = send . ReadBlob -readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project -readProject dir files = send (ReadProject dir files) - -listFiles :: Member Files effs => FilePath -> [String] -> Eff effs [FilePath] -listFiles dir exts = send (ListFiles dir exts) - -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob] readBlobs = send . ReadBlobs @@ -167,6 +160,9 @@ readBlobs = send . ReadBlobs readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair] readBlobPairs = send . ReadBlobPairs +readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project +readProject dir files = send (ReadProject dir files) + -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs () writeToOutput path = send . WriteToOutput path @@ -175,24 +171,20 @@ writeToOutput path = send . WriteToOutput path -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's. data Files out where ReadBlob :: File -> Files Blob.Blob - ReadProject :: Maybe FilePath -> NonEmpty File -> Files Project - ListFiles :: FilePath -> [String] -> Files [FilePath] - ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] + ReadProject :: Maybe FilePath -> NonEmpty File -> Files Project WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a runFiles = interpret $ \ files -> case files of ReadBlob path -> rethrowing (readBlobFromPath path) - ReadProject dir files -> rethrowing (readProjectFromPaths dir files) - ListFiles directory exts -> liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) directory) - ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle) ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) + ReadProject dir files -> rethrowing (readProjectFromPaths dir files) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b855eb4ef..a9ff0360c 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -7,11 +7,10 @@ module Semantic.Task , RAlgebra , Differ -- * I/O -, IO.listFiles -, IO.readProject , IO.readBlob , IO.readBlobs , IO.readBlobPairs +, IO.readProject , IO.writeToOutput -- * Telemetry , writeLog From 44e5dbb4fb7518e035a8f82a2523ce887f36bca0 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:27:31 -0700 Subject: [PATCH 09/23] Don't do this --- src/Data/File.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 581699a0e..0ff7793e1 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -13,9 +13,6 @@ data File = File } deriving (Eq, Ord, Show) -instance IsString File where - fromString = fileDetectingLanguage - fileDetectingLanguage :: FilePath -> File fileDetectingLanguage path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension From 24aa9debbbe9257fba1e7b615c4636f8cef8a266 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:27:44 -0700 Subject: [PATCH 10/23] Swap up order here --- src/Semantic/Graph.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index d349360f7..a7ed90fb1 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -33,7 +33,7 @@ graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Tele graph renderer project | Just (SomeAnalysisParser parser prelude) <- someAnalysisParser (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do - parsePackage parser project prelude >>= graphImports >>= case renderer of + parsePackage parser prelude project >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput DOTGraphRenderer -> pure . Abstract.renderImportGraph @@ -42,10 +42,10 @@ graph renderer project -- | Parse a list of files into a 'Package'. parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -- ^ A parser. - -> Project -- ^ Project to parse into a package. -> Maybe File -- ^ Prelude (optional). + -> Project -- ^ Project to parse into a package. -> Eff effs (Package term) -parsePackage parser project@Project{..} preludeFile = do +parsePackage parser preludeFile project@Project{..} = do prelude <- traverse (parseModule parser Nothing) preludeFile Package.fromModules n Nothing prelude <$> parseModules parser project where From 7c2a8a464ec56b072047cf676af1f97d7bf11ac9 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:27:53 -0700 Subject: [PATCH 11/23] Couple of test fixes --- test/Semantic/IO/Spec.hs | 2 +- test/SpecHelpers.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index ce64b7eaf..87cc64c88 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -12,7 +12,7 @@ spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - Just blob <- readFile "semantic.cabal" Nothing + Just blob <- readFile (File "semantic.cabal" Nothing) blobPath blob `shouldBe` "semantic.cabal" it "throws for absent files" $ do diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 77b1dc008..de1e4390c 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -17,6 +17,7 @@ import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Blob as X +import Data.File as X import Data.Functor.Listable as X import Data.Language as X import Data.Output as X @@ -55,11 +56,11 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: FilePath -> IO ByteString -parseFilePath path = (fromJust <$> IO.readFile path (IO.languageForFilePath path)) >>= runTask . parseBlob SExpressionTermRenderer +parseFilePath path = (fromJust <$> IO.readFile (fileDetectingLanguage path)) >>= runTask . parseBlob SExpressionTermRenderer -- | Read two files to a BlobPair. readFilePair :: Both FilePath -> IO BlobPair -readFilePair paths = let paths' = fmap (\p -> (p, IO.languageForFilePath p)) paths in +readFilePair paths = let paths' = fmap fileDetectingLanguage paths in runBothWith IO.readFilePair paths' readFileVerbatim :: FilePath -> IO Verbatim From 625020a416912dba0098e06c5828d336391e9391 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:28:09 -0700 Subject: [PATCH 12/23] Fighting with the types in Util --- src/Semantic/Util.hs | 43 +++++++++++++++++++++++++++++++++---------- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca8a142ea..2cdff8e5e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -47,6 +47,7 @@ import System.FilePath.Posix import qualified Language.Go.Assignment as Go import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby +import qualified Language.PHP.Assignment as PHP import qualified Language.TypeScript.Assignment as TypeScript -- -- Ruby @@ -89,21 +90,43 @@ import qualified Language.TypeScript.Assignment as TypeScript -- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) +evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser path +evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser path +evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser path +evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser path +evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser path +evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing (fileDetectingLanguage path :| []) >>= parsePackage parser Nothing) +-- evaluateProject path = evaluatePackage <$> runTask (do +-- project <- readProject Nothing (fileDetectingLanguage path :| []) +-- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of +-- Just (SomeAnalysisParser parser prelude) -> parsePackage parser prelude project +-- Nothing -> undefined) + + +-- evalJavaScriptProject = evalProject @(JustEvaluating TypeScript.Term) + +-- evalProject :: forall term effects a. +-- ( Members '[Exc SomeException, Task] effects +-- , Members (EvaluatingEffects (Located Precise term) term (Value (Located Precise term))) effects +-- ) +-- evalProject :: FilePath -> IO (Final effs (JustEvaluating term effects a)) +-- evalProject :: forall effs a. FilePath -> IO (Final effs a) +-- evalProject :: forall m location term value effects. ( MonadAnalysis location term value m, Members (EvaluatingEffects location term value) effects ) +-- => FilePath -> IO (Final effects value) -- evalProject path = runTask $ do -- project <- readProject Nothing (fileDetectingLanguage path :| []) --- let Just (SomeAnalysisParser parser prelude) = someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project --- package <- parsePackage parser project prelude --- analyze @(EvaluatingWithHoles TypeScript.Term) (evaluatePackage package) - -- where - -- asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value - -- -> Package term - -- -> ImportGraphAnalysis term effs value - -- asAnalysisForTypeOfPackage = const - - -- +-- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of +-- Just (SomeAnalysisParser parser prelude) -> do +-- package <- parsePackage typescriptParser prelude project +-- analyze (SomeAnalysis (evaluatePackage @(JustEvaluating TypeScript.Term) package)) +-- Nothing -> Task.throwError (SomeException (NoLanguageForBlob (filePath (projectEntryPoint project)))) +-- +-- -- package <- parsePackage typescriptParser project prelude -- runAnalysis @(EvaluatingWithHoles TypeScript.Term) package + +type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From 9d7a85cbda47aa8ca24e865f2643f2f85e5784d1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:28:18 -0700 Subject: [PATCH 13/23] Expose EvaluatingEffects --- src/Analysis/Abstract/Evaluating.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6afe6b223..be77d7a1b 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,6 +2,7 @@ module Analysis.Abstract.Evaluating ( Evaluating , EvaluatingState(..) +, EvaluatingEffects , State ) where From f96db32268d12a2bbd94258ae019c4d8fcebc82a Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:30:06 -0700 Subject: [PATCH 14/23] Few more test fixes --- src/Semantic/Util.hs | 14 +++++++------- test/Semantic/IO/Spec.hs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 2cdff8e5e..61ceb01df 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -161,13 +161,13 @@ type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) -- -- getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts) -- --- --- -- Read and parse a file. --- parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) --- parseFile parser rootDir path = runTask $ do --- blob <- file path --- moduleForBlob rootDir blob <$> parse parser blob --- + +-- Read and parse a file. +parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) +parseFile parser rootDir path = runTask $ do + blob <- file path + moduleForBlob rootDir blob <$> parse parser blob + -- parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] -- parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 87cc64c88..d8536123a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -16,7 +16,7 @@ spec = parallel $ do blobPath blob `shouldBe` "semantic.cabal" it "throws for absent files" $ do - readFile "this file should not exist" Nothing `shouldThrow` anyIOException + readFile (File "this file should not exist" Nothing) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" From e2722ea7e989d77edc266364d3d7b1f142974a0e Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 20 Apr 2018 16:34:37 -0700 Subject: [PATCH 15/23] Construct File(s) here too --- test/Semantic/CLI/Spec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 182d6b2dd..7f370c5e9 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -26,17 +26,17 @@ spec = parallel $ do when (actual /= expected) $ print actual actual `shouldBe` expected -parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)] +parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [File], ByteString)] parseFixtures = [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput) - , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby)], symbolsOutput) - , (SomeRenderer TagsTermRenderer, Right [("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby)], tagsOutput) + , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput) + , (SomeRenderer TagsTermRenderer, Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput) ] - where pathMode = Right [("test/fixtures/ruby/corpus/and-or.A.rb", Just Ruby)] - pathMode' = Right [("test/fixtures/ruby/corpus/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/corpus/and-or.B.rb", Just Ruby)] + where pathMode = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)] + pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)] sExpressionParseTreeOutput = "(Program\n (LowAnd\n (Send\n (Identifier))\n (Send\n (Identifier))))\n" jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n" @@ -46,13 +46,13 @@ parseFixtures = tagsOutput = "[{\"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\"}]\n" -diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)] +diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both File], ByteString)] diffFixtures = [ (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput) , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput) , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput) ] - where pathMode = Right [both ("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/corpus/method-declaration.B.rb", Just Ruby)] + where pathMode = Right [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" (Just Ruby))] jsonOutput = "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\"}}]}\n" sExpressionOutput = "(Program\n (Method\n (Empty)\n { (Identifier)\n ->(Identifier) }\n {+(Identifier)+}\n (\n {+(Send\n {+(Identifier)+})+})))\n" From 773eef65ed36684e2268b5560a6c1e10833007e4 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 21 Apr 2018 07:22:01 -0700 Subject: [PATCH 16/23] Rename constructor to just file --- src/Data/File.hs | 11 +++++------ src/Semantic/Util.hs | 15 ++++++++------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 0ff7793e1..a2cd61063 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -1,10 +1,9 @@ module Data.File where -import Prologue -import Data.Language -import Data.String -import qualified Data.List.NonEmpty as NonEmpty import Data.ByteString.Char8 as BC (pack) +import Data.Language +import qualified Data.List.NonEmpty as NonEmpty +import Prologue import System.FilePath.Posix data File = File @@ -13,8 +12,8 @@ data File = File } deriving (Eq, Ord, Show) -fileDetectingLanguage :: FilePath -> File -fileDetectingLanguage path = File path (languageForFilePath path) +file :: FilePath -> File +file path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension data Project = Project diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 61ceb01df..3ea3d8a71 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -91,13 +91,13 @@ import qualified Language.TypeScript.Assignment as TypeScript -- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser path -evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser path +evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser path evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser path evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser path evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser path -evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing (fileDetectingLanguage path :| []) >>= parsePackage parser Nothing) +evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser Nothing) -- evaluateProject path = evaluatePackage <$> runTask (do --- project <- readProject Nothing (fileDetectingLanguage path :| []) +-- project <- readProject Nothing (file path :| []) -- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of -- Just (SomeAnalysisParser parser prelude) -> parsePackage parser prelude project -- Nothing -> undefined) @@ -114,7 +114,7 @@ evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing ( -- evalProject :: forall m location term value effects. ( MonadAnalysis location term value m, Members (EvaluatingEffects location term value) effects ) -- => FilePath -> IO (Final effects value) -- evalProject path = runTask $ do --- project <- readProject Nothing (fileDetectingLanguage path :| []) +-- project <- readProject Nothing (file path :| []) -- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of -- Just (SomeAnalysisParser parser prelude) -> do -- package <- parsePackage typescriptParser prelude project @@ -126,6 +126,7 @@ evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing ( -- runAnalysis @(EvaluatingWithHoles TypeScript.Term) package +type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) @@ -165,7 +166,7 @@ type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) -- Read and parse a file. parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) parseFile parser rootDir path = runTask $ do - blob <- file path + blob <- readBlob (file path) moduleForBlob rootDir blob <$> parse parser blob -- parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] @@ -176,8 +177,8 @@ parseFile parser rootDir path = runTask $ do -- Read a file from the filesystem into a Blob. -file :: MonadIO m => FilePath -> m Blob -file path = fromJust <$> IO.readFile (fileDetectingLanguage path) +-- readBlob :: MonadIO m => FilePath -> m Blob +-- readBlob path = fromJust <$> IO.readFile (file path) -- Diff helpers diffWithParser :: ( HasField fields Data.Span.Span From 45386ed1cecefbd42bc1629ad136acd4ac51ddbd Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 21 Apr 2018 07:22:09 -0700 Subject: [PATCH 17/23] Get the tests compiling again --- test/Analysis/Go/Spec.hs | 4 ++++ test/Analysis/PHP/Spec.hs | 4 ++++ test/Analysis/Python/Spec.hs | 3 +++ test/Analysis/Ruby/Spec.hs | 4 +++- test/Analysis/TypeScript/Spec.hs | 4 +++- test/SpecHelpers.hs | 8 ++++++-- 6 files changed, 23 insertions(+), 4 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 471580ba8..f218dd086 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.Go.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import qualified Language.Go.Assignment as Go + import SpecHelpers @@ -28,3 +31,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index b78a66952..a89014de5 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.PHP.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import qualified Language.PHP.Assignment as PHP + import SpecHelpers @@ -32,3 +35,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index fa368af4f..8f48c1777 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedLists, OverloadedStrings #-} module Analysis.Python.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import Data.Abstract.Value import Data.Map +import qualified Language.Python.Assignment as Python import SpecHelpers @@ -48,3 +50,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index ce590b749..65f830197 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -2,12 +2,13 @@ module Analysis.Ruby.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..)) +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import Data.Abstract.Value import Control.Monad.Effect (SomeExc(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map import Data.Map.Monoidal as Map +import qualified Language.Ruby.Assignment as Ruby import SpecHelpers @@ -57,3 +58,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) + evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index c455a78d2..8b5abbc36 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.TypeScript.Spec (spec) where -import SpecHelpers import Data.Abstract.Evaluatable +import qualified Language.TypeScript.Assignment as TypeScript +import SpecHelpers spec :: Spec spec = parallel $ do @@ -35,3 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) + evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser path diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index de1e4390c..e7c024341 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -49,6 +49,8 @@ import Test.LeanCheck as X import qualified Data.ByteString as B import qualified Semantic.IO as IO import Data.Abstract.Value +import Analysis.Abstract.Evaluating +-- import qualified Language.Ruby.Assignment as Ruby -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString @@ -56,16 +58,18 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: FilePath -> IO ByteString -parseFilePath path = (fromJust <$> IO.readFile (fileDetectingLanguage path)) >>= runTask . parseBlob SExpressionTermRenderer +parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= runTask . parseBlob SExpressionTermRenderer -- | Read two files to a BlobPair. readFilePair :: Both FilePath -> IO BlobPair -readFilePair paths = let paths' = fmap fileDetectingLanguage paths in +readFilePair paths = let paths' = fmap file paths in runBothWith IO.readFilePair paths' readFileVerbatim :: FilePath -> IO Verbatim readFileVerbatim = fmap verbatim . B.readFile +type TestEvaluating term = Evaluating Precise term (Value Precise) + ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise From 10d13cd424592b12572bd1d3214480251ea5a5d4 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sun, 22 Apr 2018 07:47:59 -0700 Subject: [PATCH 18/23] Bring preludes back for testing, clean up Util --- src/Semantic/Util.hs | 133 ++++--------------------------- test/Analysis/Go/Spec.hs | 2 +- test/Analysis/PHP/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/Ruby/Spec.hs | 4 +- test/Analysis/TypeScript/Spec.hs | 2 +- test/Matching/Go/Spec.hs | 4 +- test/SpecHelpers.hs | 2 +- 8 files changed, 23 insertions(+), 128 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 3ea3d8a71..21f386ea7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -28,6 +28,7 @@ import Data.File import Data.Diff import Data.Range import Data.Record +import qualified Data.Language as Language import Data.Span import Data.Term import Diffing.Algorithm @@ -50,135 +51,29 @@ import qualified Language.Ruby.Assignment as Ruby import qualified Language.PHP.Assignment as PHP import qualified Language.TypeScript.Assignment as TypeScript --- -- Ruby --- evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"] --- evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path)) --- --- evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path)) --- --- evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths --- --- evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths --- --- -- Go --- evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path --- evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path --- --- typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path --- --- -- Python --- evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"] --- evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path)) --- evalPythonProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))))))) <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluatePackageBody <$> parseProject pythonParser ["py"] path)) --- --- typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path --- tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path --- evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path --- --- -- PHP --- evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path --- evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path --- --- -- TypeScript --- evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path --- evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path --- typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path --- JavaScript --- evalJavaScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) . evaluatePackageBody <$> parseProject typescriptParser ["js"] path --- evalJavaScriptProject path = parsePackage Nothing typescriptParser (takeDirectory path) - --- runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) - -evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser path -evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser path -evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser path -evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser path -evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser path -evaluateProject parser path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser Nothing) --- evaluateProject path = evaluatePackage <$> runTask (do --- project <- readProject Nothing (file path :| []) --- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of --- Just (SomeAnalysisParser parser prelude) -> parsePackage parser prelude project --- Nothing -> undefined) - - --- evalJavaScriptProject = evalProject @(JustEvaluating TypeScript.Term) - --- evalProject :: forall term effects a. --- ( Members '[Exc SomeException, Task] effects --- , Members (EvaluatingEffects (Located Precise term) term (Value (Located Precise term))) effects --- ) --- evalProject :: FilePath -> IO (Final effs (JustEvaluating term effects a)) --- evalProject :: forall effs a. FilePath -> IO (Final effs a) --- evalProject :: forall m location term value effects. ( MonadAnalysis location term value m, Members (EvaluatingEffects location term value) effects ) --- => FilePath -> IO (Final effects value) --- evalProject path = runTask $ do --- project <- readProject Nothing (file path :| []) --- case someAnalysisParser (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project of --- Just (SomeAnalysisParser parser prelude) -> do --- package <- parsePackage typescriptParser prelude project --- analyze (SomeAnalysis (evaluatePackage @(JustEvaluating TypeScript.Term) package)) --- Nothing -> Task.throwError (SomeException (NoLanguageForBlob (filePath (projectEntryPoint project)))) --- --- - -- package <- parsePackage typescriptParser project prelude - -- runAnalysis @(EvaluatingWithHoles TypeScript.Term) package - - -type TestEvaluating term = Evaluating Precise term (Value Precise) +-- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) +evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path +evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path +evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path +evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path +evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path +evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude) --- -- TODO: Remove this by exporting EvaluatingEffects --- runEvaluating :: forall term effects a. --- ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects --- , Corecursive term --- , Recursive term ) --- => Evaluating Precise term (Value Precise) effects a --- -> Final effects a --- runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise)) --- --- parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term) --- parsePrelude parser = do --- let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) --- parseFile parser Nothing preludePath - --- parseProject :: Parser term --- -> [Prelude.String] --- -> FilePath --- -> IO (PackageBody term) --- parseProject parser exts entryPoint = do --- let rootDir = takeDirectory entryPoint --- paths <- getPaths exts rootDir --- modules <- parseFiles parser rootDir paths --- pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint) --- --- withPrelude prelude a = do --- preludeEnv <- evaluateModule prelude *> getEnv --- withDefaultEnvironment preludeEnv a --- --- getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts) --- +rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby) +pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python) -- Read and parse a file. -parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) -parseFile parser rootDir path = runTask $ do - blob <- readBlob (file path) - moduleForBlob rootDir blob <$> parse parser blob - --- parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] --- parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) - --- parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term) --- parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir - +parseFile :: Parser term -> FilePath -> IO term +parseFile parser = runTask . (parse parser <=< readBlob . file) -- Read a file from the filesystem into a Blob. --- readBlob :: MonadIO m => FilePath -> m Blob --- readBlob path = fromJust <$> IO.readFile (file path) +blob :: FilePath -> IO Blob +blob = runTask . readBlob . file -- Diff helpers diffWithParser :: ( HasField fields Data.Span.Span diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index f218dd086..a46f0ab7e 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -31,4 +31,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser path + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index a89014de5..31f9361d0 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -35,4 +35,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser path + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 8f48c1777..32831a209 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -50,4 +50,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) - evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser path + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 65f830197..038e4b425 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -2,7 +2,7 @@ module Analysis.Ruby.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import Data.Abstract.Evaluatable import Data.Abstract.Value import Control.Monad.Effect (SomeExc(..)) import Data.List.NonEmpty (NonEmpty(..)) @@ -58,4 +58,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) - evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser path + evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 8b5abbc36..efc891e47 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -36,4 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser path + evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Nothing path diff --git a/test/Matching/Go/Spec.hs b/test/Matching/Go/Spec.hs index 496e4a1ac..5bb99d182 100644 --- a/test/Matching/Go/Spec.hs +++ b/test/Matching/Go/Spec.hs @@ -30,11 +30,11 @@ loopMatcher = target <* go where spec :: Spec spec = describe "matching/go" $ do it "extracts integers" $ do - parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/integers.go" + parsed <- parseFile goParser "test/fixtures/go/matching/integers.go" let matched = runMatcher integerMatcher parsed sort matched `shouldBe` ["1", "2", "3"] it "counts for loops" $ do - parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/for.go" + parsed <- parseFile goParser "test/fixtures/go/matching/for.go" let matched = runMatcher @[] loopMatcher parsed length matched `shouldBe` 2 diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index e7c024341..e9cc3b47c 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -9,6 +9,7 @@ module SpecHelpers ( , ns , verbatim , Verbatim(..) +, TestEvaluating , ) where import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) @@ -50,7 +51,6 @@ import qualified Data.ByteString as B import qualified Semantic.IO as IO import Data.Abstract.Value import Analysis.Abstract.Evaluating --- import qualified Language.Ruby.Assignment as Ruby -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString From 373004bdf6526bd3e8847f41b48e0955c9827731 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sun, 22 Apr 2018 07:48:04 -0700 Subject: [PATCH 19/23] Fix docs --- .ghci | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.ghci b/.ghci index d8fd64b8d..112816cb1 100644 --- a/.ghci +++ b/.ghci @@ -25,7 +25,7 @@ assignmentExample lang = case lang of "Markdown" -> mk "md" "markdown" "JSON" -> mk "json" "json" _ -> mk "" "" - where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util") + where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util") :} :undef assignment :def assignment assignmentExample From a75c75b21429ed49566a101179e485f4f90c7261 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sun, 22 Apr 2018 07:49:19 -0700 Subject: [PATCH 20/23] Lint --- src/Semantic/IO.hs | 2 +- src/Semantic/Util.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index c9f588622..ae3f74ff9 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TupleSections, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO ( readFile , readFilePair diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 21f386ea7..6112c8f69 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -16,7 +16,7 @@ import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Abstract.Analysis import Control.Monad.IO.Class -import Data.Abstract.Evaluatable hiding (head) +import Data.Abstract.Evaluatable import Data.Abstract.Address import Data.Abstract.Located import Data.Abstract.Module From 9547f497592b32026484e416d4521fc8eeb5ffa1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 11:41:24 -0700 Subject: [PATCH 21/23] Don't need this (yet) --- src/Analysis/Abstract/Evaluating.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 7a3b6f262..944228e45 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.Evaluating ( Evaluating , EvaluatingState(..) -, EvaluatingEffects , State ) where From 56f7d6d168a6d77220123b403a2aec4c08938b86 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 11:41:31 -0700 Subject: [PATCH 22/23] Remove unused imports --- src/Semantic/Util.hs | 74 ++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 41 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 6112c8f69..ef382b0ba 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,54 +1,43 @@ -- MonoLocalBinds is to silence a warning about a simplifiable constraint. {-# LANGUAGE DataKinds, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} module Semantic.Util where -import Analysis.Abstract.BadVariables -import Analysis.Abstract.BadModuleResolutions -import Analysis.Abstract.BadValues -import Analysis.Abstract.Caching -import Analysis.Abstract.Quiet -import Analysis.Abstract.Dead -import Analysis.Abstract.Evaluating as X -import Analysis.Abstract.ImportGraph -import Analysis.Abstract.Tracing -import Analysis.Declaration -import Control.Abstract.Analysis -import Control.Monad.IO.Class -import Data.Abstract.Evaluatable -import Data.Abstract.Address -import Data.Abstract.Located -import Data.Abstract.Module -import Data.Abstract.Package as Package -import Data.Abstract.Type -import Data.Abstract.Value -import Data.Blob -import Data.File -import Data.Diff -import Data.Range -import Data.Record +import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadValues +import Analysis.Abstract.BadVariables +import Analysis.Abstract.Evaluating as X +import Analysis.Abstract.ImportGraph +import Analysis.Abstract.Quiet +import Analysis.Declaration +import Control.Abstract.Analysis +import Data.Abstract.Address +import Data.Abstract.Evaluatable +import Data.Abstract.Located +import Data.Abstract.Value +import Data.Blob +import Data.Diff +import Data.File import qualified Data.Language as Language -import Data.Span -import Data.Term -import Diffing.Algorithm -import Diffing.Interpreter -import System.FilePath.Glob +import Data.Range +import Data.Record +import Data.Span +import Data.Term +import Diffing.Algorithm +import Diffing.Interpreter import qualified GHC.TypeLits as TypeLevel -import Language.Preluded -import Parsing.Parser -import Prologue -import Semantic.Diff (diffTermPair) -import Semantic.IO as IO -import Semantic.Task -import Semantic.Graph -import qualified Semantic.Task as Task -import System.FilePath.Posix +import Language.Preluded +import Parsing.Parser +import Prologue +import Semantic.Diff (diffTermPair) +import Semantic.Graph +import Semantic.IO as IO +import Semantic.Task import qualified Language.Go.Assignment as Go +import qualified Language.PHP.Assignment as PHP import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby -import qualified Language.PHP.Assignment as PHP import qualified Language.TypeScript.Assignment as TypeScript @@ -62,11 +51,14 @@ evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProje evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path -evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude) rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby) pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python) +-- Evaluate a project, starting at a single entrypoint. +evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude) + + -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO term parseFile parser = runTask . (parse parser <=< readBlob . file) From 79d05e820aeade6f24ea088d51b5c3edb35f4816 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 11:44:56 -0700 Subject: [PATCH 23/23] Remove comment --- src/Semantic/Graph.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c46cc0cc0..89e63e218 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -93,6 +93,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - -- (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph (Right (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _)))))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))