From 4684e3a7986c6d6924644fd68f0a192a577bc5b9 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 12:39:13 -0400 Subject: [PATCH] Overhaul catFile. --- semantic.cabal | 7 +++++-- src/Data/Blob/IO.hs | 2 +- src/Semantic/Git.hs | 33 ++++++++++++++++++++++----------- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index ba1e07d2a..20b5a9083 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -68,6 +68,7 @@ common dependencies , semilattices ^>= 0.0.0.3 , shelly >= 1.5 && <2 , streaming ^>= 0.2.2.0 + , streaming-bytestring ^>= 0.1.6 , text ^>= 1.2.3.1 , these >= 0.7 && <1 , unix ^>= 2.7.2.2 @@ -311,6 +312,7 @@ library , semantic-tags ^>= 0 , semigroupoids ^>= 5.3.2 , split ^>= 0.2.3.3 + , streaming-process ^>= 0.1 , stm-chans ^>= 3.0.0.4 , template-haskell ^>= 2.14 , time ^>= 1.8.0.2 @@ -410,15 +412,16 @@ test-suite parse-examples , foldl ^>= 1.4.5 , resourcet ^>= 1.2 , streaming - , streaming-bytestring ^>= 0.1.6 + , streaming-bytestring , tasty , tasty-hunit benchmark evaluation import: haskell, dependencies, executable-flags - hs-source-dirs: bench/evaluation + hs-source-dirs: bench type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: Evaluation ghc-options: -static build-depends: base , algebraic-graphs diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index df942cba0..c4600e216 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -58,7 +58,7 @@ readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybe , not (pathIsMinified path) , path `notElem` excludePaths , null includePaths || path `elem` includePaths - = Just . sourceBlob' path lang oid . Source.fromText <$> Git.catFile gitDir oid + = Just . sourceBlob' path lang oid <$> Git.catFile gitDir oid blobFromTreeEntry _ _ = pure Nothing sourceBlob' filepath language (Git.OID oid) source = makeBlob source filepath language oid diff --git a/src/Semantic/Git.hs b/src/Semantic/Git.hs index 954365184..120559e34 100644 --- a/src/Semantic/Git.hs +++ b/src/Semantic/Git.hs @@ -15,23 +15,34 @@ module Semantic.Git , parseEntry ) where -import Control.Monad.IO.Class -import Data.Attoparsec.Text (Parser) -import Data.Attoparsec.Text as AP -import Data.Char -import Data.Either (fromRight) -import Data.Text as Text -import Shelly hiding (FilePath) +import Prologue + +import Data.Attoparsec.Text (Parser) +import Data.Attoparsec.Text as AP +import qualified Data.ByteString.Streaming as ByteStream +import Data.Char +import Data.Either (fromRight) +import Data.Text as Text +import Shelly hiding (FilePath) +import Streaming hiding (run) +import qualified Streaming.Process +import System.Exit +import qualified System.Process as Process (proc) +import qualified Source.Source as Source -- | git clone --bare clone :: Text -> FilePath -> IO () clone url path = sh $ do run_ "git" ["clone", "--bare", url, pack path] --- | git cat-file -p -catFile :: FilePath -> OID -> IO Text -catFile gitDir (OID oid) = sh $ do - run "git" ["-C", pack gitDir, "cat-file", "-p", oid] +-- | Runs @git cat-file -p@. Throws 'ProcessExitedUnsuccessfully' if the +-- underlying git command returns a nonzero exit code. Loads the contents +-- of the file into memory all at once and strictly. +catFile :: FilePath -> OID -> IO Source.Source +catFile gitDir (OID oid) = + let process = Process.proc "git" ["-C", gitDir, "cat-file", "-p", Text.unpack oid] + consumeStdout stream = Streaming.Process.withProcessOutput stream ByteStream.toStrict_ + in Source.fromUTF8 <$> Streaming.Process.withStreamProcess process consumeStdout -- | git ls-tree -rz lsTree :: FilePath -> OID -> IO [TreeEntry]