From 284fc30f1cb4dfba538efb095a5bdec335bb5652 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 11:25:34 -0400 Subject: [PATCH 1/7] Reorganize benchmarks. --- bench/{evaluation/Main.hs => Evaluation.hs} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename bench/{evaluation/Main.hs => Evaluation.hs} (100%) diff --git a/bench/evaluation/Main.hs b/bench/Evaluation.hs similarity index 100% rename from bench/evaluation/Main.hs rename to bench/Evaluation.hs From 54394d61c8f7f9c450877f4ded6715fdfacbcbfc Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 12:37:24 -0400 Subject: [PATCH 2/7] Move around and correct benchmarks. --- bench/Evaluation.hs | 10 ++++++---- bench/Main.hs | 9 +++++++++ 2 files changed, 15 insertions(+), 4 deletions(-) create mode 100644 bench/Main.hs diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 405cfe423..b8c43eafd 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -1,9 +1,11 @@ {-# LANGUAGE DataKinds, FlexibleContexts, PackageImports, PartialTypeSignatures, TypeApplications, TypeFamilies #-} -module Main where +module Evaluation (benchmarks) where import Algebra.Graph import Control.Monad +import Control.Carrier.Parse.Simple +import qualified Data.Duration as Duration import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Blob @@ -45,7 +47,7 @@ callGraphProject' :: ( Language.SLanguage lang -> IO (Either String (Data.Graph.Graph ControlFlowVertex)) callGraphProject' session proxy parser path = fmap (first show) . runTask session $ do blob <- readBlobFromFile' (fileForRelPath path) - package <- fmap snd <$> parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] (Language.reflect proxy) []) + package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] (Language.reflect proxy) [])) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package @@ -70,8 +72,8 @@ pyCall p = nfIO $ callGraphProject (Proxy @'Language.Python) pythonParser (Path. rbCall :: Path.RelFile -> Benchmarkable rbCall p = nfIO $ callGraphProject (Proxy @'Language.Ruby) rubyParser $ (Path.relDir "bench/bench-fixtures/ruby" p) -main :: IO () -main = defaultMain +benchmarks :: Benchmark +benchmarks = bgroup "evaluation" [ bgroup "python" [ bench "assignment" . pyEval $ Path.relFile "simple-assignment.py" , bench "function def" . pyEval $ Path.relFile "function-definition.py" , bench "if + function calls" . pyCall . Path.relFile $ "if-statement-functions.py" diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 000000000..c0537e243 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Gauge +import qualified Evaluation + +main :: IO () +main = defaultMain + [ Evaluation.benchmarks + ] From 2aae2af79f94f533b8e77681417dd31e5731aaac Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 12:38:32 -0400 Subject: [PATCH 3/7] Add an NFData instance for Source. --- semantic-source/CHANGELOG.md | 4 ++++ semantic-source/src/Source/Source.hs | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/semantic-source/CHANGELOG.md b/semantic-source/CHANGELOG.md index 50ed229aa..283d03c1e 100644 --- a/semantic-source/CHANGELOG.md +++ b/semantic-source/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.0.0.2 + +- Adds an `NFData` instance for `Source`. + # 0.0.0.1 - Loosens the upper bound on `hashable`. diff --git a/semantic-source/src/Source/Source.hs b/semantic-source/src/Source/Source.hs index 182f5439c..4bea385ad 100644 --- a/semantic-source/src/Source/Source.hs +++ b/semantic-source/src/Source/Source.hs @@ -32,6 +32,7 @@ module Source.Source import Prelude hiding (drop, take) import Control.Arrow ((&&&)) +import Control.DeepSeq (NFData) import Data.Aeson (FromJSON (..), withText) import qualified Data.ByteString as B import Data.Char (ord) @@ -50,7 +51,7 @@ import Source.Span (Span(Span), Pos(..)) -- 'ByteString' under the hood. Construct these with 'fromUTF8'; obviously, -- passing 'fromUTF8' non-UTF8 bytes will cause crashes. newtype Source = Source { bytes :: B.ByteString } - deriving (Eq, Semigroup, Monoid, IsString, Show, Generic) + deriving (Eq, Semigroup, Monoid, IsString, Show, Generic, NFData) fromUTF8 :: B.ByteString -> Source fromUTF8 = Source From 4684e3a7986c6d6924644fd68f0a192a577bc5b9 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 12:39:13 -0400 Subject: [PATCH 4/7] 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] From 2f91bad319dea47c59f21bb06603f63410f8aed1 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 15:49:30 -0400 Subject: [PATCH 5/7] Fix tests. --- test/Semantic/IO/Spec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 324fcd46b..eb10de200 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -15,6 +15,7 @@ import Data.Blob import Data.Handle import qualified Semantic.Git as Git import Shelly (cd, run_, shelly, silently, touchfile, writefile) +import qualified Source.Source as Source import SpecHelpers import System.Path (()) import qualified System.Path as Path @@ -42,7 +43,7 @@ spec = do trees <- Git.lsTree (dir <> "/.git") (Git.OID "HEAD") Just it <- pure $ find (\p -> "日本語" `isInfixOf` Git.treeEntryPath p) trees Git.catFile (dir <> "/.git") (Git.treeEntryOid it) - ("日本語" `Text.isInfixOf` result) `shouldBe` True + Source.toText result `shouldSatisfy` ("日本語" `Text.isInfixOf`) describe "lsTree" $ do hasGit <- runIO $ isJust <$> findExecutable "git" From e5841eb473dd35a33054fac08b55e913e7f338ac Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 15:49:34 -0400 Subject: [PATCH 6/7] Squash warnings. --- src/Semantic/Git.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Git.hs b/src/Semantic/Git.hs index 120559e34..69be0a4bd 100644 --- a/src/Semantic/Git.hs +++ b/src/Semantic/Git.hs @@ -24,9 +24,7 @@ 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 From a3f2816d4da254f79421b68d178355b0e2a155f3 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 4 Oct 2019 17:16:34 -0400 Subject: [PATCH 7/7] New version should be 0.0.1.0. --- semantic-source/CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic-source/CHANGELOG.md b/semantic-source/CHANGELOG.md index 283d03c1e..f1859800e 100644 --- a/semantic-source/CHANGELOG.md +++ b/semantic-source/CHANGELOG.md @@ -1,4 +1,4 @@ -# 0.0.0.2 +# 0.0.1.0 - Adds an `NFData` instance for `Source`.