From a90d70fa364881a54290c473a2ea1eaaf2558614 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 8 Jun 2018 12:41:07 -0400 Subject: [PATCH] generalize Project --- src/Data/Project.hs | 56 +++++++++++++++++++++++++++++++------- src/Semantic/Graph.hs | 11 ++++---- src/Semantic/IO.hs | 16 +++++++---- src/Semantic/Resolution.hs | 3 +- 4 files changed, 64 insertions(+), 22 deletions(-) diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 1c75ccc2e..3e47530a5 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -1,25 +1,58 @@ +{-# LANGUAGE DeriveAnyClass #-} module Data.Project where -import Data.Text as T (pack) +import Data.Blob import Data.Language +import qualified Data.Text as T import Prologue +import Proto3.Suite import System.FilePath.Posix -data Project = Project - { projectRootDir :: FilePath - , projectFiles :: [File] +data Project blobs paths path = Project + { projectRootDir :: path + , projectBlobs :: blobs Blob , projectLanguage :: Language - , projectEntryPoints :: [File] - , projectExcludeDirs :: [FilePath] - } - deriving (Eq, Ord, Show) + , projectEntryPaths :: paths path + , projectExcludeDirs :: paths path + } deriving (Functor, Generic, Named) -projectName :: Project -> Text +deriving instance ( MessageField path + , MessageField (paths path) + , MessageField (blobs Blob) + ) => Message (Project blobs paths path) + +deriving instance (Eq path, Eq (blobs Blob), Eq (paths path)) => Eq (Project blobs paths path) +deriving instance (Show path, Show (blobs Blob), Show (paths path)) => Show (Project blobs paths path) + +type Concrete = Project [] [] FilePath +type PB = Project NestedVec UnpackedVec Text + +fromPB :: PB -> Concrete +fromPB Project {..} = Project + { projectRootDir = T.unpack projectRootDir + , projectBlobs = go projectBlobs + , projectLanguage = projectLanguage + , projectEntryPaths = T.unpack <$> go projectEntryPaths + , projectExcludeDirs = T.unpack <$> go projectExcludeDirs + } where go :: Foldable f => f a -> [a] + go = foldr (:) [] + +projectName :: Concrete -> Text projectName = T.pack . dropExtensions . takeFileName . projectRootDir -projectExtensions :: Project -> [String] +projectExtensions :: Concrete -> [String] projectExtensions = extensionsForLanguage . projectLanguage +projectEntryPoints :: Concrete -> [File] +projectEntryPoints (Project {..})= foldr go [] projectBlobs + where go b acc = + if blobPath b `elem` projectEntryPaths + then toFile b : acc + else acc + +projectFiles :: Concrete -> [File] +projectFiles = fmap toFile . projectBlobs where + data File = File { filePath :: FilePath @@ -29,3 +62,6 @@ data File = File file :: FilePath -> File file path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension + +toFile :: Blob -> File +toFile (Blob _ p l) = File p l diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b18c32dcd..9d778618e 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -27,6 +27,7 @@ import Data.Abstract.Package as Package import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith) import Data.Graph import Data.Project +import qualified Data.Project as Project (Concrete) import Data.Record import Data.Term import Data.Text (pack) @@ -40,7 +41,7 @@ data GraphType = ImportGraph | CallGraph runGraph :: ( Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs) => GraphType -> Bool - -> Project + -> Project.Concrete -> Eff effs (Graph Vertex) runGraph graphType includePackages project | SomeAnalysisParser parser prelude <- someAnalysisParser @@ -71,21 +72,21 @@ runGraph graphType includePackages project parsePackage :: (Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs) => Parser term -- ^ A parser. -> Maybe File -- ^ Prelude (optional). - -> Project -- ^ Project to parse into a package. + -> Project.Concrete -- ^ Project to parse into a package. -> Eff effs (Package term) parsePackage parser preludeFile project@Project{..} = do prelude <- traverse (parseModule parser Nothing) preludeFile p <- parseModules parser project resMap <- Task.resolutionMap project - let pkg = Package.fromModules n Nothing prelude (length projectEntryPoints) p resMap + let pkg = Package.fromModules n Nothing prelude (length projectEntryPaths) p resMap pkg <$ trace ("project: " <> show pkg) where n = name (projectName project) -- | Parse all files in a project into 'Module's. - parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term] - parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir)) + parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project.Concrete -> Eff effs [Module term] + parseModules parser Project{..} = distributeFor (projectEntryPoints project <> projectFiles project) (WrapTask . parseModule parser (Just projectRootDir)) -- | Parse a file into a 'Module'. parseModule :: (Member Files effs, Member Task effs) => Parser term -> Maybe FilePath -> File -> Eff effs (Module term) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index c6aa9a8af..8af6c7a23 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -39,12 +39,14 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.Blob as Blob import Data.Bool -import Data.Project +import Data.Project (File (..), Project (..)) +import qualified Data.Project as Project import qualified Data.ByteString as B import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL import Data.Language import Data.Source (fromUTF8, fromText) +import qualified Data.Text as T import Prelude hiding (readFile) import Prologue hiding (MonadError (..), fail) import System.Directory (doesDirectoryExist) @@ -98,7 +100,7 @@ readBlobFromPath file = do maybeFile <- readFile file maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile -readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project.Concrete readProjectFromPaths maybeRoot path lang excludeDirs = do isDir <- isDirectory path let (filterFun, entryPoints, rootDir) = if isDir @@ -106,9 +108,11 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot) paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs - pure $ Project rootDir (toFile <$> paths) lang entryPoints excludeDirs + blobs <- traverse (readBlobFromPath . toFile) paths + + pure $ Project rootDir blobs lang (filePath <$> entryPoints) excludeDirs where - toFile path = File path lang + toFile p = File p lang exts = extensionsForLanguage lang -- Recursively find files in a directory. @@ -203,7 +207,7 @@ readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] - readBlobPairs (Left handle) = send (Read (FromPairHandle handle)) readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths -readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project +readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project.Concrete readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath] @@ -247,7 +251,7 @@ data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode) -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's. data Files out where Read :: Source out -> Files out - ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project + ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project.Concrete FindFiles :: FilePath -> [String] -> [FilePath] -> Files [FilePath] Write :: Destination -> B.Builder -> Files () diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 438af10c3..81fa45e9b 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -6,6 +6,7 @@ import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Blob import Data.Project +import qualified Data.Project as Project (Concrete) import qualified Data.Map as Map import Data.Source import Data.Language @@ -29,7 +30,7 @@ nodeJSResolutionMap rootDir prop excludeDirs = do where relPkgDotJSONPath = makeRelative rootDir path relEntryPath x = takeDirectory relPkgDotJSONPath x -resolutionMap :: Member Resolution effs => Project -> Eff effs (Map FilePath FilePath) +resolutionMap :: Member Resolution effs => Project.Concrete -> Eff effs (Map FilePath FilePath) resolutionMap Project{..} = case projectLanguage of TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs) JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)