Merge branch 'master' into add-explicit-assignment-timeout

semantic.cabal

@@ -81,12 +81,14 @@ library
                      , Data.Diff
                      , Data.Duration
                      , Data.Error
+                     , Data.File
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic
                      , Data.Graph
                      , Data.Graph.ControlFlowVertex
                      , Data.Graph.TermVertex
                      , Data.Graph.DiffVertex
+                     , Data.Handle
                      , Data.History
                      , Data.JSON.Fields
                      , Data.Language
@@ -196,6 +198,7 @@ library
                      , Semantic.REPL
                      , Semantic.Resolution
                      , Semantic.Task
+                     , Semantic.Task.Files
                      , Semantic.Telemetry
                      , Semantic.Telemetry.AsyncQueue
                      , Semantic.Telemetry.Haystack

src/Control/Abstract/Evaluator.hs

@@ -25,7 +25,6 @@ import Control.Monad.Effect.Reader    as X
 import Control.Monad.Effect.Resumable as X
 import Control.Monad.Effect.State     as X
 import Control.Monad.Effect.Trace     as X
-import Control.Monad.IO.Class
 import Prologue hiding (MonadError(..))
 
 -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.

src/Data/Blob.hs

@@ -1,36 +1,48 @@
 {-# LANGUAGE DeriveAnyClass #-}
 module Data.Blob
 ( Blob(..)
+, Blobs(..)
+, decodeBlobs
 , nullBlob
 , sourceBlob
+, noLanguageForBlob
 , BlobPair
 , These(..)
 , blobPairDiffing
 , blobPairInserting
 , blobPairDeleting
+, decodeBlobPairs
 , languageForBlobPair
 , languageTagForBlobPair
 , pathForBlobPair
 , pathKeyForBlobPair
 ) where
 
-import Prologue
+import Prologue hiding (throwError)
-import Proto3.Suite
+
-import Data.Aeson
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Exception
+import           Data.Aeson
+import qualified Data.ByteString.Lazy as BL
+import           Proto3.Suite
+import qualified Proto3.Wire.Decode as Decode
+import qualified Proto3.Wire.Encode as Encode
+
 import Data.JSON.Fields
 import Data.Language
 import Data.Source as Source
-import qualified Proto3.Wire.Encode as Encode
-import qualified Proto3.Wire.Decode as Decode
 
 -- | The source, path, and language of a blob.
 data Blob = Blob
-  { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
+  { blobSource   :: Source   -- ^ The UTF-8 encoded source text of the blob.
-  , blobPath :: FilePath -- ^ The file path to the blob.
+  , blobPath     :: FilePath -- ^ The file path to the blob.
   , blobLanguage :: Language -- ^ The language of this blob.
   }
   deriving (Show, Eq, Generic, Message, Named)
 
+newtype Blobs a = Blobs { blobs :: [a] }
+  deriving (Generic, FromJSON)
+
 instance FromJSON Blob where
   parseJSON = withObject "Blob" $ \b -> inferringLanguage
     <$> b .: "content"
@@ -48,6 +60,16 @@ inferringLanguage src pth lang
   | knownLanguage lang = Blob src pth lang
   | otherwise = Blob src pth (languageForFilePath pth)
 
+decodeBlobs :: BL.ByteString -> Either String [Blob]
+decodeBlobs = fmap blobs <$> eitherDecode
+
+-- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
+newtype NoLanguageForBlob = NoLanguageForBlob FilePath
+  deriving (Eq, Exception, Ord, Show, Typeable)
+
+noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
+noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
+
 -- | Represents a blobs suitable for diffing which can be either a blob to
 -- delete, a blob to insert, or a pair of blobs to diff.
 type BlobPair = Join These Blob
@@ -55,8 +77,8 @@ type BlobPair = Join These Blob
 instance Message BlobPair where
   encodeMessage _ pair = case pair of
     (Join (These a b)) -> Encode.embedded 1 (encodeMessage 1 a) <> Encode.embedded 2 (encodeMessage 1 b)
-    (Join (This a)) -> Encode.embedded 1 (encodeMessage 1 a)
+    (Join (This a))    -> Encode.embedded 1 (encodeMessage 1 a)
-    (Join (That b)) -> Encode.embedded 2 (encodeMessage 1 b)
+    (Join (That b))    -> Encode.embedded 2 (encodeMessage 1 b)
   decodeMessage _ = Join <$> (these <|> this <|> that)
     where
       embeddedAt parser = Decode.at (Decode.embedded'' parser)
@@ -100,8 +122,8 @@ languageForBlobPair (Join (These a b))
     = blobLanguage b
 
 pathForBlobPair :: BlobPair -> FilePath
-pathForBlobPair (Join (This Blob{..})) = blobPath
+pathForBlobPair (Join (This Blob{..}))    = blobPath
-pathForBlobPair (Join (That Blob{..})) = blobPath
+pathForBlobPair (Join (That Blob{..}))    = blobPath
 pathForBlobPair (Join (These _ Blob{..})) = blobPath
 
 languageTagForBlobPair :: BlobPair -> [(String, String)]
@@ -117,3 +139,6 @@ pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
 
 instance ToJSONFields Blob where
   toJSONFields Blob{..} = [ "path" .= blobPath, "language" .= blobLanguage ]
+
+decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
+decodeBlobPairs = fmap blobs <$> eitherDecode

src/Data/File.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Data.File
+  ( File (..)
+  , file
+  , toFile
+  , readBlobFromFile
+  , readBlobFromFile'
+  , readBlobsFromDir
+  , readFilePair
+  , maybeThese
+  ) where
+
+import Prologue
+
+import qualified Data.ByteString as B
+import           System.FilePath.Glob
+import           System.FilePath.Posix
+
+import Data.Blob
+import Data.Language
+import Data.Source
+
+data File = File
+  { filePath     :: FilePath
+  , fileLanguage :: Language
+  } deriving (Eq, Ord, Show)
+
+file :: FilePath -> File
+file path = File path (languageForFilePath path)
+  where languageForFilePath = languageForType . takeExtension
+
+-- This is kind of a wart; Blob and File should be two views of
+-- the same higher-kinded datatype.
+toFile :: Blob -> File
+toFile (Blob _ p l) = File p l
+
+-- | Read a utf8-encoded file to a 'Blob'.
+readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)
+readBlobFromFile (File "/dev/null" _) = pure Nothing
+readBlobFromFile (File path language) = do
+  raw <- liftIO $ B.readFile path
+  pure . Just . sourceBlob path language . fromUTF8 $ raw
+
+-- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found.
+readBlobFromFile' :: MonadIO m => File -> m Blob
+readBlobFromFile' file = do
+  maybeFile <- readBlobFromFile file
+  maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
+
+readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
+readBlobsFromDir path = do
+  paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
+  let paths' = fmap (\p -> File p (languageForFilePath p)) paths
+  blobs <- traverse readBlobFromFile paths'
+  pure (catMaybes blobs)
+
+readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair
+readFilePair a b = Join <$> join (maybeThese <$> readBlobFromFile a <*> readBlobFromFile b)
+
+maybeThese :: MonadFail m => Maybe a -> Maybe b -> m (These a b)
+maybeThese a b = case (a, b) of
+  (Just a, Nothing) -> pure (This a)
+  (Nothing, Just b) -> pure (That b)
+  (Just a, Just b)  -> pure (These a b)
+  _                 -> Prologue.fail "expected file pair with content on at least one side"

src/Data/Handle.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE GADTs #-}
+
+module Data.Handle
+  ( Handle (..)
+  , getHandle
+  , stdin
+  , stdout
+  , stderr
+  , readBlobsFromHandle
+  , readBlobPairsFromHandle
+  , readFromHandle
+  , openFileForReading
+  ) where
+
+import Prologue
+
+import           Data.Aeson
+import qualified Data.ByteString.Lazy as BL
+import           System.Exit
+import qualified System.IO as IO
+
+import Data.Blob
+
+data Handle mode where
+  ReadHandle  :: IO.Handle -> Handle 'IO.ReadMode
+  WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
+
+deriving instance Eq   (Handle mode)
+deriving instance Show (Handle mode)
+
+getHandle :: Handle mode -> IO.Handle
+getHandle (ReadHandle  handle) = handle
+getHandle (WriteHandle handle) = handle
+
+stdin :: Handle 'IO.ReadMode
+stdin = ReadHandle IO.stdin
+
+stdout :: Handle 'IO.WriteMode
+stdout = WriteHandle IO.stdout
+
+stderr :: Handle 'IO.WriteMode
+stderr = WriteHandle IO.stderr
+
+openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
+openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
+
+-- | Read JSON encoded blobs from a handle.
+readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
+readBlobsFromHandle = fmap blobs <$> readFromHandle
+
+-- | Read JSON encoded blob pairs from a handle.
+readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
+readBlobPairsFromHandle = fmap blobs <$> readFromHandle
+
+readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
+readFromHandle (ReadHandle h) = do
+  input <- liftIO $ BL.hGetContents h
+  case eitherDecode input of
+    Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
+    Right d -> pure d

src/Data/Project.hs

@@ -11,9 +11,7 @@ module Data.Project (
   , projectName
   , projectFiles
   , readFile
-  -- * Files
+  , readProjectFromPaths
-  , File (..)
-  , file
   ) where
 
 import Prelude hiding (readFile)
@@ -22,10 +20,12 @@ import Prologue hiding (throwError)
 import           Control.Monad.Effect
 import           Control.Monad.Effect.Exception
 import           Data.Blob
+import           Data.File
 import           Data.Language
 import qualified Data.Text as T
 import           Proto3.Suite
 import           System.FilePath.Posix
+import           Semantic.IO
 
 -- | A 'ProjectF' contains all the information that semantic needs
 -- to execute an analysis, diffing, or graphing pass. It is higher-kinded
@@ -73,20 +73,6 @@ projectExtensions = extensionsForLanguage . projectLanguage
 projectFiles :: Project -> [File]
 projectFiles = fmap toFile . projectBlobs
 
-data File = File
-  { filePath     :: FilePath
-  , fileLanguage :: Language
-  } deriving (Eq, Ord, Show)
-
-file :: FilePath -> File
-file path = File path (languageForFilePath path)
-  where languageForFilePath = languageForType . takeExtension
-
--- This is kind of a wart; Blob and File should be two views of
--- the same higher-kinded datatype.
-toFile :: Blob -> File
-toFile (Blob _ p l) = File p l
-
 newtype ProjectException
   = FileNotFound FilePath
     deriving (Show, Eq, Typeable, Exception)
@@ -102,3 +88,17 @@ readFile Project{..} f =
     | p == "/dev/null"  -> pure Nothing
     | isJust candidate  -> pure candidate
     | otherwise         -> throwError (SomeException (FileNotFound p))
+
+readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
+readProjectFromPaths maybeRoot path lang excludeDirs = do
+  isDir <- isDirectory path
+  let rootDir = if isDir
+      then fromMaybe path maybeRoot
+      else fromMaybe (takeDirectory path) maybeRoot
+
+  paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
+  blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
+  pure $ Project rootDir blobs lang excludeDirs
+  where
+    toFile path = File path lang
+    exts = extensionsForLanguage lang

src/Parsing/TreeSitter.hs

@@ -11,7 +11,6 @@ import qualified Control.Exception as Exc (bracket)
 import           Control.Monad.Effect
 import           Control.Monad.Effect.Resource
 import           Control.Monad.Effect.Trace
-import           Control.Monad.IO.Class
 import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import           Foreign
 import           Foreign.C.Types (CBool (..))

src/Prologue.hs

@@ -36,6 +36,7 @@ import Control.Arrow as X ((&&&), (***))
 import Control.Monad as X hiding (fail, return)
 import Control.Monad.Except as X (MonadError (..))
 import Control.Monad.Fail as X (MonadFail (..))
+import Control.Monad.IO.Class as X (MonadIO (..))
 import Data.Algebra as X
 import Data.Bifoldable as X
 import Data.Bifunctor as X (Bifunctor (..))

src/Semantic/AST.hs

@@ -12,7 +12,6 @@ import Data.Blob
 import Parsing.Parser
 import Prologue hiding (MonadError(..))
 import Rendering.JSON (renderJSONAST)
-import Semantic.IO (noLanguageForBlob)
 import Semantic.Task
 import qualified Serializing.Format as F
 

src/Semantic/CLI.hs

@@ -6,10 +6,11 @@ module Semantic.CLI
 , Parse.runParse
 ) where
 
