Merge branch 'master' into java-assignment-continued

src/Analysis/Abstract/Caching.hs

@@ -77,7 +77,6 @@ cachingTerms recur term = do
 
 convergingModules :: ( AbstractValue address value effects
                      , Cacheable term address (Cell address) value
-                     , Member (Allocator address value) effects
                      , Member Fresh effects
                      , Member NonDet effects
                      , Member (Reader (Cache term address (Cell address) value)) effects
@@ -86,6 +85,7 @@ convergingModules :: ( AbstractValue address value effects
                      , Member (State (Cache term address (Cell address) value)) effects
                      , Member (Env address) effects
                      , Member (State (Heap address (Cell address) value)) effects
+                     , Effects effects
                      )
                   => SubtermAlgebra Module term (TermEvaluator term address value effects address)
                   -> SubtermAlgebra Module term (TermEvaluator term address value effects address)

src/Control/Abstract/Primitive.hs

@@ -32,14 +32,12 @@ defineClass :: ( AbstractValue address value effects
                , Member (Reader Span) effects
                )
             => Name
-            -> [Name]
+            -> [address]
             -> Evaluator address value effects a
             -> Evaluator address value effects ()
-defineClass name superclasses scope = define name $ do
-  env <- locally $ do
-    void scope
-    Env.newEnv . Env.head <$> getEnv
-  klass name (map (string . formatName) superclasses) env
+defineClass name superclasses body = define name $ do
+  binds <- Env.head <$> locally (body >> getEnv)
+  klass name superclasses binds
 
 defineNamespace :: ( AbstractValue address value effects
                    , HasCallStack

src/Control/Abstract/Value.hs

@@ -128,9 +128,9 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
   index :: value -> value -> Evaluator address value effects address
 
   -- | Build a class value from a name and environment.
-  klass :: Name                 -- ^ The new class's identifier
-        -> [value]              -- ^ A list of superclasses
-        -> Environment address -- ^ The environment to capture
+  klass :: Name             -- ^ The new class's identifier
+        -> [address]        -- ^ A list of superclasses
+        -> Bindings address -- ^ The environment to capture
         -> Evaluator address value effects value
 
   -- | Build a namespace value from a name and environment stack
@@ -141,7 +141,7 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
             -> Evaluator address value effects value
 
   -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
-  scopedEnvironment :: value -> Evaluator address value effects (Maybe (Environment address))
+  scopedEnvironment :: address -> Evaluator address value effects (Maybe (Environment address))
 
   -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
   --
@@ -189,7 +189,7 @@ makeNamespace :: ( AbstractValue address value effects
                  )
               => Name
               -> address
-              -> Maybe value
+              -> Maybe address
               -> Evaluator address value effects value
 makeNamespace name addr super = do
   superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
@@ -203,11 +203,11 @@ makeNamespace name addr super = do
 evaluateInScopedEnv :: ( AbstractValue address value effects
                        , Member (Env address) effects
                        )
-                    => Evaluator address value effects value
+                    => address
                     -> Evaluator address value effects a
                     -> Evaluator address value effects a
 evaluateInScopedEnv scopedEnvTerm term = do
-  scopedEnv <- scopedEnvTerm >>= scopedEnvironment
+  scopedEnv <- scopedEnvironment scopedEnvTerm
   maybe term (\ env -> locally (bindAll env *> term)) scopedEnv
 
 
@@ -233,19 +233,17 @@ subtermValue = value <=< subtermRef
 
 -- | Returns the address of a value referenced by a 'ValueRef'
 address :: ( AbstractValue address value effects
-           , Member (Allocator address value) effects
            , Member (Env address) effects
            , Member (Resumable (EnvironmentError address)) effects
            )
         => ValueRef address
         -> Evaluator address value effects address
 address (LvalLocal var) = variable var
-address (LvalMember obj prop) = evaluateInScopedEnv (deref obj) (variable prop)
+address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
 address (Rval addr) = pure addr
 
 -- | Evaluates a 'Subterm' to the address of its rval
 subtermAddress :: ( AbstractValue address value effects
-                  , Member (Allocator address value) effects
                   , Member (Env address) effects
                   , Member (Resumable (EnvironmentError address)) effects
                   )

src/Data/Abstract/Environment.hs

@@ -36,7 +36,7 @@ import           Prologue
 
 -- | A map of names to values. Represents a single scope level of an environment chain.
 newtype Bindings address = Bindings { unBindings :: Map.Map Name address }
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 instance Semigroup (Bindings address) where
   (<>) (Bindings a) (Bindings b) = Bindings (a <> b)

src/Data/Abstract/Value/Concrete.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase #-}
 module Data.Abstract.Value.Concrete where
 
 import Control.Abstract
-import Data.Abstract.Environment (Environment, mergeEnvs)
+import Data.Abstract.Environment (Environment, Bindings)
 import qualified Data.Abstract.Environment as Env
 import Data.Abstract.Name
 import qualified Data.Abstract.Number as Number
@@ -24,7 +24,7 @@ data Value address body
   | Symbol Text
   | Tuple [address]
   | Array [address]
-  | Class Name (Environment address)
+  | Class Name [address] (Bindings address)
   | Namespace Name (Environment address)
   | KVPair (Value address body) (Value address body)
   | Hash [Value address body]
@@ -118,10 +118,8 @@ instance ( Coercible body (Eff effects)
   tuple = pure . Tuple
   array = pure . Array
 
-  klass n [] env = pure $ Class n env
-  klass n supers env = do
-    product <- foldl mergeEnvs lowerBound . catMaybes <$> traverse scopedEnvironment supers
-    pure $ Class n (mergeEnvs product env)
+  klass n supers binds = do
+    pure $ Class n supers binds
 
   namespace name env = do
     maybeAddr <- lookupEnv name
@@ -131,10 +129,13 @@ instance ( Coercible body (Eff effects)
             | Namespace _ env' <- v = pure env'
             | otherwise             = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace")
 
-  scopedEnvironment o
-    | Class _ env <- o = pure (Just env)
-    | Namespace _ env <- o = pure (Just env)
-    | otherwise = pure Nothing
+  scopedEnvironment ptr = do
+    ancestors <- ancestorBinds [ptr]
+    pure (Env.Environment <$> nonEmpty ancestors)
+      where ancestorBinds = (pure . concat) <=< traverse (deref >=> \case
+                Class _ supers binds -> (binds :) <$> ancestorBinds (reverse supers)
+                Namespace _ env -> pure . toList . Env.unEnvironment $ env
+                _ -> pure [])
 
   asString v
     | String n <- v = pure n

src/Data/Syntax/Declaration.hs

@@ -163,11 +163,11 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Class where
   eval Class{..} = do
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
-    supers <- traverse subtermValue classSuperclasses
+    supers <- traverse subtermAddress classSuperclasses
     (_, addr) <- letrec name $ do
       void $ subtermValue classBody
-      classEnv <- newEnv . Env.head <$> getEnv
-      klass name supers classEnv
+      classBinds <- Env.head <$> getEnv
+      klass name supers classBinds
     bind name addr
     pure (Rval addr)
 

src/Data/Syntax/Expression.hs

@@ -439,7 +439,7 @@ instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable ScopeResolution where
   eval (ScopeResolution xs) = Rval <$> foldl1 f (fmap subtermAddress xs)
-    where f ns = evaluateInScopedEnv (ns >>= deref)
+    where f ns id = ns >>= flip evaluateInScopedEnv id
 
 
 -- | A non-null expression such as Typescript or Swift's ! expression.

src/Language/PHP/Syntax.hs

@@ -200,7 +200,9 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
 instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedName where
-  eval (QualifiedName name iden) = Rval <$> evaluateInScopedEnv (subtermValue name) (subtermAddress iden)
+  eval (QualifiedName name iden) = do
+    namePtr <- subtermAddress name
+    Rval <$> evaluateInScopedEnv namePtr (subtermAddress iden)
 
 newtype NamespaceName a = NamespaceName (NonEmpty a)
   deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1)
@@ -212,7 +214,7 @@ instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable NamespaceName where
   eval (NamespaceName xs) = Rval <$> foldl1 f (fmap subtermAddress xs)
-    where f ns = evaluateInScopedEnv (ns >>= deref)
+    where f ns id = ns >>= flip evaluateInScopedEnv id
 
 newtype ConstDeclaration a = ConstDeclaration [a]
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)

src/Language/Ruby/Syntax.hs

@@ -54,7 +54,7 @@ instance Evaluatable Send where
     let sel = case sendSelector of
           Just sel -> subtermAddress sel
           Nothing  -> variable (name "call")
-    func <- deref =<< maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
+    func <- deref =<< maybe sel (flip evaluateInScopedEnv sel <=< subtermAddress) sendReceiver
     Rval <$> call func (map subtermAddress sendArgs) -- TODO pass through sendBlock
 
 data Require a = Require { requireRelative :: Bool, requirePath :: !a }
@@ -131,7 +131,7 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Class where
   eval Class{..} = do
-    super <- traverse subtermValue classSuperClass
+    super <- traverse subtermAddress classSuperClass
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
     rvalBox =<< letrec' name (\addr ->
       subtermValue classBody <* makeNamespace name addr super)

src/Language/TypeScript/Syntax.hs

@@ -742,11 +742,11 @@ instance Declarations a => Declarations (AbstractClass a) where
 instance Evaluatable AbstractClass where
   eval AbstractClass{..} = do
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm abstractClassIdentifier)
-    supers <- traverse subtermValue classHeritage
+    supers <- traverse subtermAddress classHeritage
     (v, addr) <- letrec name $ do
       void $ subtermValue classBody
