github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 00:42:33 +03:00
Code Issues Projects Releases Wiki Activity

split up Semantic.IO into Data.Handle and Semantic.Effect.Files

Browse Source
This commit is contained in:
Patrick Thomson 2018-06-11 17:38:31 -04:00
parent 511d412e10
commit 25a3ad2e55
9 changed files with 167 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic.cabal
View File

@ -78,6 +78,7 @@ library
, Data.Graph
, Data.Graph.AdjList
, Data.Graph.Vertex
, Data.Handle
, Data.JSON.Fields
, Data.Language
, Data.Map.Monoidal
@ -154,6 +155,7 @@ library
, Semantic.CLI
, Semantic.Diff
, Semantic.Distribute
, Semantic.Effect.Files
, Semantic.Env
, Semantic.Graph
, Semantic.IO

37
src/Data/Handle.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE GADTs #-}
module Data.Handle
( Handle (..)
, IO.IOMode (..)
, getHandle
, stdin
, stdout
, stderr
, openFileForReading
) where
import qualified System.IO as IO
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

1
src/Parsing/TreeSitter.hs
View File

@ -22,6 +22,7 @@ import Foreign
import Foreign.C.Types (CBool (..))
import Foreign.Marshal.Array (allocaArray)
import Semantic.IO hiding (Source)
import Semantic.Effect.Files (catchException)
import System.Timeout
import qualified TreeSitter.Language as TS

2
src/Semantic/CLI.hs
View File

@ -7,6 +7,7 @@ module Semantic.CLI
, Parse.runParse
) where
import Data.Project
import Data.Language (ensureLanguage)
import Data.List (intercalate)
@ -24,6 +25,7 @@ import Semantic.IO as IO
import qualified Semantic.Log as Log
import qualified Semantic.Parse as Parse
import qualified Semantic.Task as Task
import Semantic.Effect.Files
import Serializing.Format
import Text.Read

113
src/Semantic/Effect/Files.hs Normal file
View File

