diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f6e84513f..f160f99b8 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -18,7 +18,7 @@ import qualified Paths_semantic as Library (version) import Semantic.IO (languageForFilePath) import qualified Semantic.Diff as Semantic (diffBlobPairs) import qualified Semantic.Log as Log -import qualified Semantic.Parse as Semantic (parseBlobs) +import qualified Semantic.Parse as Semantic (parseBlobs, graph) import qualified Semantic.Task as Task import System.IO (Handle, stdin, stdout) import Text.Read @@ -33,6 +33,9 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs +runGraph :: SomeRenderer TermRenderer -> (FilePath, Maybe Language) -> Task.TaskEff ByteString +runGraph (SomeRenderer r) = Semantic.graph r <=< Task.readBlob + -- | A parser for the application's command-line arguments. -- -- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout. @@ -54,7 +57,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <*> pure Log.logfmtFormatter -- Formatter <*> pure 0 -- ProcessID argumentsParser = (. Task.writeToOutput) . (>>=) - <$> hsubparser (diffCommand <> parseCommand) + <$> hsubparser (diffCommand <> parseCommand <> graphCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout) ) @@ -84,6 +87,11 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <*> ( Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) ) + graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute import/call graph for an entry point")) + graphArgumentsParser = runGraph + <$> flag (SomeRenderer DOTTermRenderer) (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output in DOT graph format (default)") + <*> argument filePathReader (metavar "ENTRY_FILE") + filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of [a, b] | Just lang <- readMaybe a -> Right (b, Just lang) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index be7b494ab..0cab8ed34 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -9,6 +9,8 @@ module Semantic.IO , readBlobsFromDir , languageForFilePath , NoLanguageForBlob(..) +, listFiles +, readBlob , readBlobs , readBlobPairs , writeToOutput @@ -75,6 +77,12 @@ 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 file = do + maybeFile <- uncurry 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 @@ -129,6 +137,11 @@ 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 = 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] @@ -145,6 +158,9 @@ 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] WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () @@ -152,6 +168,9 @@ data Files out where -- | 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) -> rethrowing (readBlobsFromPaths paths) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 99fe52a4d..5413c1172 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -12,8 +12,25 @@ import Data.Record import Parsing.Parser import Prologue hiding (MonadError(..)) import Rendering.Renderer -import Semantic.IO (NoLanguageForBlob(..)) +import Semantic.IO (NoLanguageForBlob(..), Files) import Semantic.Task +import System.FilePath.Posix +import Data.Language as Language + +graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException] effs, Output output) => TermRenderer output -> Blob -> Eff effs ByteString +graph renderer blob@Blob{..} = do + parser <- parserForLanguage blobLanguage + let rootDir = takeDirectory blobPath + paths <- filter (/= blobPath) <$> listFiles rootDir ["go"] + package <- parsePackage "test" parser rootDir (blobPath : paths) + graphImports package + + + where + -- parserForLanguage (Just Language.Ruby) = pure rubyParser + parserForLanguage (Just Language.Go) = pure goParser + parserForLanguage _ = throwError (SomeException (NoLanguageForBlob blobPath)) + parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . parseBlob renderer) blobs diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 8ccf979a8..486074fb8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -7,6 +7,8 @@ module Semantic.Task , RAlgebra , Differ -- * I/O +, IO.listFiles +, IO.readBlob , IO.readBlobs , IO.readBlobPairs , IO.writeToOutput