-      classEnv <- newEnv . Env.head <$> getEnv
-      klass name supers classEnv
+      classBinds <- Env.head <$> getEnv
+      klass name supers classBinds
     rvalBox =<< (v <$ bind name addr)
 
 

src/Parsing/TreeSitter.hs

@@ -58,7 +58,7 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
 
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
-parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Trace effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
+parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Trace effects, Effects effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
 parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
   let parserTimeout = s * 1000
 

src/Semantic/Task.hs

@@ -37,6 +37,7 @@ module Semantic.Task
 -- * Interpreting
 , runTask
 , runTaskWithOptions
+, withOptions
 , runTaskWithConfig
 -- * Re-exports
 , Distribute
@@ -127,11 +128,12 @@ runTask = runTaskWithOptions defaultOptions
 
 -- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'.
 runTaskWithOptions :: Options -> TaskEff a -> IO a
-runTaskWithOptions opts task = do
-  config <- defaultConfig opts
-  result <- withTelemetry config $ \(TelemetryQueues logger statter _) ->
-    runTaskWithConfig config logger statter task
-  either (die . displayException) pure result
+runTaskWithOptions opts task = withOptions opts (\ config logger statter -> runTaskWithConfig config logger statter task) >>= either (die . displayException) pure
+
+withOptions :: Options -> (Config -> LogQueue -> StatQueue -> IO a) -> IO a
+withOptions options with = do
+  config <- defaultConfig options
+  withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
 
 -- | Execute a 'TaskEff' yielding its result value in 'IO'.
 runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a)
