github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-23 06:41:45 +03:00
Code Issues Projects Releases Wiki Activity

Combine the reading options for files behind a Source datatype.

Browse Source
This commit is contained in:
Rob Rix 2018-05-11 19:43:16 -04:00
parent 1775354e4c
commit 29af2ed78d
1 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
src/Semantic/IO.hs
View File

@ -62,14 +62,14 @@ readFile (File path language) = do
pure $ Blob.sourceBlob path language . fromBytes <$> raw pure $ Blob.sourceBlob path language . fromBytes <$> raw
readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair
readFilePair a b = do readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b)
before <- readFile a
after <- readFile b maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b)
case (before, after) of maybeThese a b = case (a, b) of
(Just a, Nothing) -> pure (Join (This a)) (Just a, Nothing) -> pure (This a)
(Nothing, Just b) -> pure (Join (That b)) (Nothing, Just b) -> pure (That b)
(Just a, Just b) -> pure (Join (These a b)) (Just a, Just b) -> pure (These a b)
_ -> fail "expected file pair with content on at least one side" _ -> fail "expected file pair with content on at least one side"
isDirectory :: MonadIO m => FilePath -> m Bool isDirectory :: MonadIO m => FilePath -> m Bool
isDirectory path = liftIO (doesDirectoryExist path) isDirectory path = liftIO (doesDirectoryExist path)
@ -196,15 +196,17 @@ newtype FormatNotSupported = FormatNotSupported String
deriving (Eq, Exception, Ord, Show, Typeable) deriving (Eq, Exception, Ord, Show, Typeable)
readBlob :: Member Files effs => File -> Eff effs Blob.Blob readBlob :: Member Files effs => File -> Eff effs Blob.Blob
readBlob = send . ReadBlob 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. -- | 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.Blob] readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob.Blob]
readBlobs = send . ReadBlobs 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. -- | 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 [Blob.BlobPair] readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [Blob.BlobPair]
readBlobPairs = send . ReadBlobPairs 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
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
@ -226,24 +228,27 @@ stdout = WriteHandle IO.stdout
stderr :: Handle 'IO.WriteMode stderr :: Handle 'IO.WriteMode
stderr = WriteHandle IO.stderr stderr = WriteHandle IO.stderr
data Source blob where
FromPath :: File -> Source Blob.Blob
FromHandle :: Handle 'IO.ReadMode -> Source [Blob.Blob]
FromPathPair :: Both File -> Source Blob.BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [Blob.BlobPair]
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode) data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's. -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
data Files out where data Files out where
ReadBlob :: File -> Files Blob.Blob Read :: Source out -> Files out
ReadBlobs :: Either (Handle 'IO.ReadMode) [File] -> Files [Blob.Blob] ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
ReadBlobPairs :: Either (Handle 'IO.ReadMode) [Both File] -> Files [Blob.BlobPair] Write :: Destination -> B.Builder -> Files ()
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
Write :: Destination -> B.Builder -> Files ()
-- | Run a 'Files' effect in 'IO'. -- | Run a 'Files' effect in 'IO'.
runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
runFiles = interpret $ \ files -> case files of runFiles = interpret $ \ files -> case files of
ReadBlob path -> rethrowing (readBlobFromPath path) Read (FromPath path) -> rethrowing (readBlobFromPath path)
ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle) Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths)
ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (flip B.hPutBuilder builder)) Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (flip B.hPutBuilder builder))
Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder) Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)