-import           Control.Monad.IO.Class
+import           Data.File
-import           Data.Language (ensureLanguage)
+import           Data.Language (ensureLanguage, languageForFilePath)
 import           Data.List (intercalate, uncons)
 import           Data.List.Split (splitWhen)
+import           Data.Handle
 import           Data.Project
 import           Options.Applicative hiding (style)
 import           Prologue
@@ -18,9 +19,9 @@ import qualified Semantic.AST as AST
 import           Semantic.Config
 import qualified Semantic.Diff as Diff
 import qualified Semantic.Graph as Graph
-import           Semantic.IO as IO
 import qualified Semantic.Parse as Parse
 import qualified Semantic.Task as Task
+import           Semantic.Task.Files
 import qualified Semantic.Telemetry.Log as Log
 import           Semantic.Version
 import           System.FilePath
@@ -118,7 +119,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
           <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
     makeReadProjectFromPathsTask language maybePaths = do
       paths <- maybeM (liftIO (many getLine)) maybePaths
-      blobs <- traverse IO.readBlob (flip File language <$> paths)
+      blobs <- traverse readBlobFromFile' (flip File language <$> paths)
       pure $! Project (takeDirectory (maybe "/" fst (uncons paths))) blobs language []
     readProjectRecursively = makeReadProjectRecursivelyTask
       <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))

