diff --git a/.ghci b/.ghci index d8fd64b8d..112816cb1 100644 --- a/.ghci +++ b/.ghci @@ -25,7 +25,7 @@ assignmentExample lang = case lang of "Markdown" -> mk "md" "markdown" "JSON" -> mk "json" "json" _ -> mk "" "" - where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util") + where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util") :} :undef assignment :def assignment assignmentExample diff --git a/semantic.cabal b/semantic.cabal index 1e359f98e..108fded1a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -74,6 +74,7 @@ library , Data.Diff , Data.Empty , Data.Error + , Data.File , Data.Functor.Both , Data.Functor.Classes.Generic , Data.JSON.Fields diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 14e8a4eda..bc2dc3679 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -11,7 +11,6 @@ module Data.Abstract.Evaluatable , variable , evaluateTerm , evaluateModule -, evaluateModules , evaluatePackage , evaluatePackageBody , throwLoadError @@ -252,12 +251,6 @@ evaluateModule :: MonadEvaluatable location term value m -> m value evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) --- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: MonadEvaluatable location term value m - => [Module term] - -> m value -evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules - -- | Evaluate a given package. evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects @@ -271,11 +264,16 @@ evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBo evaluatePackageBody :: MonadEvaluatable location term value m => PackageBody term -> m [value] -evaluatePackageBody body = localModuleTable (<> packageModules body) - (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) - where evaluateEntryPoint (m, sym) = do - (_, v) <- require m - maybe (pure v) ((`call` []) <=< variable) sym +evaluatePackageBody body = withPrelude (packagePrelude body) $ + localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) + where + evaluateEntryPoint (m, sym) = do + (_, v) <- require m + maybe (pure v) ((`call` []) <=< variable) sym + withPrelude Nothing a = a + withPrelude (Just prelude) a = do + preludeEnv <- evaluateModule prelude *> getEnv + withDefaultEnvironment preludeEnv a -- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package. pushOrigin :: ( Effectful m diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 3864a4426..4e577d2bd 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -18,6 +18,7 @@ newtype Version = Version { versionString :: String } data PackageBody term = PackageBody { packageModules :: ModuleTable [Module term] + , packagePrelude :: Maybe (Module term) , packageEntryPoints :: ModuleTable (Maybe Name) } deriving (Eq, Functor, Ord, Show) @@ -30,11 +31,12 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -fromModules :: [Module term] -> PackageBody term -fromModules [] = PackageBody mempty mempty -fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath (moduleInfo m)) - -fromModulesWithEntryPoint :: [Module term] -> FilePath -> PackageBody term -fromModulesWithEntryPoint ms path = PackageBody (ModuleTable.fromModules ms) entryPoints - where entryPoints = ModuleTable.singleton path Nothing - +fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> [Module term] -> Package term +fromModules name version prelude = Package (PackageInfo name version) . go prelude + where + go :: Maybe (Module term) -> [Module term] -> PackageBody term + go p [] = PackageBody mempty p mempty + go p (m:ms) = PackageBody (ModuleTable.fromModules (m : ms)) p entryPoints + where + entryPoints = ModuleTable.singleton path Nothing + path = modulePath (moduleInfo m) diff --git a/src/Data/File.hs b/src/Data/File.hs new file mode 100644 index 000000000..a2cd61063 --- /dev/null +++ b/src/Data/File.hs @@ -0,0 +1,39 @@ +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 :: Maybe Language + } + deriving (Eq, Ord, Show) + +file :: FilePath -> File +file path = File path (languageForFilePath path) + where languageForFilePath = languageForType . takeExtension + +data Project = Project + { projectEntryPoints :: NonEmpty File + , projectRootDir :: FilePath + , projectFiles :: [File] + } + deriving (Eq, Ord, Show) + +projectAllFiles :: Project -> [File] +projectAllFiles Project{..} = NonEmpty.toList projectEntryPoints <> projectFiles + +projectName :: Project -> ByteString +projectName = BC.pack . dropExtensions . takeFileName . projectRootDir + +projectLanguage :: Project -> Maybe Language +projectLanguage = fileLanguage. projectEntryPoint + +projectEntryPoint :: Project -> File +projectEntryPoint = NonEmpty.head . projectEntryPoints + +projectExtensions :: Project -> [String] +projectExtensions = extensionsForLanguage . projectLanguage diff --git a/src/Data/Language.hs b/src/Data/Language.hs index e3df96d84..471c5a43c 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -32,3 +32,14 @@ languageForType mediaType = case mediaType of ".php" -> Just PHP ".phpt" -> Just PHP _ -> Nothing + +extensionsForLanguage :: Maybe Language -> [String] +extensionsForLanguage Nothing = [] +extensionsForLanguage (Just language) = case language of + Go -> ["go"] + JavaScript -> ["js"] + PHP -> ["php"] + Python -> ["py"] + Ruby -> ["rb"] + TypeScript -> ["ts", "tsx", "d.tsx"] + _ -> [] diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 5341fe54a..687d3aef4 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -25,6 +25,7 @@ import Data.Language import Data.Record import qualified Data.Syntax as Syntax import Data.Term +import Data.File import Foreign.Ptr import qualified GHC.TypeLits as TypeLevel import qualified Language.Go.Assignment as Go @@ -54,8 +55,7 @@ data SomeAnalysisParser typeclasses ann where SomeAnalysisParser :: ( Member Syntax.Identifier fs , ApplyAll' typeclasses fs) => Parser (Term (Union fs) ann) -- ^ A parser. - -> [String] -- ^ List of valid file extensions to be used for module resolution. - -> Maybe String -- ^ Maybe path to prelude. + -> Maybe File -- ^ Maybe path to prelude. -> SomeAnalysisParser typeclasses ann -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. @@ -68,12 +68,12 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. -> Language -- ^ The 'Language' to select. -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced. -someAnalysisParser _ Go = SomeAnalysisParser goParser ["go"] Nothing -someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser ["js"] Nothing -someAnalysisParser _ PHP = SomeAnalysisParser phpParser ["php"] Nothing -someAnalysisParser _ Python = SomeAnalysisParser pythonParser ["py"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term)))) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser ["rb"] (Just (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term)))) -someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser ["ts", "tsx", "d.tsx"] Nothing +someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing +someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser Nothing +someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing +someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) +someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index cf7dd3dfc..f3f232bfa 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -6,8 +6,9 @@ module Semantic.CLI , runParse ) where -import Data.Language +import Data.File import Data.List (intercalate) +import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split (splitWhen) import Data.Version (showVersion) import Development.GitRev @@ -28,14 +29,14 @@ import Text.Read main :: IO () main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions -runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.TaskEff ByteString +runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs -runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString +runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> (FilePath, Maybe Language) -> Task.TaskEff ByteString -runGraph (SomeRenderer r) rootDir = Semantic.graph rootDir r <=< Task.readBlob +runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString +runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir -- | A parser for the application's command-line arguments. -- @@ -89,14 +90,14 @@ 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")) - entryPoint <- argument filePathReader (metavar "ENTRY_FILE") - pure $ runGraph renderer rootDir entryPoint + entryPoints <- NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)")) + pure $ runGraph renderer rootDir entryPoints filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | Just lang <- readMaybe a -> Right (b, Just lang) - | Just lang <- readMaybe b -> Right (a, Just lang) - [path] -> Right (path, languageForFilePath path) + [a, b] | Just lang <- readMaybe a -> Right (File b (Just lang)) + | Just lang <- readMaybe b -> Right (File a (Just lang)) + [path] -> Right (File path (languageForFilePath path)) _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE") optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3d3eeb73e..89e63e218 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -4,40 +4,94 @@ module Semantic.Graph where import qualified Analysis.Abstract.ImportGraph as Abstract import qualified Data.Abstract.Evaluatable as Analysis import Data.Abstract.FreeVariables -import qualified Data.Abstract.ModuleTable as ModuleTable -import Data.Abstract.Package -import Data.Blob -import Data.List (intercalate) -import Data.ByteString.Char8 as BC (pack) +import Data.Abstract.Package as Package +import qualified Control.Exception as Exc +import Data.Abstract.Module +import Data.File +import Data.Term +import qualified Data.Syntax as Syntax +import Data.Abstract.Value (Value) +import Data.Abstract.Located +import Data.Abstract.Address +import Analysis.Abstract.BadAddresses +import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadValues +import Analysis.Abstract.BadVariables +import Analysis.Abstract.Evaluating +import Analysis.Abstract.Quiet import Data.Output import Parsing.Parser import Prologue hiding (MonadError (..)) import Rendering.Renderer import Semantic.IO (Files, NoLanguageForBlob (..)) import Semantic.Task -import System.FilePath.Posix graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) - => Maybe FilePath - -> GraphRenderer output - -> Blob + => GraphRenderer output + -> Project -> Eff effs ByteString -graph maybeRootDir renderer Blob{..} - | Just (SomeAnalysisParser parser exts preludePath) <- someAnalysisParser - (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do - let rootDir = fromMaybe (takeDirectory blobPath) maybeRootDir - paths <- filter (/= blobPath) <$> listFiles rootDir exts - prelude <- traverse (parseModule parser Nothing) preludePath - let name = packageName blobPath - package <- parsePackage name parser rootDir (blobPath : paths) - - let modulePaths = intercalate "," $ ModuleTable.keys (packageModules (packageBody package)) - writeLog Info ("Package " <> show name <> " loaded") [("paths", modulePaths)] - - graphImports prelude package >>= case renderer of +graph renderer project + | Just (SomeAnalysisParser parser prelude) <- someAnalysisParser + (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do + parsePackage parser prelude project >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput DOTGraphRenderer -> pure . Abstract.renderImportGraph - | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) + | otherwise = throwError (SomeException (NoLanguageForBlob (filePath (projectEntryPoint project)))) - where packageName = name . BC.pack . dropExtensions . takeFileName +-- | Parse a list of files into a 'Package'. +parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs + => Parser term -- ^ A parser. + -> Maybe File -- ^ Prelude (optional). + -> Project -- ^ Project to parse into a package. + -> Eff effs (Package term) +parsePackage parser preludeFile project@Project{..} = do + prelude <- traverse (parseModule parser Nothing) preludeFile + Package.fromModules n Nothing prelude <$> 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 allFiles (WrapTask . parseModule parser (Just projectRootDir)) + where allFiles = projectAllFiles project + + -- | Parse a file into a 'Module'. + parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term) + parseModule parser rootDir file = do + blob <- readBlob file + moduleForBlob rootDir blob <$> parse parser blob + + +type ImportGraphAnalysis term effects value = + Abstract.ImportGraphing + (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) + effects + value + +-- | Render the import graph for a given 'Package'. +graphImports :: ( + Show ann + , Ord ann + , Apply Analysis.Declarations1 syntax + , Apply Analysis.Evaluatable syntax + , Apply FreeVariables1 syntax + , Apply Functor syntax + , Apply Ord1 syntax + , Apply Eq1 syntax + , Apply Show1 syntax + , Member Syntax.Identifier syntax + , Members '[Exc SomeException, Task] effs + , term ~ Term (Union syntax) ann + ) + => Package term -> Eff effs Abstract.ImportGraph +graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph + where + asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value + -> Package term + -> ImportGraphAnalysis term effs value + asAnalysisForTypeOfPackage = const + + extractGraph result = case result of + (Right (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _)))))))), _) -> pure $! graph + _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index c7a3140c0..ae3f74ff9 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TupleSections, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO ( readFile , readFilePair @@ -9,8 +9,8 @@ module Semantic.IO , readBlobsFromDir , languageForFilePath , NoLanguageForBlob(..) -, listFiles , readBlob +, readProject , readBlobs , readBlobPairs , writeToOutput @@ -27,10 +27,12 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.Blob as Blob import Data.Bool +import Data.File import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Language import Data.Source +import qualified Data.List.NonEmpty as NonEmpty import Prelude hiding (readFile) import Prologue hiding (MonadError (..), fail) import System.Directory (doesDirectoryExist) @@ -41,16 +43,16 @@ import System.IO (Handle) import Text.Read -- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob) -readFile "/dev/null" _ = pure Nothing -readFile path language = do +readFile :: forall m. MonadIO m => File -> m (Maybe Blob.Blob) +readFile (File "/dev/null" _) = pure Nothing +readFile (File path language) = do raw <- liftIO (Just <$> B.readFile path) pure $ Blob.sourceBlob path language . fromBytes <$> raw -readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair +readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair readFilePair a b = do - before <- uncurry readFile a - after <- uncurry readFile b + before <- readFile a + after <- readFile b case (before, after) of (Just a, Nothing) -> pure (Join (This a)) (Nothing, Just b) -> pure (Join (That b)) @@ -77,19 +79,30 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readBlobFromPath :: MonadIO m => (FilePath, Maybe Language) -> m Blob.Blob +readBlobFromPath :: MonadIO m => File -> m Blob.Blob readBlobFromPath file = do - maybeFile <- uncurry readFile file + maybeFile <- readFile file maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile -readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob] -readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files +readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob] +readBlobsFromPaths files = catMaybes <$> traverse readFile files + +readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> m Project +readProjectFromPaths root files = do + paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir) + pure $ Project files rootDir (toFile <$> paths) + where + toFile path = File path (languageForFilePath path) + exts = extensionsForLanguage (fileLanguage entryPoint) + entryPoint = NonEmpty.head files + entryPointPath = filePath entryPoint + rootDir = fromMaybe (takeDirectory entryPointPath) root readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) - let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths - blobs <- traverse (uncurry readFile) paths' + let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths + blobs <- traverse readFile paths' pure (catMaybes blobs) readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a @@ -136,20 +149,20 @@ instance FromJSON BlobPair where newtype NoLanguageForBlob = NoLanguageForBlob FilePath deriving (Eq, Exception, Ord, Show, Typeable) -listFiles :: Member Files effs => FilePath -> [String] -> Eff effs [FilePath] -listFiles dir exts = send (ListFiles dir exts) - -readBlob :: Member Files effs => (FilePath, Maybe Language) -> Eff effs Blob.Blob +readBlob :: Member Files effs => File -> Eff effs Blob.Blob readBlob = send . ReadBlob -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob] +readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob] readBlobs = send . ReadBlobs -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: Member Files effs => Either Handle [Both (FilePath, Maybe Language)] -> Eff effs [Blob.BlobPair] +readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair] readBlobPairs = send . ReadBlobPairs +readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project +readProject dir files = send (ReadProject dir files) + -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs () writeToOutput path = send . WriteToOutput path @@ -157,23 +170,21 @@ writeToOutput path = send . WriteToOutput path -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's. data Files out where - ReadBlob :: (FilePath, Maybe Language) -> Files Blob.Blob - ListFiles :: FilePath -> [String] -> Files [FilePath] - - ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob] - ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair] + 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 WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () -- | Run a 'Files' effect in 'IO'. runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a runFiles = interpret $ \ files -> case files of ReadBlob path -> rethrowing (readBlobFromPath path) - ListFiles directory exts -> liftIO $ fmap fold (globDir (compile . mappend "**/*." <$> exts) directory) - ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle) - ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) + ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) + ReadProject dir files -> rethrowing (readProjectFromPaths dir files) WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4a2eed6ca..a9ff0360c 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -7,10 +7,10 @@ module Semantic.Task , RAlgebra , Differ -- * I/O -, IO.listFiles , IO.readBlob , IO.readBlobs , IO.readBlobPairs +, IO.readProject , IO.writeToOutput -- * Telemetry , writeLog @@ -18,14 +18,10 @@ module Semantic.Task , time -- * High-level flow , parse -, parseModule -, parseModules -, parsePackage , analyze , decorate , diff , render -, graphImports -- * Concurrency , distribute , distributeFor @@ -47,29 +43,14 @@ module Semantic.Task , Telemetry ) where -import Analysis.Abstract.BadAddresses -import Analysis.Abstract.BadModuleResolutions -import Analysis.Abstract.BadValues -import Analysis.Abstract.BadVariables -import Analysis.Abstract.Evaluating -import qualified Analysis.Abstract.ImportGraph as Abstract -import Analysis.Abstract.Quiet import Analysis.Decorator (decoratorWithAlgebra) import qualified Assigning.Assignment as Assignment import qualified Control.Abstract.Analysis as Analysis -import qualified Control.Exception as Exc import Control.Monad import Control.Monad.Effect.Exception import Control.Monad.Effect.Internal as Eff hiding (run) import Control.Monad.Effect.Reader import Control.Monad.Effect.Run as Run -import Data.Abstract.Address -import qualified Data.Abstract.Evaluatable as Analysis -import Data.Abstract.FreeVariables -import Data.Abstract.Located -import Data.Abstract.Module -import Data.Abstract.Package as Package -import Data.Abstract.Value (Value) import Data.Blob import Data.Diff import qualified Data.Error as Error @@ -106,21 +87,6 @@ type Renderer i o = i -> o parse :: Member Task effs => Parser term -> Blob -> Eff effs term parse parser = send . Parse parser --- | Parse a file into a 'Module'. -parseModule :: Members '[IO.Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term) -parseModule parser rootDir path = do - blob <- head <$> IO.readBlobs (Right [(path, IO.languageForFilePath path)]) - moduleForBlob rootDir blob <$> parse parser blob - --- | Parse a list of files into 'Module's. -parseModules :: Members '[IO.Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term] -parseModules parser rootDir = traverse (parseModule parser (Just rootDir)) - --- | Parse a list of files into a 'Package'. -parsePackage :: Members '[IO.Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term) -parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths - - -- | A task running some 'Analysis.MonadAnalysis' to completion. analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result analyze = send . Analyze @@ -137,45 +103,6 @@ diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2) render :: Member Task effs => Renderer input output -> input -> Eff effs output render renderer = send . Render renderer - -type ImportGraphAnalysis term effects value = - Abstract.ImportGraphing - (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) - effects - value - --- | Render the import graph for a given 'Package'. -graphImports :: ( - Show ann - , Ord ann - , Apply Analysis.Declarations1 syntax - , Apply Analysis.Evaluatable syntax - , Apply FreeVariables1 syntax - , Apply Functor syntax - , Apply Ord1 syntax - , Apply Eq1 syntax - , Apply Show1 syntax - , Member Syntax.Identifier syntax - , Members '[Exc SomeException, Task] effs - , term ~ Term (Union syntax) ann - ) - => Maybe (Module term) -> Package term -> Eff effs Abstract.ImportGraph -graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelude (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package))) >>= extractGraph - where - asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value - -> Package term - -> ImportGraphAnalysis term effs value - asAnalysisForTypeOfPackage = const - - extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _)))))))), _) -> pure $! graph - _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) - - withPrelude Nothing a = a - withPrelude (Just prelude) a = do - preludeEnv <- Analysis.evaluateModule prelude *> Analysis.getEnv - Analysis.withDefaultEnvironment preludeEnv a - -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- -- > runTask = runTaskWithOptions defaultOptions diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca020feb0..ef382b0ba 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -3,139 +3,69 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where -import Analysis.Abstract.BadVariables -import Analysis.Abstract.BadModuleResolutions -import Analysis.Abstract.BadValues -import Analysis.Abstract.Caching -import Analysis.Abstract.Quiet -import Analysis.Abstract.Dead -import Analysis.Abstract.Evaluating as X -import Analysis.Abstract.ImportGraph -import Analysis.Abstract.Tracing -import Analysis.Declaration -import Control.Abstract.Analysis -import Control.Monad.IO.Class -import Data.Abstract.Evaluatable hiding (head) -import Data.Abstract.Address -import Data.Abstract.Located -import Data.Abstract.Module -import Data.Abstract.Package as Package -import Data.Abstract.Type -import Data.Abstract.Value -import Data.Blob -import Data.Diff -import Data.Range -import Data.Record -import Data.Span -import Data.Term -import Diffing.Algorithm -import Diffing.Interpreter -import System.FilePath.Glob +import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadValues +import Analysis.Abstract.BadVariables +import Analysis.Abstract.Evaluating as X +import Analysis.Abstract.ImportGraph +import Analysis.Abstract.Quiet +import Analysis.Declaration +import Control.Abstract.Analysis +import Data.Abstract.Address +import Data.Abstract.Evaluatable +import Data.Abstract.Located +import Data.Abstract.Value +import Data.Blob +import Data.Diff +import Data.File +import qualified Data.Language as Language +import Data.Range +import Data.Record +import Data.Span +import Data.Term +import Diffing.Algorithm +import Diffing.Interpreter import qualified GHC.TypeLits as TypeLevel -import Language.Preluded -import Parsing.Parser -import Prologue -import Semantic.Diff (diffTermPair) -import Semantic.IO as IO -import Semantic.Task -import qualified Semantic.Task as Task -import System.FilePath.Posix +import Language.Preluded +import Parsing.Parser +import Prologue +import Semantic.Diff (diffTermPair) +import Semantic.Graph +import Semantic.IO as IO +import Semantic.Task import qualified Language.Go.Assignment as Go +import qualified Language.PHP.Assignment as PHP import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript --- Ruby -evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"] -evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path)) - -evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path)) - -evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths - -evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths - --- Go -evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path -evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path - -typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path - --- Python -evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"] -evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path)) -evalPythonProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))))))) <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluatePackageBody <$> parseProject pythonParser ["py"] path)) - -typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path -evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path - --- PHP -evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path -evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path - --- TypeScript -evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path -evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path -typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path - --- JavaScript -evalJavaScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) . evaluatePackageBody <$> parseProject typescriptParser ["js"] path - -runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path)) +-- type TestEvaluating term = Evaluating Precise term (Value Precise) +type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) +evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path +evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path +evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path +evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path +evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path --- TODO: Remove this by exporting EvaluatingEffects -runEvaluating :: forall term effects a. - ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects - , Corecursive term - , Recursive term ) - => Evaluating Precise term (Value Precise) effects a - -> Final effects a -runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise)) +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) -parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term) -parsePrelude parser = do - let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) - parseFile parser Nothing preludePath - -parseProject :: Parser term - -> [Prelude.String] - -> FilePath - -> IO (PackageBody term) -parseProject parser exts entryPoint = do - let rootDir = takeDirectory entryPoint - paths <- getPaths exts rootDir - modules <- parseFiles parser rootDir paths - pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint) - -withPrelude prelude a = do - preludeEnv <- evaluateModule prelude *> getEnv - withDefaultEnvironment preludeEnv a - -getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts) +-- Evaluate a project, starting at a single entrypoint. +evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude) -- Read and parse a file. -parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) -parseFile parser rootDir path = runTask $ do - blob <- file path - moduleForBlob rootDir blob <$> parse parser blob - -parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term] -parseFiles parser rootDir = traverse (parseFile parser (Just rootDir)) - -parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term) -parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir - +parseFile :: Parser term -> FilePath -> IO term +parseFile parser = runTask . (parse parser <=< readBlob . file) -- Read a file from the filesystem into a Blob. -file :: MonadIO m => FilePath -> m Blob -file path = fromJust <$> IO.readFile path (languageForFilePath path) +blob :: FilePath -> IO Blob +blob = runTask . readBlob . file -- Diff helpers diffWithParser :: ( HasField fields Data.Span.Span diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 471580ba8..a46f0ab7e 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.Go.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import qualified Language.Go.Assignment as Go + import SpecHelpers @@ -28,3 +31,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) + evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index b78a66952..31f9361d0 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.PHP.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import qualified Language.PHP.Assignment as PHP + import SpecHelpers @@ -32,3 +35,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) + evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 51a367f33..13e970321 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedLists, OverloadedStrings #-} module Analysis.Python.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) import Data.Abstract.Value import Data.Map +import qualified Language.Python.Assignment as Python import SpecHelpers @@ -48,3 +50,4 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) + evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 45b9db269..f02cb1d84 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -2,13 +2,14 @@ module Analysis.Ruby.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..)) +import Data.Abstract.Evaluatable import Data.Abstract.Value as Value import Data.Abstract.Number as Number import Control.Monad.Effect (SomeExc(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map import Data.Map.Monoidal as Map +import qualified Language.Ruby.Assignment as Ruby import SpecHelpers @@ -62,3 +63,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 diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 394559f73..528c24b7e 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -1,11 +1,13 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.TypeScript.Spec (spec) where -import SpecHelpers import Data.Abstract.Evaluatable +import qualified Language.TypeScript.Assignment as TypeScript import Data.Abstract.Value as Value import Data.Abstract.Number as Number +import SpecHelpers + spec :: Spec spec = parallel $ do describe "evaluates TypeScript" $ do @@ -40,3 +42,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 diff --git a/test/Matching/Go/Spec.hs b/test/Matching/Go/Spec.hs index 496e4a1ac..5bb99d182 100644 --- a/test/Matching/Go/Spec.hs +++ b/test/Matching/Go/Spec.hs @@ -30,11 +30,11 @@ loopMatcher = target <* go where spec :: Spec spec = describe "matching/go" $ do it "extracts integers" $ do - parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/integers.go" + parsed <- parseFile goParser "test/fixtures/go/matching/integers.go" let matched = runMatcher integerMatcher parsed sort matched `shouldBe` ["1", "2", "3"] it "counts for loops" $ do - parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/for.go" + parsed <- parseFile goParser "test/fixtures/go/matching/for.go" let matched = runMatcher @[] loopMatcher parsed length matched `shouldBe` 2 diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 182d6b2dd..7f370c5e9 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -26,17 +26,17 @@ spec = parallel $ do when (actual /= expected) $ print actual actual `shouldBe` expected -parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)] +parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [File], ByteString)] parseFixtures = [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput) - , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby)], symbolsOutput) - , (SomeRenderer TagsTermRenderer, Right [("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby)], tagsOutput) + , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput) + , (SomeRenderer TagsTermRenderer, Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput) ] - where pathMode = Right [("test/fixtures/ruby/corpus/and-or.A.rb", Just Ruby)] - pathMode' = Right [("test/fixtures/ruby/corpus/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/corpus/and-or.B.rb", Just Ruby)] + where pathMode = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)] + pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)] sExpressionParseTreeOutput = "(Program\n (LowAnd\n (Send\n (Identifier))\n (Send\n (Identifier))))\n" jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n" @@ -46,13 +46,13 @@ parseFixtures = tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n" -diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)] +diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both File], ByteString)] diffFixtures = [ (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput) , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput) , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput) ] - where pathMode = Right [both ("test/fixtures/ruby/corpus/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/corpus/method-declaration.B.rb", Just Ruby)] + where pathMode = Right [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" (Just Ruby))] jsonOutput = "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\"}}]}\n" sExpressionOutput = "(Program\n (Method\n (Empty)\n { (Identifier)\n ->(Identifier) }\n {+(Identifier)+}\n (\n {+(Send\n {+(Identifier)+})+})))\n" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index ce64b7eaf..d8536123a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -12,11 +12,11 @@ spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - Just blob <- readFile "semantic.cabal" Nothing + Just blob <- readFile (File "semantic.cabal" Nothing) blobPath blob `shouldBe` "semantic.cabal" it "throws for absent files" $ do - readFile "this file should not exist" Nothing `shouldThrow` anyIOException + readFile (File "this file should not exist" Nothing) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 77b1dc008..e9cc3b47c 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -9,6 +9,7 @@ module SpecHelpers ( , ns , verbatim , Verbatim(..) +, TestEvaluating , ) where import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) @@ -17,6 +18,7 @@ import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Blob as X +import Data.File as X import Data.Functor.Listable as X import Data.Language as X import Data.Output as X @@ -48,6 +50,7 @@ import Test.LeanCheck as X import qualified Data.ByteString as B import qualified Semantic.IO as IO import Data.Abstract.Value +import Analysis.Abstract.Evaluating -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString @@ -55,16 +58,18 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: FilePath -> IO ByteString -parseFilePath path = (fromJust <$> IO.readFile path (IO.languageForFilePath path)) >>= runTask . parseBlob SExpressionTermRenderer +parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= runTask . parseBlob SExpressionTermRenderer -- | Read two files to a BlobPair. readFilePair :: Both FilePath -> IO BlobPair -readFilePair paths = let paths' = fmap (\p -> (p, IO.languageForFilePath p)) paths in +readFilePair paths = let paths' = fmap file paths in runBothWith IO.readFilePair paths' readFileVerbatim :: FilePath -> IO Verbatim readFileVerbatim = fmap verbatim . B.readFile +type TestEvaluating term = Evaluating Precise term (Value Precise) + ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise