Merge branch 'master' into resumable-type-errors

src/Data/Abstract/Package.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE TupleSections #-}
 module Data.Abstract.Package where
 
 import Data.Abstract.FreeVariables
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable as ModuleTable
+import qualified Data.Map as Map
 
 type PackageName = Name
 
@@ -31,12 +33,8 @@ data Package term = Package
   }
   deriving (Eq, Functor, Ord, Show)
 
-fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> [Module term] -> Package term
-fromModules name version prelude = Package (PackageInfo name version) . go prelude
+fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
+fromModules name version prelude entryPoints modules =
+  Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
   where
-    go :: Maybe (Module term) -> [Module term] -> PackageBody term
-    go p []     = PackageBody mempty p mempty
-    go p (m:ms) = PackageBody (ModuleTable.fromModules (m : ms)) p entryPoints
-      where
-        entryPoints = ModuleTable.singleton path Nothing
-        path = modulePath (moduleInfo m)
+    entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules

src/Data/File.hs

@@ -2,7 +2,6 @@ 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
 
@@ -12,28 +11,20 @@ data File = File
   }
   deriving (Eq, Ord, Show)
 
+data Project = Project
+  { projectRootDir :: FilePath
+  , projectFiles :: [File]
+  , projectLanguage :: Language
+  , projectEntryPoints :: [File]
+  }
+  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

src/Data/Language.hs

@@ -33,9 +33,8 @@ languageForType mediaType = case mediaType of
     ".phpt" -> Just PHP
     _ -> Nothing
 
-extensionsForLanguage :: Maybe Language -> [String]
-extensionsForLanguage Nothing         = []
-extensionsForLanguage (Just language) = case language of
+extensionsForLanguage :: Language -> [String]
+extensionsForLanguage language = case language of
   Go -> ["go"]
   JavaScript -> ["js"]
   PHP -> ["php"]

src/Semantic/CLI.hs

@@ -7,8 +7,8 @@ module Semantic.CLI
 ) where
 
 import           Data.File
+import           Data.Language
 import           Data.List (intercalate)
-import qualified Data.List.NonEmpty as NonEmpty
 import           Data.List.Split (splitWhen)
 import           Data.Version (showVersion)
 import           Development.GitRev
@@ -25,7 +25,6 @@ import qualified Semantic.Task as Task
 import           System.IO (Handle, stdin, stdout)
 import           Text.Read
 
-
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
@@ -35,7 +34,7 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
 runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
 runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
-runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString
+runGraph :: SomeRenderer GraphRenderer -> FilePath -> Language -> Task.TaskEff ByteString
 runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir
 
 -- | A parser for the application's command-line arguments.
@@ -89,16 +88,15 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
     graphArgumentsParser = do
       renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
               <|> flag'                                (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
-      rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY"))
-      entryPoints <- NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)"))
-      pure $ runGraph renderer rootDir entryPoints
+      File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
+      pure $ runGraph renderer filePath (fromJust fileLanguage)
 
     filePathReader = eitherReader parseFilePath
     parseFilePath arg = case splitWhen (== ':') arg of
-        [a, b] | Just lang <- readMaybe a -> Right (File b (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")
+        [a, b] | lang <- readMaybe b -> Right (File a lang)
+               | lang <- readMaybe a -> Right (File b lang)
+        [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path)
+        args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
 
     optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
     options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))

src/Semantic/Graph.hs

@@ -23,7 +23,7 @@ import           Data.Output
 import           Parsing.Parser
 import           Prologue hiding (MonadError (..))
 import           Rendering.Renderer
-import           Semantic.IO (Files, NoLanguageForBlob (..))
+import           Semantic.IO (Files)
 import           Semantic.Task
 
 graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs)
@@ -31,14 +31,12 @@ graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Tele
       -> Project
       -> Eff effs ByteString
 graph renderer project
-  | Just (SomeAnalysisParser parser prelude) <- someAnalysisParser
-    (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do
+  | 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 (filePath (projectEntryPoint project))))
-
 -- | Parse a list of files into a 'Package'.
 parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
              => Parser term       -- ^ A parser.
@@ -47,14 +45,13 @@ parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
              -> Eff effs (Package term)
 parsePackage parser preludeFile project@Project{..} = do
   prelude <- traverse (parseModule parser Nothing) preludeFile
-  Package.fromModules n Nothing prelude <$> parseModules parser project
+  Package.fromModules n Nothing prelude (length projectEntryPoints) <$> parseModules parser project
   where
     n = name (projectName project)
 
     -- | Parse all files in a project into 'Module's.
     parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term]
-    parseModules parser project@Project{..} = distributeFor allFiles (WrapTask . parseModule parser (Just projectRootDir))
-      where allFiles = projectAllFiles project
+    parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
 
     -- | Parse a file into a 'Module'.
     parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)

src/Semantic/IO.hs

@@ -32,7 +32,6 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import           Data.Language
 import           Data.Source
-import qualified Data.List.NonEmpty as NonEmpty
 import           Prelude hiding (readFile)
 import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
