Quiet debug spew in specs.

semantic.cabal

@@ -64,6 +64,7 @@ common dependencies
                      , scientific ^>= 0.3.6.2
                      , safe-exceptions ^>= 0.1.7.0
                      , semilattices ^>= 0.0.0.3
+                     , shelly >= 1.5 && <2
                      , text ^>= 1.2.3.1
                      , these >= 0.7 && <1
                      , unix ^>= 2.7.2.2
@@ -307,7 +308,6 @@ library
                      , reducers ^>= 3.12.3
                      , semigroupoids ^>= 5.3.2
                      , servant ^>= 0.15
-                     , shelly >= 1.5 && <2
                      , split ^>= 0.2.3.3
                      , stm-chans ^>= 3.0.0.4
                      , template-haskell ^>= 2.14
@@ -393,6 +393,7 @@ test-suite test
                      , tasty-golden ^>= 2.3.2
                      , tasty-hedgehog ^>= 1.0.0.1
                      , tasty-hspec ^>= 1.1.5.1
+                     , tasty-hunit ^>= 0.10.0.2
                      , HUnit ^>= 1.6.0.0
                      , leancheck >= 0.8 && <1
                      , temporary ^>= 1.3

src/Data/Blob.hs

@@ -5,6 +5,7 @@ module Data.Blob
 , Blob(..)
 , Blobs(..)
 , blobLanguage
+, NoLanguageForBlob (..)
 , blobPath
 , makeBlob
 , decodeBlobs

src/Data/Handle.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveAnyClass, GADTs #-}
 
 module Data.Handle
   ( Handle (..)
@@ -11,14 +11,15 @@ module Data.Handle
   , readBlobPairsFromHandle
   , readFromHandle
   , openFileForReading
+  , InvalidJSONException (..)
   ) where
 
 import Prologue
 
+import           Control.Exception (throw)
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
-import           System.Exit
 import qualified System.IO as IO
 
 import Data.Blob
@@ -58,9 +59,14 @@ readPathsFromHandle (ReadHandle h) = liftIO $ fmap BLC.unpack . BLC.lines <$> BL
 readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
 readBlobPairsFromHandle = fmap blobs <$> readFromHandle
 
+newtype InvalidJSONException = InvalidJSONException String
+  deriving (Eq, Show, Exception)
+
+-- | Read JSON-encoded data from a 'Handle'. Throws
+-- 'InvalidJSONException' on parse failure.
 readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
 readFromHandle (ReadHandle h) = do
   input <- liftIO $ BL.hGetContents h
   case eitherDecode input of
-    Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
+    Left e  -> throw (InvalidJSONException e)
     Right d -> pure d