@@ -195,7 +197,7 @@ data ParserCancelled = ParserTimedOut deriving (Show, Typeable)
 instance Exception ParserCancelled
 
 -- | Parse a 'Blob' in 'IO'.
-runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
+runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Blob -> Parser term -> Eff effs term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
@@ -225,6 +227,7 @@ runParser blob@Blob{..} parser = case parser of
                          , Member (Reader Config) effs
                          , Member Telemetry effs
                          , Member Trace effs
+                         , Effects effs
                          )
                       => (Source -> assignment (Term (Sum syntaxes) (Record Assignment.Location)) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) (Record Assignment.Location)))
                       -> Parser ast

src/Semantic/Util.hs

@@ -7,6 +7,7 @@ import Prelude hiding (readFile)
 import           Analysis.Abstract.Caching
 import           Analysis.Abstract.Collecting
 import           Control.Abstract
+import           Control.Exception (displayException)
 import           Control.Monad.Effect.Trace (runPrintingTrace)
 import           Data.Abstract.Address
 import           Data.Abstract.Evaluatable
@@ -27,9 +28,12 @@ import           Language.Haskell.HsColour
 import           Language.Haskell.HsColour.Colourise
 import           Parsing.Parser
 import           Prologue hiding (weaken)
+import           Semantic.Config
 import           Semantic.Graph
 import           Semantic.IO as IO
 import           Semantic.Task