@ -0,0 +1,113 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
module Semantic.Effect.Files
( Source (..)
, Destination (..)
, Files (..)
, catchException
, findFiles
, readBlob
, readBlobPairs
, readBlobs
, readProject
, runFiles
, runFilesGuided
, write
) where
import qualified Control.Exception as Exc
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Monad.Effect.State
import Control.Monad.IO.Class
import Data.Blob
import qualified Data.ByteString.Builder as B
import Data.Handle
import Data.Language
import Data.Project (File (..), ProjectException (..))
import qualified Data.Project as Project
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import qualified System.IO as IO
import Semantic.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 out where
Read :: Source out -> Files out
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project.Concrete
FindFiles :: FilePath -> [String] -> [FilePath] -> Files [FilePath]
Write :: Destination -> B.Builder -> Files ()
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.Concrete
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
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Exc SomeException) effs, Member IO 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)
runFilesGuided :: (Member (State Project.Concrete) effs, Member (Exc SomeException) effs) => Eff (Files ': effs) a -> Eff effs a
runFilesGuided = interpret $ \files -> case files of
Read (FromHandle _) -> throwError (SomeException HandleNotSupported)
Read (FromPairHandle _) -> throwError (SomeException HandleNotSupported)
Write _ _ -> throwError (SomeException WritesNotSupported)
Read (FromPath path) -> get >>= \p -> Project.readBlobFromPath p path
Read (FromPathPair paths) -> get >>= \p -> runBothWith (Project.readBlobPair p) paths
FindFiles dir exts excludeDirs -> get >>= \p -> pure (Project.findFiles (p { Project.projectExcludeDirs = excludeDirs }) dir exts)
ReadProject{} -> get
-- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.
--
-- Note that while the type allows 'IO' to occur anywhere within the effect list, it must actually occur at the end to be able to run the computation.
catchException :: ( Exc.Exception e
, Member IO r
)
=> Eff r a
-> (e -> Eff r a)
-> Eff r a
catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m
-- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect.
rethrowing :: ( Member (Exc SomeException) r
, Member IO r
)
=> IO a
-> Eff r a
rethrowing m = catchException (liftIO m) (throwError . toException @SomeException)

2
src/Semantic/Graph.hs
View File

@ -34,7 +34,7 @@ import Data.Term
import Data.Text (pack)
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Semantic.IO (Files)
import Semantic.Effect.Files
import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph

131
src/Semantic/IO.hs
View File

@ -1,53 +1,31 @@
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.IO
( Destination(..)
, Files
, Handle(..)
, IO.IOMode(..)
( module X
, NoLanguageForBlob(..)
, Source(..)
, catchException
, findFiles
, findFilesInDir
, getHandle
, isDirectory
, languageForFilePath
, noLanguageForBlob
, openFileForReading
, readBlob
, readBlobFromPath
, readBlobPairs
, readBlobPairsFromHandle
, readBlobs
, readBlobsFromDir
, readBlobsFromHandle
, decodeBlobPairs
, decodeBlobs
, readFile
, readFilePair
, readProject
, readProjectFromPaths
, rethrowing
, runFiles
, runFilesGuided
, stderr
, stdin
, stdout
, write
) where
import qualified Control.Exception as Exc
import Control.Monad.Effect
import Control.Monad.Effect.State
import Control.Monad.Effect.Exception
import Control.Monad.IO.Class
import Data.Aeson
import Data.Blob
import Data.Bool
import qualified Data.Project as Project
import Data.Project (File (..), ProjectException (..))
import Data.Project (File (..))
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)
@ -61,6 +39,8 @@ import System.FilePath
import System.FilePath.Glob
import qualified System.IO as IO
import Data.Handle as X
-- | Read a utf8-encoded file to a 'Blob'.
readFile :: forall m. MonadIO m => File -> m (Maybe Blob)
readFile (File "/dev/null" _) = pure Nothing
@ -166,106 +146,3 @@ newtype NoLanguageForBlob = NoLanguageForBlob FilePath
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.Concrete
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 out where
Read :: Source out -> Files out
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project.Concrete
FindFiles :: FilePath -> [String] -> [FilePath] -> Files [FilePath]
Write :: Destination -> B.Builder -> Files ()
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Exc SomeException) effs, Member IO 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)
runFilesGuided :: (Member (State Project.Concrete) effs, Member (Exc SomeException) effs) => Eff (Files ': effs) a -> Eff effs a
runFilesGuided = interpret $ \files -> case files of
Read (FromHandle _) -> throwError (SomeException HandleNotSupported)
Read (FromPairHandle _) -> throwError (SomeException HandleNotSupported)
Write _ _ -> throwError (SomeException WritesNotSupported)
Read (FromPath path) -> get >>= \p -> Project.readBlobFromPath p path
Read (FromPathPair paths) -> get >>= \p -> runBothWith (Project.readBlobPair p) paths
FindFiles dir exts excludeDirs -> get >>= \p -> pure (Project.findFiles (p { Project.projectExcludeDirs = excludeDirs }) dir exts)
ReadProject{} -> get
-- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.
--
-- Note that while the type allows 'IO' to occur anywhere within the effect list, it must actually occur at the end to be able to run the computation.
catchException :: ( Exc.Exception e
, Member IO r
)
=> Eff r a
-> (e -> Eff r a)
-> Eff r a
catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m
-- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect.
rethrowing :: ( Member (Exc SomeException) r
, Member IO r
)
=> IO a
-> Eff r a
rethrowing m = catchException (liftIO m) (throwError . toException @SomeException)

2
src/Semantic/Resolution.hs
View File

@ -11,7 +11,7 @@ import qualified Data.Map as Map
import Data.Source
import Data.Language
import Prologue
import Semantic.IO
import Semantic.Effect.Files
import System.FilePath.Posix

18
src/Semantic/Task.hs
View File

@ -6,13 +6,7 @@ module Semantic.Task
, WrappedTask'(..)
, Level(..)
, RAlgebra
-- * I/O
, IO.readBlob
, IO.readBlobs
, IO.readBlobPairs
, IO.readProject
, IO.findFiles
, IO.write
, module Semantic.Effect.Files
-- * Module Resolution
, resolutionMap
, Resolution
@ -76,7 +70,7 @@ import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (MonadError (..), project)
import Semantic.Distribute
import qualified Semantic.IO as IO
import Semantic.Effect.Files
import Semantic.Resolution
import Semantic.Log
import Semantic.Queue
@ -90,7 +84,7 @@ import System.IO (stderr)
type TaskEff = Eff '[Distribute WrappedTask
, Task
, Resolution
, IO.Files
, Files
, Reader Options
, Trace
, Telemetry
@ -100,7 +94,7 @@ type TaskEff = Eff '[Distribute WrappedTask
type TaskEff' = Eff '[Distribute WrappedTask'
, Task
, Resolution
, IO.Files
, Files
, State Concrete
, Reader Options
, Trace
@ -170,7 +164,7 @@ runTaskWithOptions' options logger statter task = do
. runTelemetry logger statter
. runTraceInTelemetry
. runReader options
. IO.runFiles
. runFiles
. runResolution
. runTaskF
. runDistribute (run . unwrapTask)
@ -192,7 +186,7 @@ runTaskWithProject proj options task = do
. runTraceInTelemetry
. runReader options
. runState proj
. IO.runFilesGuided
. runFilesGuided
. runResolution
. runTaskF
. runDistribute (run . unwrapTask')