From d568c9cf134a8c4f2a2e8806d70b3cce6339d9d6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 20 Apr 2018 19:03:30 -0400 Subject: [PATCH 01/39] Add graphPackage function --- src/Semantic/Graph.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3d3eeb73e..d64da9dfb 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -16,6 +16,9 @@ import Rendering.Renderer import Semantic.IO (Files, NoLanguageForBlob (..)) import Semantic.Task import System.FilePath.Posix +import qualified Data.ByteString.Char8 as B +import Path +import Data.Record graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => Maybe FilePath @@ -41,3 +44,23 @@ graph maybeRootDir renderer Blob{..} | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) where packageName = name . BC.pack . dropExtensions . takeFileName + +graphPackage :: (Show (Record location), Ord (Record location), Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) + => GraphRenderer output + -> Path Abs Dir + -> SomeAnalysisParser '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ] (Record location) + -> Eff effs ByteString +graphPackage renderer rootDir (SomeAnalysisParser parser exts preludePath) = do + paths <- listFiles (toFilePath rootDir) exts + prelude <- traverse (parseModule parser Nothing) preludePath + let packageName = name . B.pack . toFilePath $ dirname rootDir + package <- parsePackage packageName parser (toFilePath rootDir) paths + + let modulePaths = intercalate "," $ ModuleTable.keys (packageModules (packageBody package)) + writeLog Info ("Package " <> show packageName <> " loaded") [("paths", modulePaths)] + + graphImports prelude package >>= case renderer of + JSONGraphRenderer -> pure . toOutput + DOTGraphRenderer -> pure . Abstract.renderImportGraph + + where packageName = name . BC.pack . dropExtensions . takeFileName From 85995afb99e2c7dea3afce741ff14a51227216a0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 20 Apr 2018 19:14:25 -0400 Subject: [PATCH 02/39] Parse a language --- src/Semantic/CLI.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index cf7dd3dfc..55f75e187 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -16,7 +16,7 @@ import qualified Paths_semantic as Library (version) import Prologue import Rendering.Renderer import qualified Semantic.Diff as Semantic (diffBlobPairs) -import qualified Semantic.Graph as Semantic (graph) +import qualified Semantic.Graph as Semantic (graph, graphPackage) import Semantic.IO (languageForFilePath) import qualified Semantic.Log as Log import qualified Semantic.Parse as Semantic (parseBlobs) @@ -88,9 +88,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphArgumentsParser = do renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") - rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY")) - entryPoint <- argument filePathReader (metavar "ENTRY_FILE") - pure $ runGraph renderer rootDir entryPoint + rootDir <- strOption (long "root" <> help "Root directory of project." <> metavar "DIRECTORY") + language <- strOption (long "language" <> help "The language of the project." <> metavar "LANGUAGE") + pure $ Semantic.graphPackage renderer rootDir language filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of From ce0b95bb793fcf6a6de72070271fe639ab31c0cf Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 20 Apr 2018 19:14:50 -0400 Subject: [PATCH 03/39] Take a Maybe Language in graphPackage --- src/Semantic/Graph.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index d64da9dfb..4fb0867b6 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -19,6 +19,7 @@ import System.FilePath.Posix import qualified Data.ByteString.Char8 as B import Path import Data.Record +import Data.Language graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => Maybe FilePath @@ -45,12 +46,14 @@ graph maybeRootDir renderer Blob{..} where packageName = name . BC.pack . dropExtensions . takeFileName -graphPackage :: (Show (Record location), Ord (Record location), Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) +graphPackage :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => GraphRenderer output -> Path Abs Dir - -> SomeAnalysisParser '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ] (Record location) + -> Maybe Language -> Eff effs ByteString -graphPackage renderer rootDir (SomeAnalysisParser parser exts preludePath) = do +graphPackage renderer rootDir blobLanguage + | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser + (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do paths <- listFiles (toFilePath rootDir) exts prelude <- traverse (parseModule parser Nothing) preludePath let packageName = name . B.pack . toFilePath $ dirname rootDir From 123d830ef03533b7dc7fffb9afd0ce015c978e36 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 23 Apr 2018 15:22:00 -0400 Subject: [PATCH 04/39] Parse a directory given a language --- semantic.cabal | 4 ++++ src/Semantic/CLI.hs | 20 +++++++++++++++----- src/Semantic/Graph.hs | 8 ++++---- 3 files changed, 23 insertions(+), 9 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 1e359f98e..7b47a3067 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -168,6 +168,7 @@ library , directory , effects , filepath + , path , free , freer-cofreer , ghc-prim @@ -186,6 +187,8 @@ library , recursion-schemes , reducers , scientific + , safe-exceptions + , exceptions , semigroupoids , split , stm-chans @@ -267,6 +270,7 @@ test-suite test , comonad , effects , filepath + , path , free , Glob , haskell-tree-sitter diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 55f75e187..77a521deb 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -12,8 +12,10 @@ import Data.List.Split (splitWhen) import Data.Version (showVersion) import Development.GitRev import Options.Applicative +import Options.Applicative.Types (readerAsk) import qualified Paths_semantic as Library (version) -import Prologue +import Prologue hiding (catch) +import Control.Monad.Catch (MonadThrow(..)) import Rendering.Renderer import qualified Semantic.Diff as Semantic (diffBlobPairs) import qualified Semantic.Graph as Semantic (graph, graphPackage) @@ -23,7 +25,8 @@ import qualified Semantic.Parse as Semantic (parseBlobs) import qualified Semantic.Task as Task import System.IO (Handle, stdin, stdout) import Text.Read - +import Path +import Control.Monad.IO.Class main :: IO () main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions @@ -37,6 +40,12 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> (FilePath, Maybe Language) -> Task.TaskEff ByteString runGraph (SomeRenderer r) rootDir = Semantic.graph rootDir r <=< Task.readBlob +runGraphPackage :: SomeRenderer GraphRenderer -> Path Abs Dir -> Language -> Task.TaskEff ByteString +runGraphPackage (SomeRenderer r) = Semantic.graphPackage r + +instance MonadThrow ReadM where + throwM e = readerError (show e) + -- | A parser for the application's command-line arguments. -- -- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout. @@ -88,10 +97,11 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphArgumentsParser = do renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") - rootDir <- strOption (long "root" <> help "Root directory of project." <> metavar "DIRECTORY") - language <- strOption (long "language" <> help "The language of the project." <> metavar "LANGUAGE") - pure $ Semantic.graphPackage renderer rootDir language + rootDir <- argument absPathReader (metavar "DIRECTORY") + language <- argument (maybeReader readMaybe :: ReadM Language) (metavar "LANGUAGE") + pure $ runGraphPackage renderer rootDir language + absPathReader = readerAsk >>= parseAbsDir filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of [a, b] | Just lang <- readMaybe a -> Right (b, Just lang) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 4fb0867b6..fec016eeb 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -17,7 +17,7 @@ import Semantic.IO (Files, NoLanguageForBlob (..)) import Semantic.Task import System.FilePath.Posix import qualified Data.ByteString.Char8 as B -import Path +import Path import Data.Record import Data.Language @@ -49,11 +49,11 @@ graph maybeRootDir renderer Blob{..} graphPackage :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => GraphRenderer output -> Path Abs Dir - -> Maybe Language + -> Language -> Eff effs ByteString graphPackage renderer rootDir blobLanguage - | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser - (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do + | SomeAnalysisParser parser exts preludePath <- someAnalysisParser + (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) blobLanguage = do paths <- listFiles (toFilePath rootDir) exts prelude <- traverse (parseModule parser Nothing) preludePath let packageName = name . B.pack . toFilePath $ dirname rootDir From d5b67c06135c6b8d3b4568367723a5bc1e940a03 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 13:18:52 -0700 Subject: [PATCH 05/39] Use a single NotFoundError instead of language specific ResolutionErrors --- src/Analysis/Abstract/BadModuleResolutions.hs | 3 +-- src/Data/Abstract/Evaluatable.hs | 14 ++++++-------- src/Language/Ruby/Syntax.hs | 5 +++-- src/Language/TypeScript/Syntax.hs | 5 +++-- 4 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 6e888ffec..0286d9eb9 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -29,7 +29,6 @@ instance ( Effectful m \yield error -> do traceM ("ResolutionError:" <> show error) case error of - (RubyError nameToResolve) -> yield nameToResolve - (TypeScriptError nameToResolve) -> yield nameToResolve) + (NotFoundError nameToResolve _) -> yield nameToResolve) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index bc2dc3679..efec9dd74 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -35,6 +35,7 @@ import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Origin (SomeOrigin, packageOrigin) import Data.Abstract.Package as Package +import Data.Language import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -69,17 +70,14 @@ deriving instance Eq value => Eq (ControlThrow value) -- | An error thrown when we can't resolve a module from a qualified name. data ResolutionError value resume where - RubyError :: String -> ResolutionError value ModulePath - TypeScriptError :: String -> ResolutionError value ModulePath + NotFoundError :: String -- ^ The path that was not found + -> Language -- ^ Language + -> ResolutionError value ModulePath deriving instance Eq (ResolutionError a b) deriving instance Show (ResolutionError a b) -instance Show1 (ResolutionError value) where - liftShowsPrec _ _ = showsPrec -instance Eq1 (ResolutionError value) where - liftEq _ (RubyError a) (RubyError b) = a == b - liftEq _ (TypeScriptError a) (TypeScriptError b) = a == b - liftEq _ _ _ = False +instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec +instance Eq1 (ResolutionError value) where liftEq _ (NotFoundError a l1) (NotFoundError b l2) = a == b && l1 == l2 -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError term value resume where diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index cea8d57a9..be3c03bd8 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -7,6 +7,7 @@ import Data.Abstract.Module (ModulePath) import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Path import qualified Data.ByteString.Char8 as BC +import qualified Data.Language as Language import Diffing.Algorithm import Prelude hiding (fail) import Prologue @@ -20,14 +21,14 @@ resolveRubyName :: forall value term location m. MonadEvaluatable location term resolveRubyName name = do let name' = cleanNameOrPath name modulePath <- resolve [name' <.> "rb"] - maybe (throwResumable @(ResolutionError value) $ RubyError name') pure modulePath + maybe (throwResumable @(ResolutionError value) $ NotFoundError name' Language.Ruby) pure modulePath -- load "/root/src/file.rb" resolveRubyPath :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] - maybe (throwResumable @(ResolutionError value) $ RubyError name') pure modulePath + maybe (throwResumable @(ResolutionError value) $ NotFoundError name' Language.Ruby) pure modulePath cleanNameOrPath :: ByteString -> String cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 7596f8d98..ff6a6dd2e 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -8,6 +8,7 @@ import Data.Abstract.Path import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B import Data.Abstract.Module (ModulePath, ModuleInfo(..)) +import qualified Data.Language as Language import Diffing.Algorithm import Prelude import Prologue @@ -49,7 +50,7 @@ resolveRelativePath relImportPath exts = do let path = joinPaths relRootDir relImportPath resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x)) where - notFound _ = throwResumable @(ResolutionError value) $ TypeScriptError relImportPath + notFound _ = throwResumable @(ResolutionError value) $ NotFoundError relImportPath Language.TypeScript -- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail. -- @@ -74,7 +75,7 @@ resolveNonRelativePath name exts = do Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs) | otherwise -> notFound (searched <> xs) Right m -> traceResolve name m $ pure m - notFound _ = throwResumable @(ResolutionError value) $ TypeScriptError name + notFound _ = throwResumable @(ResolutionError value) $ NotFoundError name Language.TypeScript resolveTSModule :: MonadEvaluatable location term value m => FilePath -> [String] -> m (Either [FilePath] ModulePath) resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths From fe7c64e7ed21c85d3a167ebf79d79a46508b2484 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 13:19:17 -0700 Subject: [PATCH 06/39] Allow graphing python by resuming when module resolution fails --- src/Language/Python/Syntax.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 245f06557..b34388e5d 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables #-} module Language.Python.Syntax where import Data.Abstract.Environment as Env @@ -8,7 +8,8 @@ import Data.Abstract.Module import Data.Align.Generic import qualified Data.ByteString.Char8 as BC import Data.Functor.Classes.Generic -import Data.List (intercalate) +import qualified Data.Language as Language +-- import Data.List (intercalate) import qualified Data.List.NonEmpty as NonEmpty import Data.Mergeable import Diffing.Algorithm @@ -51,7 +52,7 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J -- Subsequent imports of `parent.two` or `parent.three` will execute -- `parent/two/__init__.py` and -- `parent/three/__init__.py` respectively. -resolvePythonModules :: MonadEvaluatable location term value m => QualifiedName -> m (NonEmpty ModulePath) +resolvePythonModules :: forall value term location m. MonadEvaluatable location term value m => QualifiedName -> m (NonEmpty ModulePath) resolvePythonModules q = do relRootDir <- rootDir q <$> currentModule for (moduleNames q) $ \name -> do @@ -68,17 +69,17 @@ resolvePythonModules q = do moduleNames (RelativeQualifiedName x Nothing) = error $ "importing from '" <> show x <> "' is not implemented" moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths - notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs + -- notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs search rootDir x = do let path = normalise (rootDir normalise x) let searchPaths = [ path "__init__.py" , path <.> ".py" ] - resolve searchPaths >>= maybeFail (notFound searchPaths) - - friendlyName :: QualifiedName -> String - friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs) - friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn + modulePath <- resolve searchPaths -- >>= maybeFail (notFound searchPaths) + maybe (throwResumable @(ResolutionError value) $ NotFoundError path Language.Python) pure modulePath + -- friendlyName :: QualifiedName -> String + -- friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs) + -- friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn -- | Import declarations (symbols are added directly to the calling environment). From faae1a10202e35a191459db68a905b029abc5784 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 13:26:21 -0700 Subject: [PATCH 07/39] Track the paths we searched in resolution notfound errors --- src/Analysis/Abstract/BadModuleResolutions.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 7 ++++--- src/Language/Python/Syntax.hs | 6 +----- src/Language/Ruby/Syntax.hs | 7 ++++--- src/Language/TypeScript/Syntax.hs | 4 ++-- 5 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 0286d9eb9..bdac11ef8 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -29,6 +29,6 @@ instance ( Effectful m \yield error -> do traceM ("ResolutionError:" <> show error) case error of - (NotFoundError nameToResolve _) -> yield nameToResolve) + (NotFoundError nameToResolve _ _) -> yield nameToResolve) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index efec9dd74..ee76af9f2 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -70,14 +70,15 @@ deriving instance Eq value => Eq (ControlThrow value) -- | An error thrown when we can't resolve a module from a qualified name. data ResolutionError value resume where - NotFoundError :: String -- ^ The path that was not found - -> Language -- ^ Language + NotFoundError :: String -- ^ The path that was not found. + -> [String] -- ^ List of paths searched that shows where semantic looked for this module. + -> Language -- ^ Language. -> ResolutionError value ModulePath deriving instance Eq (ResolutionError a b) deriving instance Show (ResolutionError a b) instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec -instance Eq1 (ResolutionError value) where liftEq _ (NotFoundError a l1) (NotFoundError b l2) = a == b && l1 == l2 +instance Eq1 (ResolutionError value) where liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2 -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError term value resume where diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index b34388e5d..eb798e222 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -69,17 +69,13 @@ resolvePythonModules q = do moduleNames (RelativeQualifiedName x Nothing) = error $ "importing from '" <> show x <> "' is not implemented" moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths - -- notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs search rootDir x = do let path = normalise (rootDir normalise x) let searchPaths = [ path "__init__.py" , path <.> ".py" ] modulePath <- resolve searchPaths -- >>= maybeFail (notFound searchPaths) - maybe (throwResumable @(ResolutionError value) $ NotFoundError path Language.Python) pure modulePath - -- friendlyName :: QualifiedName -> String - -- friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs) - -- friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn + maybe (throwResumable @(ResolutionError value) $ NotFoundError path searchPaths Language.Python) pure modulePath -- | Import declarations (symbols are added directly to the calling environment). diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index be3c03bd8..654eedea9 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -20,15 +20,16 @@ import System.FilePath.Posix resolveRubyName :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath resolveRubyName name = do let name' = cleanNameOrPath name - modulePath <- resolve [name' <.> "rb"] - maybe (throwResumable @(ResolutionError value) $ NotFoundError name' Language.Ruby) pure modulePath + let paths = [name' <.> "rb"] + modulePath <- resolve paths + maybe (throwResumable @(ResolutionError value) $ NotFoundError name' paths Language.Ruby) pure modulePath -- load "/root/src/file.rb" resolveRubyPath :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] - maybe (throwResumable @(ResolutionError value) $ NotFoundError name' Language.Ruby) pure modulePath + maybe (throwResumable @(ResolutionError value) $ NotFoundError name' [name'] Language.Ruby) pure modulePath cleanNameOrPath :: ByteString -> String cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index ff6a6dd2e..989eed8f3 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -50,7 +50,7 @@ resolveRelativePath relImportPath exts = do let path = joinPaths relRootDir relImportPath resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x)) where - notFound _ = throwResumable @(ResolutionError value) $ NotFoundError relImportPath Language.TypeScript + notFound xs = throwResumable @(ResolutionError value) $ NotFoundError relImportPath xs Language.TypeScript -- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail. -- @@ -75,7 +75,7 @@ resolveNonRelativePath name exts = do Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs) | otherwise -> notFound (searched <> xs) Right m -> traceResolve name m $ pure m - notFound _ = throwResumable @(ResolutionError value) $ NotFoundError name Language.TypeScript + notFound xs = throwResumable @(ResolutionError value) $ NotFoundError name xs Language.TypeScript resolveTSModule :: MonadEvaluatable location term value m => FilePath -> [String] -> m (Either [FilePath] ModulePath) resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths From 7b0a17e27f154161101c10a332b6ab6c6f884bd8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 23 Apr 2018 16:31:25 -0400 Subject: [PATCH 08/39] Evaluate all files as entry points --- src/Data/Abstract/Package.hs | 10 ++++++---- src/Semantic/Util.hs | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 3864a4426..4cce1442c 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE TupleSections #-} module Data.Abstract.Package where import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable +import qualified Data.Map as Map type PackageName = Name @@ -32,9 +34,9 @@ data Package term = Package fromModules :: [Module term] -> PackageBody term fromModules [] = PackageBody mempty mempty -fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath (moduleInfo m)) +fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath . moduleInfo <$> (m : ms)) -fromModulesWithEntryPoint :: [Module term] -> FilePath -> PackageBody term -fromModulesWithEntryPoint ms path = PackageBody (ModuleTable.fromModules ms) entryPoints - where entryPoints = ModuleTable.singleton path Nothing +fromModulesWithEntryPoint :: [Module term] -> [FilePath] -> PackageBody term +fromModulesWithEntryPoint ms paths = PackageBody (ModuleTable.fromModules ms) entryPoints + where entryPoints = ModuleTable . Map.fromList $ (,Nothing) <$> paths diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca020feb0..95fb77957 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -111,7 +111,7 @@ parseProject parser exts entryPoint = do let rootDir = takeDirectory entryPoint paths <- getPaths exts rootDir modules <- parseFiles parser rootDir paths - pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint) + pure $ fromModulesWithEntryPoint modules [takeFileName entryPoint] withPrelude prelude a = do preludeEnv <- evaluateModule prelude *> getEnv From 2edf4a69951e5fe59da4d4774fa82fe06100610c Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 23 Apr 2018 16:31:57 -0400 Subject: [PATCH 09/39] Try catching ArithExceptions --- src/Data/Syntax/Expression.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 0ad4d5ad7..8abec2180 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,6 +6,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedF import Data.Fixed import Diffing.Algorithm import Prologue +import System.IO.Unsafe (unsafePerformIO) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } @@ -60,7 +61,7 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Arithmetic where - eval = traverse subtermValue >=> go where + eval = traverse subtermValue >=> (\term -> unsafePerformIO (catch (pure $ go term) (\(_ :: ArithException) -> pure hole))) where go (Plus a b) = liftNumeric2 add a b where add = liftReal (+) go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-) go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*) From 021786f0c411a4a00830c62078ff6fed93da3aef Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 14:09:38 -0700 Subject: [PATCH 10/39] Write out loaded project for debugging --- src/Semantic/Graph.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 89e63e218..56e7276b3 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -47,7 +47,8 @@ parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs -> Eff effs (Package term) parsePackage parser preludeFile project@Project{..} = do prelude <- traverse (parseModule parser Nothing) preludeFile - Package.fromModules n Nothing prelude <$> parseModules parser project + project <- parseModules parser project + trace ("project: " <> show project) $ pure (Package.fromModules n Nothing prelude project) where n = name (projectName project) From 4eba50244848ebf204c850d0a69a3dec29d8b4db Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 14:10:01 -0700 Subject: [PATCH 11/39] non-relative python imports just start looking at the root --- src/Language/Python/Syntax.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index eb798e222..3e968e7bb 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -59,7 +59,7 @@ resolvePythonModules q = do x <- search relRootDir name traceResolve name x $ pure x where - rootDir (QualifiedName _) ModuleInfo{..} = takeDirectory modulePath + rootDir (QualifiedName _) ModuleInfo{..} = mempty -- overall rootDir of the Package. rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory modulePath) where numDots = pred (length n) upDir n dir | n <= 0 = dir @@ -70,11 +70,12 @@ resolvePythonModules q = do moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths search rootDir x = do + traceM ("searching for " <> show x <> " in " <> show rootDir) let path = normalise (rootDir normalise x) let searchPaths = [ path "__init__.py" , path <.> ".py" ] - modulePath <- resolve searchPaths -- >>= maybeFail (notFound searchPaths) + modulePath <- resolve searchPaths maybe (throwResumable @(ResolutionError value) $ NotFoundError path searchPaths Language.Python) pure modulePath From 50e359c5a542b7e2ae94b589bcd9bee0615be602 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 15:46:56 -0700 Subject: [PATCH 12/39] Allow getting the current Package --- src/Analysis/Abstract/Evaluating.hs | 4 ++++ src/Control/Abstract/Evaluator.hs | 3 +++ 2 files changed, 7 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 944228e45..52b95228f 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -156,6 +156,10 @@ instance Members '[ Reader (ModuleTable [Module term]) o <- raise ask maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o + currentPackage = do + o <- raise ask + maybeFail "unable to get currentPackage" $ withSomeOrigin (originPackage @term) o + instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 3b88a9590..e509b840e 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -30,6 +30,7 @@ import Data.Abstract.FreeVariables import Data.Abstract.Heap import Data.Abstract.Module import Data.Abstract.ModuleTable +import Data.Abstract.Package import Data.Semigroup.Reducer import Prologue @@ -157,6 +158,8 @@ class Monad m => MonadModuleTable location term value m | m -> location, m -> te -- | Get the currently evaluating 'ModuleInfo'. currentModule :: m ModuleInfo + -- | Get the currently evaluating 'PackageInfo'. + currentPackage :: m PackageInfo -- | Update the evaluated module table. modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m () From c3bf5133c817f76706ae09962e2992efeffae455 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 15:47:23 -0700 Subject: [PATCH 13/39] Support Go import graphing a bit better --- src/Analysis/Abstract/BadModuleResolutions.hs | 3 +- src/Data/Abstract/Evaluatable.hs | 7 +- src/Language/Go/Syntax.hs | 70 ++++++++++++------- 3 files changed, 52 insertions(+), 28 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index bdac11ef8..be578159c 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -29,6 +29,7 @@ instance ( Effectful m \yield error -> do traceM ("ResolutionError:" <> show error) case error of - (NotFoundError nameToResolve _ _) -> yield nameToResolve) + (NotFoundError nameToResolve _ _) -> yield nameToResolve + (GoImportError pathToResolve) -> yield [pathToResolve]) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ee76af9f2..47d9a420b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -75,10 +75,15 @@ data ResolutionError value resume where -> Language -- ^ Language. -> ResolutionError value ModulePath + GoImportError :: FilePath -> ResolutionError value [ModulePath] + deriving instance Eq (ResolutionError a b) deriving instance Show (ResolutionError a b) instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec -instance Eq1 (ResolutionError value) where liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2 +instance Eq1 (ResolutionError value) where + liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2 + liftEq _ (GoImportError a) (GoImportError b) = a == b + liftEq _ _ _ = False -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError term value resume where diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 70283df16..e2bdf5fa0 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -1,32 +1,50 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-} module Language.Go.Syntax where -import Data.Abstract.Evaluatable hiding (Label) -import Data.Abstract.Module -import Data.Abstract.Path -import Data.Abstract.FreeVariables (name) -import Diffing.Algorithm -import qualified Data.ByteString.Char8 as BC +import Data.Abstract.Evaluatable hiding (Label) +import Data.Abstract.FreeVariables (Name (..), name) +import Data.Abstract.Module +import qualified Data.Abstract.Package as Package +import Data.Abstract.Path import qualified Data.ByteString as B -import System.FilePath.Posix -import Prologue +import qualified Data.ByteString.Char8 as BC +import qualified Data.Language as Language +import Diffing.Algorithm +import Prologue +import System.FilePath.Posix -newtype ImportPath = ImportPath { unPath :: FilePath } +data Relative = Relative | NonRelative + deriving (Eq, Ord, Show) + +data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative } deriving (Eq, Ord, Show) importPath :: ByteString -> ImportPath -importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) - where stripQuotes = B.filter (`B.notElem` "\'\"") +importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path) + where + stripQuotes = B.filter (`B.notElem` "\'\"") + pathType xs | not (B.null xs), BC.head xs == '.' = Relative + | otherwise = NonRelative defaultAlias :: ImportPath -> Name defaultAlias = name . BC.pack . takeFileName . unPath --- TODO: need to delineate between relative and absolute Go imports -resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [ModulePath] -resolveGoImport relImportPath = do +resolveGoImport :: forall value term location m. MonadEvaluatable location term value m => ImportPath -> m [ModulePath] +resolveGoImport (ImportPath path Relative) = do ModuleInfo{..} <- currentModule - let relRootDir = takeDirectory modulePath - listModulesInDir (joinPaths relRootDir relImportPath) + paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path) + case paths of + [] -> throwResumable @(ResolutionError value) $ GoImportError path + _ -> pure paths +resolveGoImport (ImportPath path NonRelative) = do + package <- BC.unpack . unName . Package.packageName <$> currentPackage + traceM ("attempting to resolve " <> show path <> " for package " <> package) + case splitDirectories path of + -- Import an absolute path that's defined in this package being analyized. + -- First two are source, next is package name, remaining are path to package + -- (e.g. github.com/golang/ listModulesInDir (joinPath xs) + _ -> throwResumable @(ResolutionError value) $ GoImportError path -- | Import declarations (symbols are added directly to the calling environment). -- @@ -39,10 +57,10 @@ instance Ord1 Import where liftCompare = genericLiftCompare instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where - eval (Import (ImportPath name) _) = do - paths <- resolveGoImport name + eval (Import importPath _) = do + paths <- resolveGoImport importPath for_ paths $ \path -> do - (importedEnv, _) <- traceResolve name path $ isolate (require path) + (importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path) modifyEnv (mappend importedEnv) unit @@ -58,12 +76,12 @@ instance Ord1 QualifiedImport where liftCompare = genericLiftCompare instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedImport where - eval (QualifiedImport (ImportPath name) aliasTerm) = do - paths <- resolveGoImport name + eval (QualifiedImport importPath aliasTerm) = do + paths <- resolveGoImport importPath alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) void $ letrec' alias $ \addr -> do for_ paths $ \path -> do - (importedEnv, _) <- traceResolve name path $ isolate (require path) + (importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path) modifyEnv (mappend importedEnv) makeNamespace alias addr [] @@ -78,9 +96,9 @@ instance Ord1 SideEffectImport where liftCompare = genericLiftCompare instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SideEffectImport where - eval (SideEffectImport (ImportPath name) _) = do - paths <- resolveGoImport name - for_ paths $ \path -> traceResolve name path $ isolate (require path) + eval (SideEffectImport importPath _) = do + paths <- resolveGoImport importPath + for_ paths $ \path -> traceResolve (unPath importPath) path $ isolate (require path) unit -- A composite literal in Go From 7f95a267206845be4b3a4c2e2294cf401ae13af5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 15:47:42 -0700 Subject: [PATCH 14/39] Remove this traceM --- src/Analysis/Abstract/ImportGraph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 1f44e71dc..4742cf050 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -76,8 +76,7 @@ instance ( Effectful m => MonadAnalysis (Located location term) term value (ImportGraphing m effects) where type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects) - analyzeTerm eval term@(In ann syntax) = do - traceShowM ann + analyzeTerm eval term@(In _ syntax) = do case prj syntax of Just (Syntax.Identifier name) -> do moduleInclusion (Variable (unName name)) From 0da504a6e3595c00d903a697d6b4016808cb65c0 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 15:47:56 -0700 Subject: [PATCH 15/39] Exclude vendor directory from globbing --- src/Semantic/IO.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index ae3f74ff9..ead2b373b 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -89,7 +89,7 @@ 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) + paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "[^vendor]**/*." <$> exts) rootDir) pure $ Project files rootDir (toFile <$> paths) where toFile path = File path (languageForFilePath path) From ba2d2b6eb3fe834e934f9c41ef60fe6d73fcf173 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 15:53:53 -0700 Subject: [PATCH 16/39] Changed the structure of ImportPath so I guess we diff differently --- .../go/corpus/single-import-declarations.diffB-A.txt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/fixtures/go/corpus/single-import-declarations.diffB-A.txt b/test/fixtures/go/corpus/single-import-declarations.diffB-A.txt index 4d5a864f7..6e0ecab67 100644 --- a/test/fixtures/go/corpus/single-import-declarations.diffB-A.txt +++ b/test/fixtures/go/corpus/single-import-declarations.diffB-A.txt @@ -5,10 +5,10 @@ {+(Identifier)+})+} {+(Import {+(TextElement)+})+} -{ (QualifiedImport - {-(Identifier)-}) -->(QualifiedImport - {+(Identifier)+}) } +{+(QualifiedImport + {+(Identifier)+})+} +{-(QualifiedImport + {-(Identifier)-})-} {-(Import {-(TextElement)-})-} {-(QualifiedImport From e4822db228b0c54ae82ba546d333831fdfd4fc32 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 23 Apr 2018 16:05:35 -0700 Subject: [PATCH 17/39] Don't need this --- src/Language/Go/Syntax.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index e2bdf5fa0..df87a6b1b 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -8,7 +8,6 @@ import qualified Data.Abstract.Package as Package import Data.Abstract.Path import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.Language as Language import Diffing.Algorithm import Prologue import System.FilePath.Posix From b087d7255c7f368d7a7a9e772900ebb59a74fe7b Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 23 Apr 2018 19:33:07 -0400 Subject: [PATCH 18/39] Revert "Try catching ArithExceptions" This reverts commit 93fb061a3b99b6f8ea7ea3bb50104233bf900e14. --- src/Data/Syntax/Expression.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 8abec2180..0ad4d5ad7 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,7 +6,6 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedF import Data.Fixed import Diffing.Algorithm import Prologue -import System.IO.Unsafe (unsafePerformIO) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } @@ -61,7 +60,7 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Arithmetic where - eval = traverse subtermValue >=> (\term -> unsafePerformIO (catch (pure $ go term) (\(_ :: ArithException) -> pure hole))) where + eval = traverse subtermValue >=> go where go (Plus a b) = liftNumeric2 add a b where add = liftReal (+) go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-) go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*) From 3fb3097c96ef581fb51203d814c127b6573fabf0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 23 Apr 2018 19:47:13 -0400 Subject: [PATCH 19/39] back to using Maybe Language in File --- src/Data/File.hs | 7 +++++-- src/Parsing/Parser.hs | 4 ++-- src/Semantic/CLI.hs | 8 +++----- src/Semantic/IO.hs | 7 +++---- src/Semantic/Util.hs | 10 ++++++++-- test/Analysis/Go/Spec.hs | 3 ++- test/Analysis/PHP/Spec.hs | 3 ++- test/Analysis/Python/Spec.hs | 3 ++- test/Analysis/Ruby/Spec.hs | 3 ++- test/Analysis/TypeScript/Spec.hs | 3 ++- 10 files changed, 31 insertions(+), 20 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 05e1149b9..89c51c39f 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -2,13 +2,12 @@ module Data.File where 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 { filePath :: FilePath - , fileLanguage :: Language + , fileLanguage :: Maybe Language } deriving (Eq, Ord, Show) @@ -19,6 +18,10 @@ data Project = Project } deriving (Eq, Ord, Show) +file :: FilePath -> File +file path = File path (languageForFilePath path) + where languageForFilePath = languageForType . takeExtension + projectName :: Project -> ByteString projectName = BC.pack . dropExtensions . takeFileName . projectRootDir diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 24529909b..687d3aef4 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -71,8 +71,8 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax 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))) Python) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Ruby) +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/CLI.hs b/src/Semantic/CLI.hs index 10947f138..918a4b758 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -7,13 +7,12 @@ module Semantic.CLI ) where import Data.File +import Data.Language import Data.List (intercalate) -import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split (splitWhen) import Data.Version (showVersion) import Development.GitRev import Options.Applicative -import Options.Applicative.Types (readerAsk) import qualified Paths_semantic as Library (version) import Prologue import Rendering.Renderer @@ -25,7 +24,6 @@ import qualified Semantic.Parse as Semantic (parseBlobs) import qualified Semantic.Task as Task import System.IO (Handle, stdin, stdout) import Text.Read -import Data.Language main :: IO () main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions @@ -90,7 +88,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphArgumentsParser = do renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") - rootDir <- argument (maybeReader readMaybe) (metavar "DIRECTORY") + rootDir <- argument (maybeReader readMaybe :: ReadM FilePath) (metavar "DIRECTORY") language <- argument (maybeReader readMaybe :: ReadM Language) (metavar "LANGUAGE") pure $ runGraph renderer rootDir language @@ -98,7 +96,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar parseFilePath arg = case splitWhen (== ':') arg of [a, b] | Just lang <- readMaybe a -> Right (File b lang) | Just lang <- readMaybe b -> Right (File a lang) - [path] -> maybe (Left $ "Cannot identify language for path:" <> path) (Right . File path) (languageForFilePath path) + [path] -> maybe (Left $ "Cannot identify language for path:" <> path) (Right . File path . Just) (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/IO.hs b/src/Semantic/IO.hs index 90c2fb1a6..631129a42 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -32,7 +32,6 @@ 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) @@ -47,7 +46,7 @@ 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 (Just language) . fromBytes <$> raw + pure $ Blob.sourceBlob path language . fromBytes <$> raw readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair readFilePair a b = do @@ -92,13 +91,13 @@ readProjectFromPaths rootDir lang = do paths <- liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) pure $ Project rootDir (toFile <$> paths) lang where - toFile path = File path lang + toFile path = File path (Just lang) exts = extensionsForLanguage lang 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 -> File p <$> languageForFilePath p) paths + let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths blobs <- traverse readFile paths' pure (catMaybes blobs) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 1840b56b4..159581543 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -52,12 +52,18 @@ evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path -rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Language.Ruby -pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Language.Python +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 lang prelude path = evaluatePackage <$> runTask (readProject path lang >>= parsePackage parser prelude) +parseFile :: Parser term -> FilePath -> IO term +parseFile parser = runTask . (parse parser <=< readBlob . file) + +blob :: FilePath -> IO Blob +blob = runTask . readBlob . file + -- Diff helpers diffWithParser :: ( HasField fields Data.Span.Span , HasField fields Range diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index a46f0ab7e..97f9672ba 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -3,6 +3,7 @@ module Analysis.Go.Spec (spec) where import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import qualified Language.Go.Assignment as Go +import qualified Data.Language as Language import SpecHelpers @@ -31,4 +32,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Nothing path + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 31f9361d0..e8a22cb9c 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -3,6 +3,7 @@ module Analysis.PHP.Spec (spec) where import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import qualified Language.PHP.Assignment as PHP +import qualified Data.Language as Language import SpecHelpers @@ -35,4 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 13e970321..39c9edaab 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import Data.Abstract.Value import Data.Map import qualified Language.Python.Assignment as Python +import qualified Data.Language as Language import SpecHelpers @@ -50,4 +51,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 pythonPrelude path + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index f02cb1d84..0049680b6 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Map import Data.Map.Monoidal as Map import qualified Language.Ruby.Assignment as Ruby +import qualified Data.Language as Language import SpecHelpers @@ -63,4 +64,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 rubyPrelude path + evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 528c24b7e..13c6e7f4d 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable import qualified Language.TypeScript.Assignment as TypeScript import Data.Abstract.Value as Value import Data.Abstract.Number as Number +import qualified Data.Language as Language import SpecHelpers @@ -42,4 +43,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Nothing path + evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path From 39cb75f04d717e2bc94c05243e8d2ca47d9be122 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 13:40:50 -0400 Subject: [PATCH 20/39] Add TypeError and make MonadValue over Type use it. --- src/Data/Abstract/Type.hs | 38 ++++++++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 3928f08c1..1c187a0e5 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE TypeFamilies, UndecidableInstances #-} -module Data.Abstract.Type where +{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-} +module Data.Abstract.Type + ( Type (..) + , TypeError (..) + , unify + ) where import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Align (alignWith) import Data.Semigroup.Reducer (Reducer) -import Prelude hiding (fail) -import Prologue +import Prelude +import Prologue hiding (TypeError) type TName = Int @@ -32,9 +36,14 @@ data Type -- TODO: À la carte representation of types. +data TypeError value resume where + NoValueError :: value -> TypeError value resume + NumOpError :: value -> value -> TypeError value resume + BitOpError :: value -> value -> TypeError value resume + UnificationError :: value -> value -> TypeError value resume -- | Unify two 'Type's. -unify :: MonadFail m => Type -> Type -> m Type +unify :: MonadResume (TypeError Type) m => Type -> Type -> m Type unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 unify a Null = pure a unify Null b = pure b @@ -44,7 +53,7 @@ unify a (Var _) = pure a unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs) unify t1 t2 | t1 == t2 = pure t2 - | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) + | otherwise = throwResumable (UnificationError t1 t2) instance Ord location => ValueRoots location Type where @@ -58,6 +67,7 @@ instance ( Alternative m , MonadFail m , MonadFresh m , MonadHeap location Type m + , MonadResume (TypeError Type) m , Reducer Type (Cell location Type) ) => MonadValue location Type m where @@ -91,28 +101,28 @@ instance ( Alternative m scopedEnvironment _ = pure mempty - asString _ = fail "Must evaluate to Value to use asString" - asPair _ = fail "Must evaluate to Value to use asPair" - asBool _ = fail "Must evaluate to Value to use asBool" + asString _ = throwResumable (NoValueError String) + asPair _ = throwResumable (NoValueError (Product [])) + asBool _ = throwResumable (NoValueError Bool) isHole ty = pure (ty == Hole) ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') - liftNumeric _ Float = pure Float + liftNumeric _ Float = pure Float liftNumeric _ Int = pure Int - liftNumeric _ _ = fail "Invalid type in unary numeric operation" + liftNumeric _ t = throwResumable (NumOpError t Hole) liftNumeric2 _ left right = case (left, right) of (Float, Int) -> pure Float (Int, Float) -> pure Float - _ -> unify left right + _ -> unify left right liftBitwise _ Int = pure Int - liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t) + liftBitwise _ t = throwResumable (BitOpError t Hole) liftBitwise2 _ Int Int = pure Int - liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)) + liftBitwise2 _ t1 t2 = throwResumable (BitOpError t1 t2) liftComparison (Concrete _) left right = case (left, right) of (Float, Int) -> pure Bool From 89c1403f896b9e28b2f0a45bf2ed9e6de645f67b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 14:12:28 -0400 Subject: [PATCH 21/39] WIP --- semantic.cabal | 1 + src/Analysis/Abstract/TypeChecking.hs | 31 +++++++++++++++++++++++++++ src/Data/Abstract/Type.hs | 2 +- src/Semantic/Util.hs | 5 +++++ 4 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 src/Analysis/Abstract/TypeChecking.hs diff --git a/semantic.cabal b/semantic.cabal index 108fded1a..5838694a9 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -26,6 +26,7 @@ library , Analysis.Abstract.ImportGraph , Analysis.Abstract.Quiet , Analysis.Abstract.Tracing + , Analysis.Abstract.TypeChecking , Analysis.CallGraph , Analysis.ConstructorName , Analysis.CyclomaticComplexity diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs new file mode 100644 index 000000000..190239f85 --- /dev/null +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Analysis.Abstract.TypeChecking +( TypeChecking +) where + +import Control.Abstract.Analysis +import Data.Abstract.Type +import Prologue hiding (TypeError) + +newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking (m effects a) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + +deriving instance MonadControl term (m effects) => MonadControl term (TypeChecking m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (TypeChecking m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (TypeChecking m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (TypeChecking m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (TypeChecking m effects) + +instance ( Effectful m + , MonadAnalysis location term Type (m effects) + , Member (Resumable (TypeError Type)) effects + , MonadValue location Type (TypeChecking m effects) + ) + => MonadAnalysis location term Type (TypeChecking m effects) where + + type Effects location term Type (TypeChecking m effects) = Resumable (TypeError Type) ': NonDet ': Effects location term Type (m effects) + + analyzeTerm eval term = resume @(TypeError Type) (liftAnalyze analyzeTerm eval term) ( + \yield err -> case err of + NoValueError v -> yield "") diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 1c187a0e5..5ad92227b 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,7 +10,7 @@ import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Align (alignWith) import Data.Semigroup.Reducer (Reducer) -import Prelude +import Prelude hiding (fail) import Prologue hiding (TypeError) type TName = Int diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ef382b0ba..a7e9e07e2 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -9,11 +9,13 @@ import Analysis.Abstract.BadVariables import Analysis.Abstract.Evaluating as X import Analysis.Abstract.ImportGraph import Analysis.Abstract.Quiet +import Analysis.Abstract.TypeChecking import Analysis.Declaration import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Located +import Data.Abstract.Type import Data.Abstract.Value import Data.Blob import Data.Diff @@ -45,6 +47,7 @@ import qualified Language.TypeScript.Assignment as TypeScript 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) +type Checking term = TypeChecking (EvaluatingWithHoles term) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path @@ -52,6 +55,8 @@ evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path +typecheckPythonFile path = runAnalysis @(Checking Python.Term) <$> evaluateProject pythonParser Nothing path + 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) From f4e0ab89774a704a90eab26ba632b6d80d996ca5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 15:35:50 -0400 Subject: [PATCH 22/39] Working implementation. --- src/Analysis/Abstract/TypeChecking.hs | 32 ++++++++++++++++++------ src/Data/Abstract/Type.hs | 36 +++++++++++++++++++-------- src/Semantic/Util.hs | 5 ++-- 3 files changed, 53 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index 190239f85..8e65b4079 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -18,14 +18,30 @@ deriving instance MonadModuleTable location term value (m effects) => MonadModul deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (TypeChecking m effects) instance ( Effectful m - , MonadAnalysis location term Type (m effects) - , Member (Resumable (TypeError Type)) effects - , MonadValue location Type (TypeChecking m effects) + , Alternative (m effects) + , MonadAnalysis location term value (m effects) + , Member (Resumable TypeError) effects + , Member NonDet effects + , Member Fail effects + , MonadValue location value (TypeChecking m effects) + , value ~ Type ) - => MonadAnalysis location term Type (TypeChecking m effects) where + => MonadAnalysis location term value (TypeChecking m effects) where - type Effects location term Type (TypeChecking m effects) = Resumable (TypeError Type) ': NonDet ': Effects location term Type (m effects) + type Effects location term value (TypeChecking m effects) = Resumable TypeError ': Effects location term value (m effects) - analyzeTerm eval term = resume @(TypeError Type) (liftAnalyze analyzeTerm eval term) ( - \yield err -> case err of - NoValueError v -> yield "") + analyzeTerm eval term = + resume @TypeError (liftAnalyze analyzeTerm eval term) ( + \yield err -> case err of + NoValueError _ a -> yield a + -- TODO: These should all yield both sides of the exception, + -- but something is mysteriously busted in the innards of typechecking, + -- so doing that just yields an empty list in the result type, which isn't + -- extraordinarily helpful. Better for now to just die with an error and + -- tackle this issue in a separate PR. + BitOpError{} -> throwResumable err + NumOpError{} -> throwResumable err + UnificationError{} -> throwResumable err + ) + + analyzeModule = liftAnalyze analyzeModule diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 5ad92227b..c37f46d13 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -36,14 +36,30 @@ data Type -- TODO: À la carte representation of types. -data TypeError value resume where - NoValueError :: value -> TypeError value resume - NumOpError :: value -> value -> TypeError value resume - BitOpError :: value -> value -> TypeError value resume - UnificationError :: value -> value -> TypeError value resume +-- TODO: specialize these to type +data TypeError resume where + NoValueError :: Type -> a -> TypeError a + NumOpError :: Type -> Type -> TypeError Type + BitOpError :: Type -> Type -> TypeError Type + UnificationError :: Type -> Type -> TypeError Type + +deriving instance Show resume => Show (TypeError resume) + +instance Show1 TypeError where + liftShowsPrec _ _ _ (NoValueError v _) = showString "NoValueError " . shows v + liftShowsPrec _ _ _ (NumOpError l r) = showString "NumOpError " . shows [l, r] + liftShowsPrec _ _ _ (BitOpError l r) = showString "BitOpError " . shows [l, r] + liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r] + +instance Eq1 TypeError where + liftEq _ (NoValueError a _) (NoValueError b _) = a == b + -- liftEq _ (NamespaceError a) (NamespaceError b) = a == b + -- liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b + -- liftEq _ (CallError a) (CallError b) = a == b + liftEq _ _ _ = False -- | Unify two 'Type's. -unify :: MonadResume (TypeError Type) m => Type -> Type -> m Type +unify :: MonadResume TypeError m => Type -> Type -> m Type unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 unify a Null = pure a unify Null b = pure b @@ -67,7 +83,7 @@ instance ( Alternative m , MonadFail m , MonadFresh m , MonadHeap location Type m - , MonadResume (TypeError Type) m + , MonadResume TypeError m , Reducer Type (Cell location Type) ) => MonadValue location Type m where @@ -101,9 +117,9 @@ instance ( Alternative m scopedEnvironment _ = pure mempty - asString _ = throwResumable (NoValueError String) - asPair _ = throwResumable (NoValueError (Product [])) - asBool _ = throwResumable (NoValueError Bool) + asString _ = throwResumable (NoValueError String "") + asPair _ = throwResumable (NoValueError (Product []) (Hole, Hole)) + asBool _ = throwResumable (NoValueError Bool True) isHole ty = pure (ty == Hole) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a7e9e07e2..2710111f5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -6,6 +6,7 @@ module Semantic.Util where import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables +import Analysis.Abstract.Caching import Analysis.Abstract.Evaluating as X import Analysis.Abstract.ImportGraph import Analysis.Abstract.Quiet @@ -47,7 +48,7 @@ import qualified Language.TypeScript.Assignment as TypeScript 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) -type Checking term = TypeChecking (EvaluatingWithHoles term) +type Checking term = Caching (TypeChecking (Evaluating Monovariant term Type)) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path @@ -55,7 +56,7 @@ evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path -typecheckPythonFile path = runAnalysis @(Checking Python.Term) <$> evaluateProject pythonParser Nothing path +typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Nothing path 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) From e82b4cca1de1a32b1ae26748f4703bb076238089 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 15:37:49 -0400 Subject: [PATCH 23/39] Cleanup. --- src/Data/Abstract/Type.hs | 11 +++++------ src/Semantic/Util.hs | 2 ++ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index c37f46d13..822d406c6 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -36,7 +36,6 @@ data Type -- TODO: À la carte representation of types. --- TODO: specialize these to type data TypeError resume where NoValueError :: Type -> a -> TypeError a NumOpError :: Type -> Type -> TypeError Type @@ -52,11 +51,11 @@ instance Show1 TypeError where liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r] instance Eq1 TypeError where - liftEq _ (NoValueError a _) (NoValueError b _) = a == b - -- liftEq _ (NamespaceError a) (NamespaceError b) = a == b - -- liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b - -- liftEq _ (CallError a) (CallError b) = a == b - liftEq _ _ _ = False + liftEq _ (NoValueError a _) (NoValueError b _) = a == b + liftEq _ (BitOpError a b) (BitOpError c d) = a == c && b == d + liftEq _ (NumOpError a b) (NumOpError c d) = a == c && b == d + liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d + liftEq _ _ _ = False -- | Unify two 'Type's. unify :: MonadResume TypeError m => Type -> Type -> m Type diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 2710111f5..30e0ed413 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -48,6 +48,8 @@ import qualified Language.TypeScript.Assignment as TypeScript 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) +-- The order is significant here: Caching has to come on the outside, or the RunEffect instance for NonDet +-- will expect the TypeError exception type to have an Ord instance, which is wrong. type Checking term = Caching (TypeChecking (Evaluating Monovariant term Type)) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path From 15b81a1dfc670712319e1c806aaa1f2da6052ab4 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 15:39:47 -0400 Subject: [PATCH 24/39] lints --- src/Data/Abstract/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 822d406c6..95d8b900a 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,7 +10,7 @@ import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Align (alignWith) import Data.Semigroup.Reducer (Reducer) -import Prelude hiding (fail) +import Prelude import Prologue hiding (TypeError) type TName = Int From 2b069d5921d0e1545c07dba909c3c09709683f62 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 24 Apr 2018 12:46:34 -0700 Subject: [PATCH 25/39] Clarify comment --- src/Language/Go/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index df87a6b1b..63111742f 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -41,7 +41,7 @@ resolveGoImport (ImportPath path NonRelative) = do case splitDirectories path of -- Import an absolute path that's defined in this package being analyized. -- First two are source, next is package name, remaining are path to package - -- (e.g. github.com/golang//path...). (_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs) _ -> throwResumable @(ResolutionError value) $ GoImportError path From 421cc0d1a1a5cc84d13c4bb12916b01bbf31649c Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 15:48:44 -0400 Subject: [PATCH 26/39] Add readProjectEntry to the Files effects --- src/Semantic/IO.hs | 15 +++++++++++++++ src/Semantic/Util.hs | 4 +++- test/Analysis/Go/Spec.hs | 2 +- test/Analysis/PHP/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/Ruby/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 7 files changed, 23 insertions(+), 6 deletions(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 631129a42..66fa16ad6 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -11,6 +11,7 @@ module Semantic.IO , NoLanguageForBlob(..) , readBlob , readProject +, readProjectEntry , readBlobs , readBlobPairs , writeToOutput @@ -94,6 +95,15 @@ readProjectFromPaths rootDir lang = do toFile path = File path (Just lang) exts = extensionsForLanguage lang +readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project +readProjectEntryFromPath path lang = do + paths <- liftIO $ filter (/= path) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) + pure $ Project rootDir (toFile <$> (path : paths)) lang + where + rootDir = takeDirectory path + toFile path = File path (Just lang) + exts = extensionsForLanguage lang + readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) @@ -159,6 +169,9 @@ readBlobPairs = send . ReadBlobPairs readProject :: Member Files effs => FilePath -> Language -> Eff effs Project readProject dir = send . ReadProject dir +readProjectEntry :: Member Files effs => FilePath -> Language -> Eff effs Project +readProjectEntry file = send . ReadProjectEntry file + -- | 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 @@ -170,6 +183,7 @@ data Files out where ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] ReadProject :: FilePath -> Language -> Files Project + ReadProjectEntry :: FilePath -> Language -> Files Project WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. @@ -181,6 +195,7 @@ runFiles = interpret $ \ files -> case files of ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) ReadProject dir language -> rethrowing (readProjectFromPaths dir language) + ReadProjectEntry file language -> rethrowing (readProjectEntryFromPath file language) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 159581543..11544a037 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -50,13 +50,15 @@ evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject g evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path -evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path +evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path +evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path 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 lang prelude path = evaluatePackage <$> runTask (readProject path lang >>= parsePackage parser prelude) +evaluateProjectEntry parser lang prelude path = evaluatePackage <$> runTask (readProjectEntry path lang >>= parsePackage parser prelude) parseFile :: Parser term -> FilePath -> IO term parseFile parser = runTask . (parse parser <=< readBlob . file) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 97f9672ba..9222ed48f 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -32,4 +32,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProjectEntry goParser Language.Go Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index e8a22cb9c..e32c64aed 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -36,4 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProjectEntry phpParser Language.PHP Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 39c9edaab..d54875a68 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -51,4 +51,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 Language.Python pythonPrelude path + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProjectEntry pythonParser Language.Python pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 0049680b6..f0e4bebbf 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -64,4 +64,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 Language.Ruby rubyPrelude path + evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProjectEntry rubyParser Language.Ruby rubyPrelude path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 13c6e7f4d..631c6d676 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -43,4 +43,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path + evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProjectEntry typescriptParser Language.TypeScript Nothing path From e986fdac393aa0eb67bf43fcb3ec39e907820ccc Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 24 Apr 2018 15:56:02 -0400 Subject: [PATCH 27/39] merge fallout + remove MonadFail --- src/Analysis/Abstract/TypeChecking.hs | 17 ++++++----------- src/Data/Abstract/Type.hs | 5 +++-- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index 8e65b4079..a761e5d36 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -9,26 +9,21 @@ import Data.Abstract.Type import Prologue hiding (TypeError) newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad) -deriving instance MonadControl term (m effects) => MonadControl term (TypeChecking m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (TypeChecking m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (TypeChecking m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (TypeChecking m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (TypeChecking m effects) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (TypeChecking m) instance ( Effectful m , Alternative (m effects) - , MonadAnalysis location term value (m effects) + , MonadAnalysis location term value effects m , Member (Resumable TypeError) effects , Member NonDet effects - , Member Fail effects - , MonadValue location value (TypeChecking m effects) + , MonadValue location value effects (TypeChecking m) , value ~ Type ) - => MonadAnalysis location term value (TypeChecking m effects) where + => MonadAnalysis location term value effects (TypeChecking m) where - type Effects location term value (TypeChecking m effects) = Resumable TypeError ': Effects location term value (m effects) + type Effects location term value (TypeChecking m) = Resumable TypeError ': Effects location term value m analyzeTerm eval term = resume @TypeError (liftAnalyze analyzeTerm eval term) ( diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 02c7e1255..b764f2a79 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -148,9 +148,10 @@ instance ( Alternative (m effects) call op params = do tvar <- fresh paramTypes <- sequenceA params - unified <- op `unify` (Product paramTypes :-> Var tvar) + let needed = Product paramTypes :-> Var tvar + unified <- op `unify` needed case unified of _ :-> ret -> pure ret - _ -> raise (fail "unification with a function produced something other than a function") + gotten -> throwResumable (UnificationError needed gotten) loop f = f empty From 71102dcef8ca683fcf71e8ee4480dd6de0809f24 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 24 Apr 2018 13:06:26 -0700 Subject: [PATCH 28/39] Resumable ResolutionErrors for PHP --- src/Language/PHP/Syntax.hs | 35 ++++++++++++++++------------------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 088413995..25c11a7df 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DeriveAnyClass, ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables #-} module Language.PHP.Syntax where import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.Path import qualified Data.ByteString.Char8 as BC +import qualified Data.Language as Language import Diffing.Algorithm import Prelude hiding (fail) import Prologue hiding (Text) @@ -34,25 +35,21 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -resolvePHPName :: MonadEvaluatable location term value m => ByteString -> m ModulePath -resolvePHPName n = resolve [name] >>= maybeFail notFound +resolvePHPName :: forall value location term m. MonadEvaluatable location term value m => ByteString -> m ModulePath +resolvePHPName n = do + modulePath <- resolve [name] + maybe (throwResumable @(ResolutionError value) $ NotFoundError name [name] Language.PHP) pure modulePath where name = toName n - notFound = "Unable to resolve: " <> name toName = BC.unpack . dropRelativePrefix . stripQuotes -doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value -doInclude pathTerm = do +include :: MonadEvaluatable location term value m + => Subterm t (m value) + -> (ModulePath -> m (Environment location value, value)) + -> m value +include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name - (importedEnv, v) <- traceResolve name path $ isolate (load path) - modifyEnv (mappend importedEnv) - pure v - -doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value -doIncludeOnce pathTerm = do - name <- subtermValue pathTerm >>= asString - path <- resolvePHPName name - (importedEnv, v) <- traceResolve name path $ isolate (require path) + (importedEnv, v) <- traceResolve name path $ isolate (f path) modifyEnv (mappend importedEnv) pure v @@ -64,7 +61,7 @@ instance Ord1 Require where liftCompare = genericLiftCompare instance Show1 Require where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Require where - eval (Require path) = doInclude path + eval (Require path) = include path load newtype RequireOnce a = RequireOnce a @@ -75,7 +72,7 @@ instance Ord1 RequireOnce where liftCompare = genericLiftCompare instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RequireOnce where - eval (RequireOnce path) = doIncludeOnce path + eval (RequireOnce path) = include path require newtype Include a = Include a @@ -86,7 +83,7 @@ instance Ord1 Include where liftCompare = genericLiftCompare instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where - eval (Include path) = doInclude path + eval (Include path) = include path load newtype IncludeOnce a = IncludeOnce a @@ -97,7 +94,7 @@ instance Ord1 IncludeOnce where liftCompare = genericLiftCompare instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IncludeOnce where - eval (IncludeOnce path) = doIncludeOnce path + eval (IncludeOnce path) = include path require newtype ArrayElement a = ArrayElement a From c20b882c5b826d0d204d0c69f56d22d5620c56da Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:14:01 -0400 Subject: [PATCH 29/39] Add projectEntryPoints back --- src/Data/Abstract/Package.hs | 9 +++++---- src/Data/File.hs | 1 + src/Semantic/Graph.hs | 4 ++-- src/Semantic/IO.hs | 4 ++-- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 61ea2520b..5b5d26cca 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -33,10 +33,11 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> [Module term] -> Package term -fromModules name version prelude = Package (PackageInfo name version) . go prelude +fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term +fromModules name version prelude entryPoints = Package (PackageInfo name version) . go prelude where go :: Maybe (Module term) -> [Module term] -> PackageBody term go p [] = PackageBody mempty p mempty - go p modules = PackageBody (ModuleTable.fromModules modules) p entryPoints - where entryPoints = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> modules + go p modules = PackageBody (ModuleTable.fromModules modules) p entryPoints' + where + entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else (take entryPoints modules) diff --git a/src/Data/File.hs b/src/Data/File.hs index 89c51c39f..91498f753 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -15,6 +15,7 @@ data Project = Project { projectRootDir :: FilePath , projectFiles :: [File] , projectLanguage :: Language + , projectEntryPoints :: [File] } deriving (Eq, Ord, Show) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 52480dd32..1ee7ba8a7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -49,13 +49,13 @@ parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs -> Eff effs (Package term) parsePackage parser preludeFile project@Project{..} = do prelude <- traverse (parseModule parser Nothing) preludeFile - Package.fromModules n Nothing prelude <$> parseModules parser project + Package.fromModules n Nothing prelude (length projectEntryPoints) <$> parseModules parser project where n = name (projectName 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 projectFiles (WrapTask . parseModule parser (Just projectRootDir)) + parseModules parser project@Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir)) -- | Parse a file into a 'Module'. parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 66fa16ad6..695ebedda 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -90,7 +90,7 @@ readBlobsFromPaths files = catMaybes <$> traverse readFile files readProjectFromPaths :: MonadIO m => FilePath -> Language -> m Project readProjectFromPaths rootDir lang = do paths <- liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> paths) lang + pure $ Project rootDir (toFile <$> paths) lang [] where toFile path = File path (Just lang) exts = extensionsForLanguage lang @@ -98,7 +98,7 @@ readProjectFromPaths rootDir lang = do readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project readProjectEntryFromPath path lang = do paths <- liftIO $ filter (/= path) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> (path : paths)) lang + pure $ Project rootDir (toFile <$> (path : paths)) lang [toFile path] where rootDir = takeDirectory path toFile path = File path (Just lang) From d2e32fd50b91350204864dfc7324be34d44b0a6b Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:19:54 -0400 Subject: [PATCH 30/39] go is really about entryPoints --- src/Data/Abstract/Package.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 5b5d26cca..9b2ec4dda 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -34,10 +34,7 @@ data Package term = Package deriving (Eq, Functor, Ord, Show) fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term -fromModules name version prelude entryPoints = Package (PackageInfo name version) . go prelude +fromModules name version prelude entryPoints modules = + Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints') where - go :: Maybe (Module term) -> [Module term] -> PackageBody term - go p [] = PackageBody mempty p mempty - go p modules = PackageBody (ModuleTable.fromModules modules) p entryPoints' - where - entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else (take entryPoints modules) + entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else (take entryPoints modules) From c6bbda32c5c4e8cb857ff8af7cb7442acc7ad1f7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:26:01 -0400 Subject: [PATCH 31/39] Remove packages --- semantic.cabal | 4 ---- src/Semantic/Graph.hs | 1 - 2 files changed, 5 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 430acbfe6..108fded1a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -169,7 +169,6 @@ library , directory , effects , filepath - , path , free , freer-cofreer , ghc-prim @@ -188,8 +187,6 @@ library , recursion-schemes , reducers , scientific - , safe-exceptions - , exceptions , semigroupoids , split , stm-chans @@ -271,7 +268,6 @@ test-suite test , comonad , effects , filepath - , path , free , Glob , haskell-tree-sitter diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 1ee7ba8a7..1326f9632 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -25,7 +25,6 @@ import Prologue hiding (MonadError (..)) import Rendering.Renderer import Semantic.IO (Files, NoLanguageForBlob (..)) import Semantic.Task -import Path hiding (File) import Data.Language (Language) import qualified Data.Abstract.ModuleTable as ModuleTable import qualified Data.ByteString.Char8 as B From c72ae3c161387df05fb4374a50ddadf34b2cdf18 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:29:40 -0400 Subject: [PATCH 32/39] Remove entry point from list of paths --- src/Semantic/IO.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 695ebedda..16144a79b 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -98,7 +98,7 @@ readProjectFromPaths rootDir lang = do readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project readProjectEntryFromPath path lang = do paths <- liftIO $ filter (/= path) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> (path : paths)) lang [toFile path] + pure $ Project rootDir (toFile <$> paths) lang [toFile path] where rootDir = takeDirectory path toFile path = File path (Just lang) From d4ac097291a33f11b70951c763552ac9bb5741e0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:30:39 -0400 Subject: [PATCH 33/39] Appease hlint --- src/Data/Abstract/Package.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 9b2ec4dda..b88e70043 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -37,4 +37,4 @@ fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Mo fromModules name version prelude entryPoints modules = Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints') where - entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else (take entryPoints modules) + entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules From 6c4f1c33bda0356fa0a694cb725fb86cfd34faac Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 24 Apr 2018 16:32:57 -0400 Subject: [PATCH 34/39] cleanup imports --- src/Semantic/Graph.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index e4fa8c4d9..a4c2e6331 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -23,11 +23,8 @@ import Data.Output import Parsing.Parser import Prologue hiding (MonadError (..)) import Rendering.Renderer -import Semantic.IO (Files, NoLanguageForBlob (..)) +import Semantic.IO (Files) import Semantic.Task -import Data.Language (Language) -import qualified Data.Abstract.ModuleTable as ModuleTable -import qualified Data.ByteString.Char8 as B graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) => GraphRenderer output @@ -54,7 +51,7 @@ parsePackage parser preludeFile project@Project{..} = do -- | 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 (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir)) + parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir)) -- | Parse a file into a 'Module'. parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term) From 0c8450edb60bc527c9a63021c786aa379ec76041 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 25 Apr 2018 12:08:32 -0400 Subject: [PATCH 35/39] Fix interface for graph --- src/Semantic/CLI.hs | 13 ++++++------- src/Semantic/IO.hs | 15 ++++++++++----- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 918a4b758..958976378 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -88,16 +88,15 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphArgumentsParser = do renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") - rootDir <- argument (maybeReader readMaybe :: ReadM FilePath) (metavar "DIRECTORY") - language <- argument (maybeReader readMaybe :: ReadM Language) (metavar "LANGUAGE") - pure $ runGraph renderer rootDir language + File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE") + pure $ runGraph renderer filePath (fromJust fileLanguage) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | Just lang <- readMaybe a -> Right (File b lang) - | Just lang <- readMaybe b -> Right (File a lang) - [path] -> maybe (Left $ "Cannot identify language for path:" <> path) (Right . File path . Just) (languageForFilePath path) - _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE") + [a, b] | lang <- readMaybe b -> Right (File a lang) + | lang <- readMaybe a -> Right (File b lang) + [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path) + args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 16144a79b..0beb84f9f 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -88,17 +88,22 @@ readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob] readBlobsFromPaths files = catMaybes <$> traverse readFile files readProjectFromPaths :: MonadIO m => FilePath -> Language -> m Project -readProjectFromPaths rootDir lang = do - paths <- liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> paths) lang [] +readProjectFromPaths path lang = do + isDir <- isDirectory path + let (filterFun, entryPoints, rootDir) = if isDir then (id, [], path) else (filter (/= path), [toFile path], takeDirectory path) + + paths <- liftIO $ filterFun <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) + pure $ Project rootDir (toFile <$> paths) lang entryPoints where toFile path = File path (Just lang) exts = extensionsForLanguage lang readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project readProjectEntryFromPath path lang = do - paths <- liftIO $ filter (/= path) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> paths) lang [toFile path] + isDir <- isDirectory path + let (filterFun, entryPoints) = if isDir then (id, []) else (filter (/= path), [toFile path]) + paths <- liftIO $ filterFun <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) + pure $ Project rootDir (toFile <$> paths) lang entryPoints where rootDir = takeDirectory path toFile path = File path (Just lang) From f7e66090695a545fb67e0d7b9ab4d6aec9c085a3 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 25 Apr 2018 12:10:33 -0400 Subject: [PATCH 36/39] Remove readProjectEntry --- src/Semantic/IO.hs | 17 ----------------- src/Semantic/Util.hs | 1 - test/Analysis/Go/Spec.hs | 2 +- test/Analysis/PHP/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/Ruby/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 7 files changed, 5 insertions(+), 23 deletions(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 0beb84f9f..f63960ef3 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -11,7 +11,6 @@ module Semantic.IO , NoLanguageForBlob(..) , readBlob , readProject -, readProjectEntry , readBlobs , readBlobPairs , writeToOutput @@ -98,17 +97,6 @@ readProjectFromPaths path lang = do toFile path = File path (Just lang) exts = extensionsForLanguage lang -readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project -readProjectEntryFromPath path lang = do - isDir <- isDirectory path - let (filterFun, entryPoints) = if isDir then (id, []) else (filter (/= path), [toFile path]) - paths <- liftIO $ filterFun <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) - pure $ Project rootDir (toFile <$> paths) lang entryPoints - where - rootDir = takeDirectory path - toFile path = File path (Just lang) - exts = extensionsForLanguage lang - readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) @@ -174,9 +162,6 @@ readBlobPairs = send . ReadBlobPairs readProject :: Member Files effs => FilePath -> Language -> Eff effs Project readProject dir = send . ReadProject dir -readProjectEntry :: Member Files effs => FilePath -> Language -> Eff effs Project -readProjectEntry file = send . ReadProjectEntry file - -- | 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 @@ -188,7 +173,6 @@ data Files out where ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] ReadProject :: FilePath -> Language -> Files Project - ReadProjectEntry :: FilePath -> Language -> Files Project WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. @@ -200,7 +184,6 @@ runFiles = interpret $ \ files -> case files of ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) ReadProject dir language -> rethrowing (readProjectFromPaths dir language) - ReadProjectEntry file language -> rethrowing (readProjectEntryFromPath file language) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 660ddc327..6a1c1665a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -58,7 +58,6 @@ pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Py -- Evaluate a project, starting at a single entrypoint. evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject path lang >>= parsePackage parser prelude) -evaluateProjectEntry parser lang prelude path = evaluatePackage <$> runTask (readProjectEntry path lang >>= parsePackage parser prelude) parseFile :: Parser term -> FilePath -> IO term parseFile parser = runTask . (parse parser <=< readBlob . file) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 9222ed48f..97f9672ba 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -32,4 +32,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProjectEntry goParser Language.Go Nothing path + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index e32c64aed..e8a22cb9c 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -36,4 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProjectEntry phpParser Language.PHP Nothing path + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 7c0c87282..c3b3e9fab 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -51,4 +51,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) - evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProjectEntry pythonParser Language.Python pythonPrelude path + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 9296ee1ab..245738ae9 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -72,4 +72,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) - evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProjectEntry rubyParser Language.Ruby rubyPrelude path + evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index c94d3dd26..0bff99808 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -43,4 +43,4 @@ spec = parallel $ do where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProjectEntry typescriptParser Language.TypeScript Nothing path + evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path From 2da5acf57aee274c7fb1a922a481a4660ba73cb3 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 25 Apr 2018 09:55:05 -0700 Subject: [PATCH 37/39] Add ability to exclude directories from globbing --- semantic.cabal | 1 + src/Data/Language.hs | 12 ++++++------ src/Semantic/CLI.hs | 7 ++++--- src/Semantic/IO.hs | 41 ++++++++++++++++++++++++++++++++++------- src/Semantic/Util.hs | 3 +-- 5 files changed, 46 insertions(+), 18 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 108fded1a..8dba60e16 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -167,6 +167,7 @@ library , cmark-gfm , containers , directory + , directory-tree , effects , filepath , free diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 471c5a43c..d2f819670 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -36,10 +36,10 @@ languageForType mediaType = case mediaType of 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"] + Go -> [".go"] + JavaScript -> [".js"] + PHP -> [".php"] + Python -> [".py"] + Ruby -> [".rb"] + TypeScript -> [".ts", ".tsx", ".d.tsx"] _ -> [] diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f3f232bfa..be912bca5 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -35,8 +35,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString -runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir +runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> [FilePath] -> Task.TaskEff ByteString +runGraph (SomeRenderer r) dir excludeDirs = Semantic.graph r <=< Task.readProject dir excludeDirs -- | A parser for the application's command-line arguments. -- @@ -90,8 +90,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY")) + excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)")) entryPoints <- NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)")) - pure $ runGraph renderer rootDir entryPoints + pure $ runGraph renderer rootDir entryPoints excludeDirs filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index ead2b373b..1a96555e2 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -7,6 +7,7 @@ module Semantic.IO , readBlobsFromHandle , readBlobsFromPaths , readBlobsFromDir +, findFiles , languageForFilePath , NoLanguageForBlob(..) , readBlob @@ -36,6 +37,8 @@ import qualified Data.List.NonEmpty as NonEmpty import Prelude hiding (readFile) import Prologue hiding (MonadError (..), fail) import System.Directory (doesDirectoryExist) +import qualified System.Directory.Tree as Tree +import System.Directory.Tree (AnchoredDirTree(..)) import System.Exit import System.FilePath import System.FilePath.Glob @@ -87,9 +90,9 @@ readBlobFromPath file = do 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 "[^vendor]**/*." <$> exts) rootDir) +readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> [FilePath] -> m Project +readProjectFromPaths root files excludeDirs = do + paths <- liftIO $ filter (/= entryPointPath) <$> findFiles rootDir exts excludeDirs pure $ Project files rootDir (toFile <$> paths) where toFile path = File path (languageForFilePath path) @@ -98,6 +101,30 @@ readProjectFromPaths root files = do entryPointPath = filePath entryPoint rootDir = fromMaybe (takeDirectory entryPointPath) root +-- Recursively find files in a directory. +findFiles :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath] +findFiles path exts excludeDirs = do + _:/dir <- liftIO $ Tree.build path + pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir + where + -- Build a list of only FilePath's (remove directories and failures) + onlyFiles (Tree.Dir _ fs) = concatMap onlyFiles fs + onlyFiles (Tree.Failed _ _) = [] + onlyFiles (Tree.File _ f) = [f] + + -- Predicate for Files with one of the extensions in 'exts'. + withExtensions exts (Tree.File n _) + | takeExtension n `elem` exts = True + | otherwise = False + withExtensions _ _ = True + + -- Predicate for contents NOT in a directory + notIn dirs (Tree.Dir n _) + | (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'. + | n `elem` dirs = False + | otherwise = True + notIn _ _ = True + readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) @@ -160,8 +187,8 @@ 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) +readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> [FilePath] -> Eff effs Project +readProject dir files excludeDirs = send (ReadProject dir files excludeDirs) -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs () @@ -173,7 +200,7 @@ data Files out where ReadBlob :: File -> Files Blob.Blob ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] - ReadProject :: Maybe FilePath -> NonEmpty File -> Files Project + ReadProject :: Maybe FilePath -> NonEmpty File -> [FilePath] -> Files Project WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. @@ -184,7 +211,7 @@ runFiles = interpret $ \ files -> case files of 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) + ReadProject dir files excludeDirs -> rethrowing (readProjectFromPaths dir files excludeDirs) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b0995c1e8..e42ce4cd6 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -56,8 +56,7 @@ rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath 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) - +evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) [] >>= parsePackage parser prelude) -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO term From 2df02aae58b4c89a56523c36feb7ea2a7c4c0fd1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 25 Apr 2018 11:00:41 -0700 Subject: [PATCH 38/39] Bring back setting a customer rootDir --- src/Semantic/CLI.hs | 9 ++++----- src/Semantic/IO.hs | 17 ++++++++++------- src/Semantic/Util.hs | 2 +- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 87c7fee2c..5bdf39c3b 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -34,8 +34,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -runGraph :: SomeRenderer GraphRenderer -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString -runGraph (SomeRenderer r) dir excludeDirs = Semantic.graph r <=< Task.readProject dir excludeDirs +runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString +runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs -- | A parser for the application's command-line arguments. -- @@ -88,11 +88,10 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar graphArgumentsParser = do renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") - -- TODO - -- rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY")) + rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY")) excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)")) File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE") - pure $ runGraph renderer filePath (fromJust fileLanguage) excludeDirs + pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 37af6b218..a03fa51e2 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -6,6 +6,7 @@ module Semantic.IO , readBlobPairsFromHandle , readBlobsFromHandle , readBlobsFromPaths +, readProjectFromPaths , readBlobsFromDir , findFiles , languageForFilePath @@ -89,10 +90,12 @@ readBlobFromPath file = do readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob] readBlobsFromPaths files = catMaybes <$> traverse readFile files -readProjectFromPaths :: MonadIO m => FilePath -> Language -> [FilePath] -> m Project -readProjectFromPaths path lang excludeDirs = do +readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProjectFromPaths maybeRoot path lang excludeDirs = do isDir <- isDirectory path - let (filterFun, entryPoints, rootDir) = if isDir then (id, [], path) else (filter (/= path), [toFile path], takeDirectory path) + let (filterFun, entryPoints, rootDir) = if isDir + then (id, [], fromMaybe path maybeRoot) + else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot) paths <- liftIO $ filterFun <$> findFiles rootDir exts excludeDirs pure $ Project rootDir (toFile <$> paths) lang entryPoints @@ -186,8 +189,8 @@ readBlobs = send . ReadBlobs readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair] readBlobPairs = send . ReadBlobPairs -readProject :: Member Files effs => FilePath -> Language -> [FilePath] -> Eff effs Project -readProject dir excludeDirs = send . ReadProject dir excludeDirs +readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project +readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs () @@ -199,7 +202,7 @@ data Files out where ReadBlob :: File -> Files Blob.Blob ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] - ReadProject :: FilePath -> Language -> [FilePath] -> Files Project + ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. @@ -210,7 +213,7 @@ runFiles = interpret $ \ files -> case files of ReadBlobs (Right paths@[File path _]) -> 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 language excludeDirs -> rethrowing (readProjectFromPaths dir language excludeDirs) + ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 64573fdda..63c913ff7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -57,7 +57,7 @@ rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python) -- Evaluate a project, starting at a single entrypoint. -evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject path lang [] >>= parsePackage parser prelude) +evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude) parseFile :: Parser term -> FilePath -> IO term parseFile parser = runTask . (parse parser <=< readBlob . file) From 37cf10c07e43392adfa1f683d0e380124731e304 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 25 Apr 2018 15:12:46 -0400 Subject: [PATCH 39/39] merge fallout --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index fb7f39579..cfe9cd198 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -59,7 +59,7 @@ evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateP evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path -typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Nothing path +typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path 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)