From 05d737fdc1ee91910c55e2ce79a347ad9b17f824 Mon Sep 17 00:00:00 2001
From: Timothy Clem <timothy.clem@gmail.com>
Date: Fri, 6 Apr 2018 15:04:15 -0700
Subject: [PATCH] Begin to plumb in a graph command

---
 src/Semantic/CLI.hs   | 12 ++++++++++--
 src/Semantic/IO.hs    | 19 +++++++++++++++++++
 src/Semantic/Parse.hs | 19 ++++++++++++++++++-
 src/Semantic/Task.hs  |  2 ++
 4 files changed, 49 insertions(+), 3 deletions(-)

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