src/Semantic/Diff.hs

@@ -17,7 +17,6 @@ import Parsing.Parser
 import Prologue hiding (MonadError(..))
 import Rendering.Graph
 import Rendering.Renderer
-import Semantic.IO (noLanguageForBlob)
 import Semantic.Telemetry as Stat
 import Semantic.Task as Task
 import Serializing.Format

src/Semantic/Distribute.hs

@@ -10,7 +10,6 @@ module Semantic.Distribute
 import qualified Control.Concurrent.Async as Async
 import           Control.Parallel.Strategies
 import           Control.Monad.Effect
-import           Control.Monad.IO.Class
 import           Prologue hiding (MonadError (..))
 
 -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.

src/Semantic/Env.hs

@@ -4,7 +4,6 @@ module Semantic.Env
   , envLookupString
   ) where
 
-import Control.Monad.IO.Class
 import Prologue
 import System.Environment
 import Text.Read (readMaybe)

src/Semantic/Graph.hs

@@ -45,6 +45,7 @@ import           Data.Abstract.Value.Concrete as Concrete
     (Value, ValueError (..), runWhile, runBoolean, runFunction, runValueErrorWith)
 import           Data.Abstract.Value.Type as Type
 import           Data.Blob
+import           Data.File
 import           Data.Graph
 import           Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy)
 import           Data.Language as Language