src/Semantic/Util.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE CPP, ConstraintKinds, Rank2Types, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
-{-# OPTIONS_GHC -Wno-missing-signatures -O0 #-}
+{-# LANGUAGE CPP, ConstraintKinds, PartialTypeSignatures, Rank2Types, ScopedTypeVariables, TypeFamilies,
+             TypeOperators #-}
+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-partial-type-signatures -O0 #-}
 module Semantic.Util
   ( evalGoProject
   , evalPHPProject
@@ -10,6 +11,7 @@ module Semantic.Util
   , mergeErrors
   , reassociate
   , parseFile
+  , parseFileQuiet
   ) where
 
 import Prelude hiding (readFile)
@@ -30,6 +32,7 @@ import           Data.Blob.IO
 import           Data.Graph (topologicalSort)
 import qualified Data.Language as Language
 import           Data.List (uncons)
+import           Data.Location
 import           Data.Project hiding (readFile)
 import           Data.Quieterm (Quieterm, quieterm)
 import           Data.Sum (weaken)
@@ -47,70 +50,11 @@ import           Semantic.Task
 import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
 
-import Data.Location
-
--- The type signatures in these functions are pretty gnarly, but these functions
--- are hit sufficiently often in the CLI and test suite so as to merit avoiding
--- the overhead of repeated type inference. If you have to hack on these functions,
--- it's recommended to remove all the type signatures and add them back when you
--- are done (type holes in GHCi will help here).
-
-justEvaluating :: Evaluator
-                        term
-                        Precise
-                        (Value term Precise)
-                        (ResumableC
-                           (BaseError (ValueError term Precise))
-                              (ResumableC
-                                 (BaseError (AddressError Precise (Value term Precise)))
-                                    (ResumableC
-                                       (BaseError ResolutionError)
-                                          (ResumableC
-                                             (BaseError
-                                                (EvalError term Precise (Value term Precise)))
-                                                (ResumableC
-                                                   (BaseError (HeapError Precise))
-                                                      (ResumableC
-                                                         (BaseError (ScopeError Precise))
-                                                            (ResumableC
-                                                               (BaseError
-                                                                  (UnspecializedError
-                                                                     Precise (Value term Precise)))
-                                                                  (ResumableC
-                                                                     (BaseError
-                                                                        (LoadError
-                                                                           Precise
-                                                                           (Value term Precise)))
-                                                                        (FreshC
-                                                                              (StateC
-                                                                                 (ScopeGraph
-                                                                                    Precise)
-                                                                                    (StateC
-                                                                                       (Heap
-                                                                                          Precise
-                                                                                          Precise
-                                                                                          (Value
-                                                                                             term
-                                                                                             Precise))
-                                                                                          (TraceByPrintingC
-                                                                                                (LiftC
-                                                                                                   IO)))))))))))))
-                        result
-                      -> IO
-                           (Heap Precise Precise (Value term Precise),
-                            (ScopeGraph Precise,
-                             Either
-                               (SomeError
-                                  (Sum
-                                     '[BaseError (ValueError term Precise),
-                                       BaseError (AddressError Precise (Value term Precise)),
-                                       BaseError ResolutionError,
-                                       BaseError (EvalError term Precise (Value term Precise)),
-                                       BaseError (HeapError Precise),
-                                       BaseError (ScopeError Precise),
-                                       BaseError (UnspecializedError Precise (Value term Precise)),
-                                       BaseError (LoadError Precise (Value term Precise))]))
-                               result))
+justEvaluating :: Evaluator term Precise (Value term Precise) _ result
+               -> IO ( Heap Precise Precise (Value term Precise),
+                     ( ScopeGraph Precise
+                     , Either (SomeError (Sum _)) result)
+                     )
 justEvaluating
   = runM
   . runEvaluator
@@ -128,75 +72,27 @@ justEvaluating
   . runAddressError
   . runValueError
 
-type FileEvaluator syntax =
+type FileEvaluator err syntax =
   [FilePath]
   -> IO
-       (Heap
-          Precise
-          Precise
-          (Value
-             (Quieterm (Sum syntax) Location) Precise),
-        (ScopeGraph Precise,
-         Either
-           (SomeError
-              (Sum
-                 '[BaseError
-                     (ValueError
-                        (Quieterm (Sum syntax) Location)
-                        Precise),
-                   BaseError
-                     (AddressError
-                        Precise
-                        (Value
-                           (Quieterm
-                              (Sum syntax) Location)
-                           Precise)),
-                   BaseError ResolutionError,
-                   BaseError
-                     (EvalError
-                        (Quieterm (Sum syntax) Location)
-                        Precise
-                        (Value
-                           (Quieterm
-                              (Sum syntax) Location)
-                           Precise)),
-                   BaseError (HeapError Precise),
-                   BaseError (ScopeError Precise),
-                   BaseError
-                     (UnspecializedError
-                        Precise
-                        (Value
-                           (Quieterm
-                              (Sum syntax) Location)
-                           Precise)),
-                   BaseError
-                     (LoadError
-                        Precise
-                        (Value
-                           (Quieterm
-                              (Sum syntax) Location)
-                           Precise))]))
-           (ModuleTable
-              (Module
-                 (ModuleResult
-                    Precise
-                    (Value
-                       (Quieterm (Sum syntax) Location)
-                       Precise))))))
+       ( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise),
+       ( ScopeGraph Precise
+       , Either (SomeError (Sum err))
+                (ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Location) Precise))))))
 
-evalGoProject :: FileEvaluator Language.Go.Assignment.Syntax
+evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax
 evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser
 
-evalRubyProject :: FileEvaluator Language.Ruby.Assignment.Syntax
+evalRubyProject :: FileEvaluator _ Language.Ruby.Assignment.Syntax
 evalRubyProject = justEvaluating <=< evaluateProject (Proxy @'Language.Ruby)               rubyParser
 
-evalPHPProject :: FileEvaluator Language.PHP.Assignment.Syntax
+evalPHPProject :: FileEvaluator _ Language.PHP.Assignment.Syntax
 evalPHPProject  = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP)        phpParser
 
-evalPythonProject :: FileEvaluator Language.Python.Assignment.Syntax
-evalPythonProject     = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python)     pythonParser
+evalPythonProject :: FileEvaluator _ Language.Python.Assignment.Syntax
+evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python)     pythonParser
 
-evalTypeScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
+evalTypeScriptProject :: FileEvaluator _ Language.TypeScript.Assignment.Syntax
 evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser
 
 evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger statter ->
@@ -218,11 +114,13 @@ evaluateProject' session proxy parser paths = do
          (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
   either (die . displayException) pure res
 
-parseFile :: Parser term -> FilePath -> IO term
+parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
 parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
+parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
 
-runTask' :: TaskEff a -> IO a
+runTask', runTaskQuiet :: TaskEff a -> IO a
 runTask' task = runTaskWithOptions debugOptions task >>= either (die . displayException) pure
+runTaskQuiet task = runTaskWithOptions defaultOptions task >>= either (die . displayException) pure
 
 mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
 mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)

