Fix all the tests.

test/Parsing/Spec.hs

@@ -1,11 +1,11 @@
+{-# LANGUAGE TypeApplications #-}
 module Parsing.Spec (spec) where
 
-import Data.AST
 import Data.Blob
 import Data.ByteString.Char8 (pack)
 import Data.Duration
+import Data.Either
 import Data.Language
-import Data.Maybe
 import Parsing.TreeSitter
 import Source.Source
 import SpecHelpers
@@ -19,15 +19,15 @@ spec = do
 
     it "returns a result when the timeout does not expire" $ do
       let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout
-      let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskC (Maybe (AST [] Grammar))
+      let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
       result <- runTaskOrDie parseTask
-      (isJust result) `shouldBe` True
+      isRight result `shouldBe` True
 
     it "returns nothing when the timeout expires" $ do
       let timeout = fromMicroseconds 1000
-      let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskC (Maybe (AST [] Grammar))
+      let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
       result <- runTaskOrDie parseTask
-      (isNothing result) `shouldBe` True
+      isLeft result `shouldBe` True
 
 toJSONSource :: Show a => a -> Source
 toJSONSource = fromUTF8 . pack . show

test/Rendering/TOC/Spec.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
 module Rendering.TOC.Spec (spec) where
 
+import Analysis.Decorator
 import Analysis.TOCSummary
 import Control.Effect
+import Control.Effect.Parse
 import Data.Aeson hiding (defaultOptions)
 import Data.Bifunctor
 import Data.Bifunctor.Join
@@ -232,10 +234,10 @@ diffWithParser :: ( Eq1 syntax
                   , HasDeclaration syntax
                   , Hashable1 syntax
                   , Member Distribute sig
-                  , Member Task sig
+                  , Member Parse sig
                   , Carrier sig m
                   )
                => Parser (Term syntax Loc)
                -> BlobPair
                -> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
-diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin
+diffWithParser parser blobs = diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob)

test/Reprinting/Spec.hs

@@ -4,6 +4,7 @@ module Reprinting.Spec (spec) where
 
 import SpecHelpers
 
+import           Control.Effect.Parse
 import           Data.Foldable
 import           Streaming hiding (Sum)
 import qualified Streaming.Prelude as Streaming
@@ -66,5 +67,5 @@ spec = describe "reprinting" $ do
         let eitherPrinted = runReprinter src defaultJSONPipeline tagged
         printed <- either (fail "reprinter failed") pure eitherPrinted
 
-        tree' <- runTaskOrDie (parse jsonParser (makeBlob printed path Language.JSON mempty))
+        tree' <- runTaskOrDie (runParseWithConfig (parse jsonParser (makeBlob printed path Language.JSON mempty)))
         length tree' `shouldSatisfy` (/= 0)

test/Semantic/CLI/Spec.hs

@@ -1,5 +1,6 @@
 module Semantic.CLI.Spec (testTree) where
 
+import           Control.Carrier.Parse.Simple
 import           Control.Effect.Reader
 import           Data.ByteString.Builder
 import           Semantic.Api hiding (Blob, BlobPair, File)
@@ -33,7 +34,7 @@ renderDiff ref new = unsafePerformIO $ do
     else ["git", "diff", ref, new]
 {-# NOINLINE renderDiff #-}
 
-testForDiffFixture :: (String, [BlobPair] -> TaskC Builder, [Both File], Path.RelFile) -> TestTree
+testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile) -> TestTree
 testForDiffFixture (diffRenderer, runDiff, files, expected) =
   goldenVsStringDiff
     ("diff fixture renders to " <> diffRenderer <> " " <> show files)
@@ -41,7 +42,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) =
     (Path.toString expected)
     (fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff)
 
-testForParseFixture :: (String, [Blob] -> TaskC Builder, [File], Path.RelFile) -> TestTree
+testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile) -> TestTree
 testForParseFixture (format, runParse, files, expected) =
   goldenVsStringDiff
     ("diff fixture renders to " <> format)
@@ -49,7 +50,7 @@ testForParseFixture (format, runParse, files, expected) =
     (Path.toString expected)
     (fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse)
 
-parseFixtures :: [(String, [Blob] -> TaskC Builder, [File], Path.RelFile)]
+parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile)]
 parseFixtures =
   [ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt")
   , ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json")
@@ -64,7 +65,7 @@ parseFixtures =
         prefix = Path.relDir "test/fixtures/cli"
         run = runReader (PerLanguageModes ALaCarte)
 
-diffFixtures :: [(String, [BlobPair] -> TaskC Builder, [Both File], Path.RelFile)]
+diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile)]
 diffFixtures =
   [ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
   , ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")

test/Semantic/Spec.hs

@@ -20,7 +20,7 @@ spec = do
       output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n"
 
     it "throws if given an unknown language for sexpression output" $ do
-      res <- runTaskWithOptions defaultOptions (runReader (PerLanguageModes ALaCarte) (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]))
+      res <- runTaskWithOptions defaultOptions (runReader (PerLanguageModes ALaCarte) (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob])))
       case res of
         Left exc    -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb")
         Right _bad  -> fail "Expected parseTermBuilder to fail for an unknown language"

test/SpecHelpers.hs

@@ -8,6 +8,7 @@ module SpecHelpers
 , parseTestFile
 , readFilePathPair
 , runTaskOrDie
+, runParseWithConfig
 , TaskSession(..)
 , testEvaluating
 , toList
@@ -20,6 +21,7 @@ module SpecHelpers
 ) where
 
 import Control.Abstract
+import Control.Carrier.Parse.Simple
 import Data.Abstract.ScopeGraph (EdgeLabel(..))
 import qualified Data.Abstract.ScopeGraph as ScopeGraph
 import qualified Data.Abstract.Heap as Heap
@@ -88,16 +90,19 @@ instance IsString Name where
 diffFilePaths :: TaskSession -> Both Path.RelFile -> IO ByteString
 diffFilePaths session paths
   = readFilePathPair paths
-    >>= runTask session . parseDiffBuilder @[] DiffSExpression . pure
+    >>= runTask session . runParse (configTreeSitterParseTimeout (config session)) . parseDiffBuilder @[] DiffSExpression . pure
     >>= either (die . displayException) (pure . runBuilder)
 
 -- | Returns an s-expression parse tree for the specified path.
 parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
 parseFilePath session path = do
   blob <- readBlobFromFile (fileForRelPath path)
-  res <- runTask session . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression (toList blob)
+  res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression (toList blob)
   pure (runBuilder <$> res)
 
+runParseWithConfig :: (Carrier sig m, Member (Reader Config) sig) => ParseC m a -> m a
+runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task
+
 -- | Read two files to a BlobPair.
 readFilePathPair :: Both Path.RelFile -> IO BlobPair
 readFilePathPair paths = let paths' = fmap fileForRelPath paths in
@@ -110,8 +115,8 @@ parseTestFile parser path = runTaskOrDie $ do
   pure (blob, term)
 
 -- Run a Task and call `die` if it returns an Exception.
-runTaskOrDie :: TaskC a -> IO a
-runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
+runTaskOrDie :: ParseC TaskC a -> IO a
+runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } (runParseWithConfig task) >>= either (die . displayException) pure
 
 type TestEvaluatingC term
   = ResumableC (BaseError (AddressError Precise (Val term)))