src/Semantic/IO.hs

@@ -1,117 +1,20 @@
-{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.IO
-( Destination(..)
+  ( isDirectory
-, Files
+  , findFilesInDir
-, Handle(..)
+  ) where
-, IO.IOMode(..)
+
-, NoLanguageForBlob(..)
+import Prelude hiding (readFile)
-, Source(..)
+import Prologue hiding (MonadError (..), fail)
-, findFiles
-, findFilesInDir
-, getHandle
-, isDirectory
-, languageForFilePath
-, noLanguageForBlob
-, openFileForReading
-, readBlob
-, readBlobFromPath
-, readBlobPairs
-, readBlobPairsFromHandle
-, readBlobs
-, readBlobsFromDir
-, readBlobsFromHandle
-, decodeBlobPairs
-, decodeBlobs
-, readFile
-, readFilePair
-, readProject
-, readProjectFromPaths
-, rethrowing
-, runFiles
-, stderr
-, stdin
-, stdout
-, write
-) where
 
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
-import           Control.Monad.IO.Class
-import           Data.Aeson
-import           Data.Blob
-import           Data.Bool
-import           Data.Project hiding (readFile)
-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)
-import           Prelude hiding (readFile)
-import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
+import           System.Directory.Tree (AnchoredDirTree (..))
 import qualified System.Directory.Tree as Tree
-import           System.Directory.Tree (AnchoredDirTree(..))
-import           System.Exit
 import           System.FilePath
-import           System.FilePath.Glob
-import qualified System.IO as IO
-
--- | Read a utf8-encoded file to a 'Blob'.
-readFile :: forall m. MonadIO m => File -> m (Maybe Blob)
-readFile (File "/dev/null" _) = pure Nothing
-readFile (File path language) = do
-  raw <- liftIO $ B.readFile path
-  pure . Just . sourceBlob path language . fromUTF8 $ raw
-
-readFilePair :: forall m. MonadIO m => File -> File -> m BlobPair
-readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b)
-
-maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b)
-maybeThese a b = case (a, b) of
-  (Just a, Nothing) -> pure (This a)
-  (Nothing, Just b) -> pure (That b)
-  (Just a, Just b)  -> pure (These a b)
-  _                 -> fail "expected file pair with content on at least one side"
-
-newtype Blobs a = Blobs { blobs :: [a] }
-  deriving (Generic, FromJSON)
 
 isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path)
 
-decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
-decodeBlobPairs = fmap blobs <$> eitherDecode
-
--- | Read JSON encoded blob pairs from a handle.
-readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
-readBlobPairsFromHandle = fmap blobs <$> readFromHandle
-
-decodeBlobs :: BL.ByteString -> Either String [Blob]
-decodeBlobs = fmap blobs <$> eitherDecode
-
--- | Read JSON encoded blobs from a handle.
-readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
-readBlobsFromHandle = fmap blobs <$> readFromHandle
-
-readBlobFromPath :: MonadIO m => File -> m Blob
-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 maybeRoot path lang excludeDirs = do
-  isDir <- isDirectory path
-  let rootDir = if isDir
-      then fromMaybe path maybeRoot
-      else fromMaybe (takeDirectory path) maybeRoot
-
-  paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
-  blobs <- liftIO $ traverse (readBlobFromPath . toFile) paths
-  pure $ Project rootDir blobs lang excludeDirs
-  where
-    toFile path = File path lang
-    exts = extensionsForLanguage lang
-
 -- Recursively find files in a directory.
 findFilesInDir :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
 findFilesInDir path exts excludeDirs = do
@@ -135,106 +38,3 @@ findFilesInDir path exts excludeDirs = do
       | n `elem` dirs = False
       | otherwise = True
     notIn _ _ = True
-
-readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
-readBlobsFromDir path = do
-  paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
-  let paths' = fmap (\p -> File p (languageForFilePath p)) paths
-  blobs <- traverse readFile paths'
-  pure (catMaybes blobs)
-
-readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
-readFromHandle (ReadHandle h) = do
-  input <- liftIO $ BL.hGetContents h
-  case eitherDecode input of
-    Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
-    Right d -> pure d
-
-
--- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
-newtype NoLanguageForBlob = NoLanguageForBlob FilePath
-  deriving (Eq, Exception, Ord, Show, Typeable)
-
-noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
-noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-
-
-readBlob :: Member Files effs => File -> Eff effs Blob
-readBlob = send . Read . FromPath
-
--- | 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 'IO.ReadMode) [File] -> Eff effs [Blob]
-readBlobs (Left handle) = send (Read (FromHandle handle))
-readBlobs (Right paths) = traverse (send . Read . FromPath) paths
-
--- | 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 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
-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 rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
-
-findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
-findFiles dir exts = send . FindFiles dir exts
-
--- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
-write :: Member Files effs => Destination -> B.Builder -> Eff effs ()
-write dest = send . Write dest
-
-data Handle mode where
-  ReadHandle  :: IO.Handle -> Handle 'IO.ReadMode
-  WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
-
-deriving instance Eq   (Handle mode)
-deriving instance Show (Handle mode)
-
-getHandle :: Handle mode -> IO.Handle
-getHandle (ReadHandle  handle) = handle
-getHandle (WriteHandle handle) = handle
-
-stdin :: Handle 'IO.ReadMode
-stdin = ReadHandle IO.stdin
-
-stdout :: Handle 'IO.WriteMode
-stdout = WriteHandle IO.stdout
-
-stderr :: Handle 'IO.WriteMode
-stderr = WriteHandle IO.stderr
-
-openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
-openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
-
-data Source blob where
-  FromPath       :: File                -> Source Blob
-  FromHandle     :: Handle 'IO.ReadMode -> Source [Blob]
-  FromPathPair   :: Both File           -> Source BlobPair
-  FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
-
-data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-
--- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
-data Files (m :: * -> *) out where
-  Read        :: Source out                                           -> Files m out
-  ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
-  FindFiles   :: FilePath -> [String] -> [FilePath]                   -> Files m [FilePath]
-  Write       :: Destination -> B.Builder                             -> Files m ()
-
-instance PureEffect Files
-instance Effect Files where
-  handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
-  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
-  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
-  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
-
--- | Run a 'Files' effect in 'IO'.
-runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
-runFiles = interpret $ \ files -> case files of
-  Read (FromPath path)         -> rethrowing (readBlobFromPath path)
-  Read (FromHandle handle)     -> rethrowing (readBlobsFromHandle handle)
-  Read (FromPathPair paths)    -> rethrowing (runBothWith readFilePair paths)
-  Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
-  ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
-  FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
-  Write (ToPath path)                   builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
-  Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)

src/Semantic/Parse.hs

@@ -19,7 +19,6 @@ import           Rendering.Graph
 import           Rendering.JSON (SomeJSON (..))
 import qualified Rendering.JSON as JSON
 import           Rendering.Renderer
-import           Semantic.IO (noLanguageForBlob)
 import           Semantic.Task
 import           Serializing.Format
 

src/Semantic/REPL.hs

@@ -6,7 +6,6 @@ module Semantic.REPL
 
 import Control.Abstract hiding (Continue, List, string)
 import Control.Monad.Effect.Resource