+import           Semantic.Telemetry (LogQueue, StatQueue)
+import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
 import           Text.Show (showListWith)
 import           Text.Show.Pretty (ppShow)
@@ -99,7 +103,12 @@ evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Lang
 typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go
 
 -- Evaluate a project consisting of the listed paths.
-evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
+evaluateProject proxy parser lang paths = withOptions debugOptions $ \ config logger statter ->
+  evaluateProject' (TaskConfig config logger statter) proxy parser lang paths
+
+data TaskConfig = TaskConfig Config LogQueue StatQueue
+
+evaluateProject' (TaskConfig config logger statter) proxy parser lang paths = either (die . displayException) pure <=< runTaskWithConfig config logger statter $ do
   blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
   package <- fmap quieterm <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
   modules <- topologicalSort <$> runImportGraph proxy package
@@ -111,6 +120,7 @@ evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
        (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
        (evaluate proxy id withTermSpans modules))))))
 
+
 evaluateProjectWithCaching proxy parser lang path = runTaskWithOptions debugOptions $ do
   project <- readProject Nothing path lang []
   package <- fmap quieterm <$> parsePackage parser project

test/Analysis/Go/Spec.hs

@@ -8,8 +8,8 @@ import qualified Language.Go.Assignment as Go
 import SpecHelpers
 
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   describe "Go" $ do
     it "imports and wildcard imports" $ do
       (_, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
@@ -30,4 +30,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/go/analysis/"
     evaluate = evalGoProject . map (fixtures <>)
-    evalGoProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go
+    evalGoProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.Go) goParser Language.Go

test/Analysis/PHP/Spec.hs

@@ -9,8 +9,8 @@ import qualified Language.PHP.Assignment as PHP
 import SpecHelpers
 
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   describe "PHP" $ do
     it "evaluates include and require" $ do
       (_, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]
@@ -42,4 +42,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/php/analysis/"
     evaluate = evalPHPProject . map (fixtures <>)
-    evalPHPProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP
+    evalPHPProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP

test/Analysis/Python/Spec.hs

@@ -10,8 +10,8 @@ import qualified Data.Language as Language
 import SpecHelpers
 
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   describe "Python" $ do
     it "imports" $ do
       (_, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
@@ -60,4 +60,4 @@ spec = parallel $ do
     ns n = Just . Latest . Last . Just . Namespace n
     fixtures = "test/fixtures/python/analysis/"
     evaluate = evalPythonProject . map (fixtures <>)
-    evalPythonProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python
+    evalPythonProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.Python) pythonParser Language.Python

test/Analysis/Ruby/Spec.hs

@@ -15,8 +15,8 @@ import qualified Data.Language as Language
 import SpecHelpers
 
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   describe "Ruby" $ do
     it "evaluates require_relative" $ do
       (_, (heap, res)) <- evaluate ["main.rb", "foo.rb"]
@@ -104,4 +104,4 @@ spec = parallel $ do
     ns n = Just . Latest . Last . Just . Namespace n
     fixtures = "test/fixtures/ruby/analysis/"
     evaluate = evalRubyProject . map (fixtures <>)
-    evalRubyProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby
+    evalRubyProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby

test/Analysis/TypeScript/Spec.hs

@@ -11,8 +11,8 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sum
 import SpecHelpers
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   describe "TypeScript" $ do
     it "imports with aliased symbols" $ do
       (_, (_, res)) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