test/Analysis/Go/Spec.hs

@@ -8,7 +8,7 @@ import           SpecHelpers
 
 
 spec :: (?session :: TaskSession) => Spec
-spec = parallel $ do
+spec = do
   describe "Go" $ do
     it "imports and wildcard imports" $ do
       (scopeGraph, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]

test/Analysis/PHP/Spec.hs

@@ -9,7 +9,7 @@ import           SpecHelpers
 
 
 spec :: (?session :: TaskSession) => Spec
-spec = parallel $ do
+spec = do
   describe "PHP" $ do
     xit "evaluates include and require" $ do
       (scopeGraph, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]

test/Analysis/Python/Spec.hs

@@ -10,7 +10,7 @@ import SpecHelpers
 
 
 spec :: (?session :: TaskSession) => Spec
-spec = parallel $ do
+spec = do
   describe "Python" $ do
     it "imports" $ do
       (scopeGraph, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]

test/Analysis/Ruby/Spec.hs

@@ -15,7 +15,7 @@ import SpecHelpers
 
 
 spec :: (?session :: TaskSession) =>  Spec
-spec = parallel $ do
+spec = do
   describe "Ruby" $ do
     it "evaluates require_relative" $ do
       (scopeGraph, (heap, res)) <- evaluate ["main.rb", "foo.rb"]

test/Analysis/TypeScript/Spec.hs

@@ -23,7 +23,7 @@ import qualified Language.TypeScript.Assignment as TypeScript
 import           SpecHelpers
 
 spec :: (?session :: TaskSession) => Spec
-spec = parallel $ do
+spec = do
   describe "TypeScript" $ do
     it "qualified export from" $ do
       (scopeGraph, (heap, res)) <- evaluate ["main6.ts", "baz.ts", "foo.ts"]

test/Assigning/Assignment/Spec.hs

@@ -44,35 +44,37 @@ spec = do
       `shouldBe`
         Right [Out "hello"]
 
-    it "distributes through overlapping committed choices, matching the left alternative" $
-      fst <$> runAssignment "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]])
-      `shouldBe`
-      Right (Out "(green)")
+    describe "distributing through overlapping committed choices" $ do
 
-    it "distributes through overlapping committed choices, matching the right alternative" $
-      fst <$> runAssignment "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]])
-      `shouldBe`
-      Right (Out "(blue)")
+      it "matches the left alternative" $
+        fst <$> runAssignment "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]])
+        `shouldBe`
+        Right (Out "(green)")
 
-    it "distributes through overlapping committed choices, matching the left alternatives" $
-      fst <$> runAssignment "magenta green green" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Green 8 13 [], node Green 14 19 []])
-      `shouldBe`
-      Right [Out "green", Out "green"]
+      it "matches the right alternative" $
+        fst <$> runAssignment "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]])
+        `shouldBe`
+        Right (Out "(blue)")
 
-    it "distributes through overlapping committed choices, matching the empty list" $
-      fst <$> runAssignment "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []])
-      `shouldBe`
-      Right (Left [])
+      it "matches the left alternatives" $
+        fst <$> runAssignment "magenta green green" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Green 8 13 [], node Green 14 19 []])
+        `shouldBe`
+        Right [Out "green", Out "green"]
 
-    it "distributes through overlapping committed choices, dropping anonymous nodes & matching the left alternative" $
-      fst <$> runAssignment "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []])
-      `shouldBe`
-      Right (Out "green")
+      it "matches the empty list" $
+        fst <$> runAssignment "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []])
+        `shouldBe`
+        Right (Left [])
 
-    it "distributes through overlapping committed choices, dropping anonymous nodes & matching the right alternative" $
-      fst <$> runAssignment "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []])
-      `shouldBe`
-      Right (Out "blue")
+      it "drops anonymous nodes & matches the left alternative" $
+        fst <$> runAssignment "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []])
+        `shouldBe`
+        Right (Out "green")
+
+      it "drops anonymous nodes & matches the right alternative" $
+        fst <$> runAssignment "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []])
+        `shouldBe`
+        Right (Out "blue")
 
     it "alternates repetitions, matching the left alternative" $
       fst <$> runAssignment "green green" (many green <|> many blue) (makeState [node Green 0 5 [], node Green 6 11 []])

test/Control/Abstract/Evaluator/Spec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 module Control.Abstract.Evaluator.Spec
 ( spec
 ) where
@@ -20,7 +21,7 @@ import           SpecHelpers hiding (reassociate)
 import           System.IO.Unsafe (unsafePerformIO)
 
 spec :: Spec
-spec = parallel $ do
+spec = do
   it "constructs integers" $ do
     (_, (_, (_, expected))) <- evaluate (integer 123)
     expected `shouldBe` Right (Value.Integer (Number.Integer 123))