-import Control.Monad.IO.Class
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.Environment as Env
 import Data.Abstract.Evaluatable hiding (string)
@@ -16,6 +15,7 @@ import Data.Abstract.Package
 import Data.Abstract.Value.Concrete as Concrete
 import Data.Blob (Blob(..))
 import Data.Error (showExcerpt)
+import Data.File (File (..), readBlobFromFile)
 import Data.Graph (topologicalSort)
 import Data.Language as Language
 import Data.List (uncons)
@@ -30,9 +30,9 @@ import Prologue hiding (throwError)
 import Semantic.Config (logOptionsFromConfig)
 import Semantic.Distribute
 import Semantic.Graph
-import Semantic.IO as IO
 import Semantic.Resolution
 import Semantic.Task hiding (Error)
+import qualified Semantic.Task.Files as Files
 import Semantic.Telemetry
 import Semantic.Timeout
 import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage)
@@ -71,8 +71,8 @@ runREPL prefs settings = interpret $ \case
 
 rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
 
-repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
+repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do
-  blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths)
+  blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
   package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)
   homeDir <- liftIO getHomeDirectory

src/Semantic/Resolution.hs

@@ -10,12 +10,13 @@ import           Control.Monad.Effect
 import           Data.Aeson
 import           Data.Aeson.Types (parseMaybe)
 import           Data.Blob
+import           Data.File
 import           Data.Project
 import qualified Data.Map as Map
 import           Data.Source
 import           Data.Language
 import           Prologue
-import           Semantic.IO
+import           Semantic.Task.Files
 import           System.FilePath.Posix
 
 

src/Semantic/Task.hs

@@ -5,12 +5,12 @@ module Semantic.Task
 , Level(..)
 , RAlgebra
 -- * I/O
-, IO.readBlob
+, Files.readBlob
-, IO.readBlobs
+, Files.readBlobs
-, IO.readBlobPairs
+, Files.readBlobPairs
-, IO.readProject
+, Files.readProject
-, IO.findFiles
+, Files.findFiles
-, IO.write
+, Files.write
 -- * Module Resolution
 , resolutionMap
 , Resolution
@@ -83,8 +83,8 @@ import           Parsing.TreeSitter
 import           Prologue hiding (MonadError (..), project)
 import           Semantic.Config
 import           Semantic.Distribute
+import qualified Semantic.Task.Files as Files
 import           Semantic.Timeout
-import qualified Semantic.IO as IO
 import           Semantic.Resolution
 import           Semantic.Telemetry
 import           Serializing.Format hiding (Options)
@@ -93,7 +93,7 @@ import           System.Exit (die)
 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
 type TaskEff = Eff '[ Task
                     , Resolution
-                    , IO.Files
+                    , Files.Files
                     , Reader Config
                     , Trace
                     , Telemetry
@@ -159,7 +159,7 @@ runTaskWithConfig options logger statter task = do
           . runTelemetry logger statter
           . runTraceInTelemetry
           . runReader options
-          . IO.runFiles
+          . Files.runFiles
           . runResolution
           . runTaskF
     run task

src/Semantic/Task/Files.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
+
+module Semantic.Task.Files
+  ( Files
+  , Destination (..)
+  , Source (..)
+  , runFiles
+  , readBlob
+  , readBlobs
+  , readBlobPairs
+  , readProject
+  , findFiles
+  , write
+  , Handle (..)
+  ) where
+
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Exception
+import qualified Data.ByteString.Builder as B
+import           Data.Blob
+import           Data.File
+import           Data.Handle
+import           Data.Language
+import           Data.Project hiding (readFile)
+import           Prelude hiding (readFile)
+import           Prologue hiding (MonadError (..), fail)
+import           Semantic.IO
+import qualified System.IO as IO
+
+data Source blob where
+  FromPath       :: File                -> Source Blob
+  FromHandle     :: Handle 'IO.ReadMode -> Source [Blob]
+  FromPathPair   :: Both File           -> Source BlobPair
+  FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
+
+data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
+
+-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
+data Files (m :: * -> *) out where
+  Read        :: Source out                                           -> Files m out
+  ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
+  FindFiles   :: FilePath -> [String] -> [FilePath]                   -> Files m [FilePath]
+  Write       :: Destination -> B.Builder                             -> Files m ()
+
+instance PureEffect Files
+instance Effect Files where
+  handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
+  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
+  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
+  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
+
+-- | Run a 'Files' effect in 'IO'.
+runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
+runFiles = interpret $ \ files -> case files of
+  Read (FromPath path)         -> rethrowing (readBlobFromFile' path)
+  Read (FromHandle handle)     -> rethrowing (readBlobsFromHandle handle)
+  Read (FromPathPair paths)    -> rethrowing (runBothWith readFilePair paths)
+  Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
+  ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
+  FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
+  Write (ToPath path)                   builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
+  Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
+
+readBlob :: Member Files effs => File -> Eff effs Blob
+readBlob = send . Read . FromPath
+
+-- | 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 'IO.ReadMode) [File] -> Eff effs [Blob]
+readBlobs (Left handle) = send (Read (FromHandle handle))
+readBlobs (Right paths) = traverse (send . Read . FromPath) paths
+
+-- | 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 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
+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 rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
+
+findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
+findFiles dir exts = send . FindFiles dir exts
+
+-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
+write :: Member Files effs => Destination -> B.Builder -> Eff effs ()
+write dest = send . Write dest

src/Semantic/Telemetry/Log.hs

@@ -8,7 +8,6 @@ module Semantic.Telemetry.Log
   , writeLogMessage
   ) where
 