@@ -49,4 +49,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/typescript/analysis/"
     evaluate = evalTypeScriptProject . map (fixtures <>)
-    evalTypeScriptProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript
+    evalTypeScriptProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript

test/Integration/Spec.hs

@@ -11,8 +11,8 @@ import SpecHelpers
 languages :: [FilePath]
 languages = ["go", "javascript", "json", "python", "ruby", "typescript"]
 
-spec :: Spec
-spec = parallel $ do
+spec :: TaskConfig -> Spec
+spec config = parallel $ do
   for_ languages $ \language -> do
     let dir = "test/fixtures" </> language </> "corpus"
     it (language <> " corpus exists") $ examples dir `shouldNotReturn` []
@@ -23,8 +23,8 @@ spec = parallel $ do
     runTestsIn directory pending = do
       examples <- runIO $ examples directory
       traverse_ (runTest pending) examples
-    runTest pending ParseExample{..} = it ("parses " <> file) $ maybe (testParse file parseOutput) pendingWith (lookup parseOutput pending)
-    runTest pending DiffExample{..} = it ("diffs " <> diffOutput) $ maybe (testDiff (both fileA fileB) diffOutput) pendingWith (lookup diffOutput pending)
+    runTest pending ParseExample{..} = it ("parses " <> file) $ maybe (testParse config file parseOutput) pendingWith (lookup parseOutput pending)
+    runTest pending DiffExample{..} = it ("diffs " <> diffOutput) $ maybe (testDiff config (both fileA fileB) diffOutput) pendingWith (lookup diffOutput pending)
 
 data Example = DiffExample { fileA :: FilePath, fileB :: FilePath, diffOutput :: FilePath }
              | ParseExample { file :: FilePath, parseOutput :: FilePath }
@@ -81,14 +81,14 @@ examples directory = do
 normalizeName :: FilePath -> FilePath
 normalizeName path = dropExtension $ dropExtension path
 
-testParse :: FilePath -> FilePath -> Expectation
-testParse path expectedOutput = do
-  actual <- verbatim <$> parseFilePath path
+testParse :: TaskConfig -> FilePath -> FilePath -> Expectation
+testParse config path expectedOutput = do
+  actual <- verbatim <$> parseFilePath config path
   expected <- verbatim <$> B.readFile expectedOutput
   actual `shouldBe` expected
 
-testDiff :: Both FilePath -> FilePath -> Expectation
-testDiff paths expectedOutput = do
-  actual <- verbatim <$> diffFilePaths paths
+testDiff :: TaskConfig -> Both FilePath -> FilePath -> Expectation
+testDiff config paths expectedOutput = do
+  actual <- verbatim <$> diffFilePaths config paths
   expected <- verbatim <$> B.readFile expectedOutput
   actual `shouldBe` expected

test/Spec.hs

@@ -24,34 +24,39 @@ import qualified Semantic.Spec
 import qualified Semantic.CLI.Spec
 import qualified Semantic.IO.Spec
 import qualified Semantic.Stat.Spec
+import Semantic.Config (defaultOptions)
+import Semantic.Task (withOptions)
+import Semantic.Util (TaskConfig(..))
 import qualified Proto3.Roundtrip
 import Test.Hspec
 
 main :: IO ()
