mirror of
https://github.com/github/semantic.git
synced 2025-01-02 04:10:29 +03:00
Merge pull request #1764 from github/lazy-parse
Read and evaluate projects in Task
This commit is contained in:
Josh Vera
GitHub
commit
bfaac4d78f
2
.ghci
2
.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
|
||||
|
||||
@ -74,6 +74,7 @@ library
|
||||
, Data.Diff
|
||||
, Data.Empty
|
||||
, Data.Error
|
||||
, Data.File
|
||||
, Data.Functor.Both
|
||||
, Data.Functor.Classes.Generic
|
||||
, Data.JSON.Fields
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
39
src/Data/File.hs
Normal file
39
src/Data/File.hs
Normal file
@ -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
|
||||
@ -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"]
|
||||
_ -> []
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)))
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user