-import           Control.Monad.IO.Class
 import           Data.Error (withSGRCode)
 import           Data.List (intersperse)
 import qualified Data.Time.Format as Time

src/Semantic/Telemetry/Stat.hs

@@ -27,7 +27,6 @@ module Semantic.Telemetry.Stat
 ) where
 
 
-import           Control.Monad.IO.Class
 import qualified Data.ByteString.Char8 as B
 import           Data.List (intercalate)
 import           Data.List.Split (splitOneOf)

src/Semantic/Util.hs

@@ -18,6 +18,7 @@ import           Data.Abstract.Package
 import           Data.Abstract.Value.Concrete as Concrete
 import           Data.Abstract.Value.Type as Type
 import           Data.Blob
+import           Data.File
 import           Data.Graph (topologicalSort)
 import qualified Data.Language as Language
 import           Data.List (uncons)
@@ -28,7 +29,6 @@ import           Parsing.Parser
 import           Prologue hiding (weaken)
 import           Semantic.Config
 import           Semantic.Graph
-import           Semantic.IO as IO
 import           Semantic.Task
 import           Semantic.Telemetry (LogQueue, StatQueue)
 import           System.Exit (die)
@@ -75,7 +75,7 @@ typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Langu
 typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser
 
 callGraphProject parser proxy opts paths = runTaskWithOptions opts $ do
-  blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths)
+  blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
   package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   x <- runCallGraph proxy False modules package
@@ -92,7 +92,7 @@ evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger
 data TaskConfig = TaskConfig Config LogQueue StatQueue
 
 evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (die . displayException) pure <=< runTaskWithConfig config logger statter $ do
-  blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths)
+  blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
   package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)

src/Semantic/Util/Rewriting.hs

@@ -12,9 +12,9 @@ import           Text.Show.Pretty (pPrint)
 import           Control.Abstract.Matching
 import           Control.Rewriting hiding (fromMatcher, target)
 import           Data.Blob
+import           Data.File
 import           Data.History
 import qualified Data.Language as Language
-import           Data.Project hiding (readFile)
 import qualified Data.Source as Source
 import qualified Data.Syntax.Literal as Literal
 import           Data.Term
@@ -23,12 +23,11 @@ import           Language.Python.PrettyPrint
 import           Language.Ruby.PrettyPrint
 import           Parsing.Parser
 import           Reprinting.Pipeline
-import           Semantic.IO as IO
 import           Semantic.Task
 
 testPythonFile = do
   let path = "test/fixtures/python/reprinting/function.py"
-  src  <- blobSource <$> readBlobFromPath (File path Language.Python)
+  src  <- blobSource <$> readBlobFromFile' (File path Language.Python)
   tree <- parseFile' miniPythonParser path
   pure (src, tree)
 