-main = hspec $ do
-  describe "Semantic.Stat" Semantic.Stat.Spec.spec
-  parallel $ do
-    describe "Analysis.Go" Analysis.Go.Spec.spec
-    describe "Analysis.PHP" Analysis.PHP.Spec.spec
-    describe "Analysis.Python" Analysis.Python.Spec.spec
-    describe "Analysis.Ruby" Analysis.Ruby.Spec.spec
-    describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
-    describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
-    describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec
-    describe "Data.Diff" Data.Diff.Spec.spec
-    describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
-    describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
-    describe "Data.Scientific" Data.Scientific.Spec.spec
-    describe "Data.Source" Data.Source.Spec.spec
-    describe "Data.Term" Data.Term.Spec.spec
-    describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec
-    describe "Diffing.Algorithm.SES" Diffing.Algorithm.SES.Spec.spec
-    describe "Diffing.Interpreter" Diffing.Interpreter.Spec.spec
-    describe "Matching" Matching.Go.Spec.spec
-    describe "Numeric" Numeric.Spec.spec
-    describe "Rendering.TOC" Rendering.TOC.Spec.spec
-    describe "Semantic" Semantic.Spec.spec
-    describe "Semantic.CLI" Semantic.CLI.Spec.spec
-    describe "Semantic.IO" Semantic.IO.Spec.spec
-    describe "Integration" Integration.Spec.spec
-    describe "Protobuf roundtripping" Proto3.Roundtrip.spec
+main = do
+  withOptions defaultOptions $ \ config logger statter -> hspec $ do
+    let args = TaskConfig config logger statter
+    describe "Semantic.Stat" Semantic.Stat.Spec.spec
+    parallel $ do
+      describe "Analysis.Go" (Analysis.Go.Spec.spec args)
+      describe "Analysis.PHP" (Analysis.PHP.Spec.spec args)
+      describe "Analysis.Python" (Analysis.Python.Spec.spec args)
+      describe "Analysis.Ruby" (Analysis.Ruby.Spec.spec args)
+      describe "Analysis.TypeScript" (Analysis.TypeScript.Spec.spec args)
+      describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
+      describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec
+      describe "Data.Diff" Data.Diff.Spec.spec
+      describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
+      describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
+      describe "Data.Scientific" Data.Scientific.Spec.spec
+      describe "Data.Source" Data.Source.Spec.spec
+      describe "Data.Term" Data.Term.Spec.spec
+      describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec
+      describe "Diffing.Algorithm.SES" Diffing.Algorithm.SES.Spec.spec
+      describe "Diffing.Interpreter" Diffing.Interpreter.Spec.spec
+      describe "Matching" Matching.Go.Spec.spec
+      describe "Numeric" Numeric.Spec.spec
+      describe "Rendering.TOC" Rendering.TOC.Spec.spec
+      describe "Semantic" Semantic.Spec.spec
+      describe "Semantic.CLI" Semantic.CLI.Spec.spec
+      describe "Semantic.IO" Semantic.IO.Spec.spec
+      describe "Integration" (Integration.Spec.spec args)
+      describe "Protobuf roundtripping" Proto3.Roundtrip.spec

test/SpecHelpers.hs

@@ -11,6 +11,9 @@ module SpecHelpers
 , TermEvaluator(..)
 , Verbatim(..)
 , toList
+, Config
+, LogQueue
+, StatQueue
 ) where
 
 import Control.Abstract
@@ -65,16 +68,20 @@ import Test.LeanCheck as X
 
 import qualified Data.ByteString as B
 import qualified Semantic.IO as IO
+import Semantic.Config (Config)
+import Semantic.Telemetry (LogQueue, StatQueue)
+import System.Exit (die)
+import Control.Exception (displayException)
 
 runBuilder = toStrict . toLazyByteString
 
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
-diffFilePaths :: Both FilePath -> IO ByteString
-diffFilePaths paths = readFilePair paths >>= fmap runBuilder . runTask . runDiff SExpressionDiffRenderer . pure
+diffFilePaths :: TaskConfig -> Both FilePath -> IO ByteString
+diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>= runTaskWithConfig config logger statter . runDiff SExpressionDiffRenderer . pure >>= either (die . displayException) (pure . runBuilder)
 
 -- | Returns an s-expression parse tree for the specified FilePath.
-parseFilePath :: FilePath -> IO ByteString
-parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= fmap runBuilder . runTask . runParse SExpressionTermRenderer . pure
+parseFilePath :: TaskConfig -> FilePath -> IO ByteString
+parseFilePath (TaskConfig config logger statter) path = (fromJust <$> IO.readFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder)
 
 -- | Read two files to a BlobPair.
 readFilePair :: Both FilePath -> IO BlobPair