@@ -87,16 +86,16 @@ readBlobFromPath file = do
 readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob]
 readBlobsFromPaths files = catMaybes <$> traverse readFile files
 
-readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> m Project
-readProjectFromPaths root files = do
-  paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir)
-  pure $ Project files rootDir (toFile <$> paths)
+readProjectFromPaths :: MonadIO m => FilePath -> Language -> m Project
+readProjectFromPaths path lang = do
+  isDir <- isDirectory path
+  let (filterFun, entryPoints, rootDir) = if isDir then (id, [], path) else (filter (/= path), [toFile path], takeDirectory path)
+
+  paths <- liftIO $ filterFun <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir)
+  pure $ Project rootDir (toFile <$> paths) lang entryPoints
   where
-    toFile path = File path (languageForFilePath path)
-    exts = extensionsForLanguage (fileLanguage entryPoint)
-    entryPoint = NonEmpty.head files
-    entryPointPath = filePath entryPoint
-    rootDir = fromMaybe (takeDirectory entryPointPath) root
+    toFile path = File path (Just lang)
+    exts = extensionsForLanguage lang
 
 readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
 readBlobsFromDir path = do
@@ -160,8 +159,8 @@ readBlobs = send . ReadBlobs
 readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
 readBlobPairs = send . ReadBlobPairs
 
-readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project
-readProject dir files = send (ReadProject dir files)
+readProject :: Member Files effs => FilePath -> Language -> Eff effs Project
+readProject dir = send . ReadProject dir
 
 -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
 writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
@@ -173,7 +172,7 @@ data Files out where
   ReadBlob      :: File -> Files Blob.Blob
   ReadBlobs     :: Either Handle [File] -> Files [Blob.Blob]
   ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
-  ReadProject   :: Maybe FilePath -> NonEmpty File -> Files Project
+  ReadProject   :: FilePath -> Language -> Files Project
   WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
 
 -- | Run a 'Files' effect in 'IO'.
@@ -181,10 +180,10 @@ runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Ef
 runFiles = interpret $ \ files -> case files of
   ReadBlob path -> rethrowing (readBlobFromPath path)
   ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
-  ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
+  ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
   ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
   ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
-  ReadProject dir files -> rethrowing (readProjectFromPaths dir files)
+  ReadProject dir language -> rethrowing (readProjectFromPaths dir language)
   WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
 
 

src/Semantic/Util.hs

@@ -52,11 +52,12 @@ type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term)
 -- will expect the TypeError exception type to have an Ord instance, which is wrong.
 type Checking term = Caching (TypeChecking (Evaluating Monovariant term Type))
 
-evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path
-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
+evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
+evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
+evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
+evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
+evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
+evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
 
 typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Nothing path
 
@@ -64,14 +65,11 @@ rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby
 pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
 
 -- Evaluate a project, starting at a single entrypoint.
-evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude)
+evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject path lang >>= parsePackage parser prelude)
 
-
--- Read and parse a file.
 parseFile :: Parser term -> FilePath -> IO term
 parseFile parser = runTask . (parse parser <=< readBlob . file)
 
--- Read a file from the filesystem into a Blob.
 blob :: FilePath -> IO Blob
 blob = runTask . readBlob . file
 

test/Analysis/Go/Spec.hs

@@ -3,6 +3,7 @@ module Analysis.Go.Spec (spec) where
 
 import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
 import qualified Language.Go.Assignment as Go
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -31,4 +32,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/go/analysis/"
     evaluate entry = evalGoProject (fixtures <> entry)
-    evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Nothing path
+    evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path

test/Analysis/PHP/Spec.hs

@@ -3,6 +3,7 @@ module Analysis.PHP.Spec (spec) where
 
 import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
 import qualified Language.PHP.Assignment as PHP
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -35,4 +36,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/php/analysis/"
     evaluate entry = evalPHPProject (fixtures <> entry)
-    evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path
+    evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path

test/Analysis/Python/Spec.hs

@@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
 import Data.Abstract.Value
 import Data.Map
 import qualified Language.Python.Assignment as Python
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -50,4 +51,4 @@ spec = parallel $ do
     addr = Address . Precise
     fixtures = "test/fixtures/python/analysis/"
     evaluate entry = evalPythonProject (fixtures <> entry)
-    evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path
+    evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path

test/Analysis/Ruby/Spec.hs

@@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map
 import Data.Map.Monoidal as Map
 import qualified Language.Ruby.Assignment as Ruby
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -71,4 +72,4 @@ spec = parallel $ do
     addr = Address . Precise
     fixtures = "test/fixtures/ruby/analysis/"
     evaluate entry = evalRubyProject (fixtures <> entry)
-    evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path
+    evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path

test/Analysis/TypeScript/Spec.hs

@@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable
 import qualified Language.TypeScript.Assignment as TypeScript
 import Data.Abstract.Value as Value
 import Data.Abstract.Number as Number
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -42,4 +43,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/typescript/analysis/"
     evaluate entry = evalTypeScriptProject (fixtures <> entry)
-    evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Nothing path
+    evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path