@@ -50,7 +49,7 @@ testPythonPipeline''' = do
 
 testRubyFile = do
   let path = "test/fixtures/ruby/reprinting/infix.rb"
-  src  <- blobSource <$> readBlobFromPath (File path Language.Ruby)
+  src  <- blobSource <$> readBlobFromFile' (File path Language.Ruby)
   tree <- parseFile' miniRubyParser path
   pure (src, tree)
 
@@ -74,7 +73,7 @@ printToTerm = either (putStrLn . show) (BC.putStr . Source.sourceBytes)
 
 testJSONFile = do
   let path = "test/fixtures/javascript/reprinting/map.json"
-  src  <- blobSource <$> readBlobFromPath (File path Language.JSON)
+  src  <- blobSource <$> readBlobFromFile' (File path Language.JSON)
   tree <- parseFile' jsonParser path
   pure (src, tree)
 

test/Examples.hs

@@ -8,10 +8,10 @@ import qualified Data.ByteString as B
 import           Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as BC
 import           Data.Either
+import           Data.File (file)
 import           Data.Foldable
 import           Data.List
 import           Data.Maybe
-import           Data.Project (file)
 import           Data.Quieterm
 import           Data.Typeable (cast)
 import           Data.Void
@@ -21,6 +21,7 @@ import           Semantic.Config (Config (..), Options (..), defaultOptions)
 import qualified Semantic.IO as IO
 import           Semantic.Parse
 import           Semantic.Task
+import           Semantic.Task.Files
 import           Semantic.Util (TaskConfig (..))
 import           System.Directory
 import           System.Exit (die)
@@ -99,7 +100,7 @@ languages =
   -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
   ]
 
-parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member IO.Files effs) => FilePath -> Eff effs Bool
+parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member Files effs) => FilePath -> Eff effs Bool
 parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
 
 languagesDir :: FilePath

test/Graphing/Calls/Spec.hs

@@ -21,7 +21,7 @@ import           Semantic.IO
 callGraphPythonProject paths = runTaskWithOptions defaultOptions $ do
   let proxy = Proxy @'Language.Python
   let lang = Language.Python
-  blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
+  blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths)
   package <- fmap snd <$> parsePackage pythonParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   runCallGraph proxy False modules package

test/Reprinting/Spec.hs

@@ -29,7 +29,7 @@ spec = describe "reprinting" $ do
   context "JSON" $ do
     let path = "test/fixtures/javascript/reprinting/map.json"
     (src, tree) <- runIO $ do
-      src  <- blobSource <$> readBlobFromPath (File path Language.JSON)
+      src  <- blobSource <$> readBlobFromFile' (File path Language.JSON)
       tree <- parseFile jsonParser path
       pure (src, tree)
 

test/Semantic/IO/Spec.hs

@@ -16,6 +16,8 @@ import qualified TreeSitter.Node as TS
 import qualified TreeSitter.Parser as TS
 import qualified TreeSitter.Tree as TS
 
+import Data.Blob
+import Data.Handle
 import SpecHelpers hiding (readFile)
 
 
@@ -23,17 +25,19 @@ spec :: Spec
 spec = parallel $ do
   describe "readFile" $ do
     it "returns a blob for extant files" $ do
-      Just blob <- readFile (File "semantic.cabal" Unknown)
+      Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
       blobPath blob `shouldBe` "semantic.cabal"
 
     it "throws for absent files" $ do
-      readFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException
+      readBlobFromFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException
 
   describe "readBlobPairsFromHandle" $ do
     let a = sourceBlob "method.rb" Ruby "def foo; end"
     let b = sourceBlob "method.rb" Ruby "def bar(x); end"
     it "returns blobs for valid JSON encoded diff input" $ do
+      putStrLn "step 1"
       blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
+      putStrLn "done"
       blobs `shouldBe` [blobPairDiffing a b]
 
     it "returns blobs when there's no before" $ do
@@ -106,5 +110,7 @@ spec = parallel $ do
 
   where blobsFromFilePath path = do
           h <- openFileForReading path
+          putStrLn "got handle"
           blobs <- readBlobPairsFromHandle h
+          putStrLn "got blobs"
           pure blobs

test/SpecHelpers.hs

@@ -36,6 +36,8 @@ import Data.ByteString.Builder (toLazyByteString)
 import Data.ByteString.Lazy (toStrict)
 import Data.Project as X
 import Data.Proxy as X
+import qualified Data.File as F
+import Data.File as X hiding (readFilePair)
 import Data.Foldable (toList)
 import Data.Functor.Listable as X
 import Data.Language as X
@@ -88,12 +90,12 @@ diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>=
 
 -- | Returns an s-expression parse tree for the specified FilePath.
 parseFilePath :: TaskConfig -> FilePath -> IO ByteString
-parseFilePath (TaskConfig config logger statter) path = (fromJust <$> IO.readFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder)
+parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder)
 
 -- | Read two files to a BlobPair.
 readFilePair :: Both FilePath -> IO BlobPair
 readFilePair paths = let paths' = fmap file paths in
-                     runBothWith IO.readFilePair paths'
+                     runBothWith F.readFilePair paths'
 
 type TestEvaluatingEffects term
   = '[ Resumable (BaseError (ValueError term Precise))