diff --git a/semantic.cabal b/semantic.cabal index 03c3bb8697..7e0ffd6231 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 6c49d89411..2097a582f8 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -5,6 +5,7 @@ module Data.Blob , Blob(..) , Blobs(..) , blobLanguage +, NoLanguageForBlob (..) , blobPath , makeBlob , decodeBlobs diff --git a/src/Data/Handle.hs b/src/Data/Handle.hs index 6917c39e93..04e1c4c0aa 100644 --- a/src/Data/Handle.hs +++ b/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 diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 70c0f731f3..e18511a739 100644 --- a/src/Semantic/Util.hs +++ b/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) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index e1cc2f357a..16ed206132 100644 --- a/test/Analysis/Go/Spec.hs +++ b/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"] diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 6f4f5099d5..2cf1db0836 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/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"] diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 6073fec500..8549a31c93 100644 --- a/test/Analysis/Python/Spec.hs +++ b/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"] diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index dd04ca4f51..e8d3fc197d 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/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"] diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 113c5513e4..3d56fc8ae4 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/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"] diff --git a/test/Assigning/Assignment/Spec.hs b/test/Assigning/Assignment/Spec.hs index e188393abf..91a4858d6e 100644 --- a/test/Assigning/Assignment/Spec.hs +++ b/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 []]) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 88b98a786d..c7f2d93592 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/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)) diff --git a/test/Data/Diff/Spec.hs b/test/Data/Diff/Spec.hs index 4a4d1feb16..451dfc764e 100644 --- a/test/Data/Diff/Spec.hs +++ b/test/Data/Diff/Spec.hs @@ -7,6 +7,6 @@ import Test.Hspec import Test.Hspec.LeanCheck spec :: Spec -spec = parallel $ do +spec = do prop "equality is reflexive" $ \ diff -> diff `shouldBe` (diff :: Diff ListableSyntax () ()) diff --git a/test/Data/Functor/Classes/Generic/Spec.hs b/test/Data/Functor/Classes/Generic/Spec.hs index 01d4e41a53..8afba0c42e 100644 --- a/test/Data/Functor/Classes/Generic/Spec.hs +++ b/test/Data/Functor/Classes/Generic/Spec.hs @@ -7,7 +7,7 @@ import Test.Hspec import Test.Hspec.LeanCheck spec :: Spec -spec = parallel $ do +spec = do describe "Eq1" $ do describe "genericLiftEq" $ do prop "equivalent to derived (==) for product types" $ diff --git a/test/Data/Source/Spec.hs b/test/Data/Source/Spec.hs index 9d6b00c33f..01aa30c017 100644 --- a/test/Data/Source/Spec.hs +++ b/test/Data/Source/Spec.hs @@ -70,7 +70,7 @@ testTree = Tasty.testGroup "Data.Source" ] spec :: Spec -spec = parallel $ do +spec = do describe "newlineIndices" $ do it "finds \\n" $ let source = "a\nb" in diff --git a/test/Data/Term/Spec.hs b/test/Data/Term/Spec.hs index 2c785547e8..547beaf461 100644 --- a/test/Data/Term/Spec.hs +++ b/test/Data/Term/Spec.hs @@ -3,12 +3,12 @@ module Data.Term.Spec (spec) where import Data.Functor.Listable import Data.Term -import Test.Hspec (Spec, describe, parallel) +import Test.Hspec (Spec, describe) import Test.Hspec.Expectations import Test.Hspec.LeanCheck spec :: Spec -spec = parallel $ do +spec = do describe "Term" $ do prop "equality is reflexive" $ \ a -> a `shouldBe` (a :: Term ListableSyntax ()) diff --git a/test/Diffing/Algorithm/RWS/Spec.hs b/test/Diffing/Algorithm/RWS/Spec.hs index d62a3aec09..36f9eeea47 100644 --- a/test/Diffing/Algorithm/RWS/Spec.hs +++ b/test/Diffing/Algorithm/RWS/Spec.hs @@ -16,7 +16,7 @@ import Test.Hspec.LeanCheck import SpecHelpers spec :: Spec -spec = parallel $ do +spec = do let positively = succ . abs describe "pqGramDecorator" $ do prop "produces grams with stems of the specified length" $ diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index 738a4fcaa0..a040fd0022 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/test/Diffing/Interpreter/Spec.hs @@ -14,14 +14,14 @@ import Data.Term import Data.These import Diffing.Interpreter import qualified Data.Syntax as Syntax -import Test.Hspec (Spec, describe, it, parallel) +import Test.Hspec (Spec, describe, it) import Test.Hspec.Expectations import Test.Hspec.LeanCheck import Test.LeanCheck.Core import SpecHelpers () spec :: Spec -spec = parallel $ do +spec = do describe "diffTerms" $ do it "returns a replacement when comparing two unicode equivalent terms" $ let termA = termIn emptyAnnotation (inject (Syntax.Identifier "t\776")) diff --git a/test/Integration/Spec.hs b/test/Integration/Spec.hs index 2d0fcdee7f..321daf5f76 100644 --- a/test/Integration/Spec.hs +++ b/test/Integration/Spec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ImplicitParams, LambdaCase, NamedFieldPuns #-} -module Integration.Spec (spec) where +module Integration.Spec (testTree) where import Control.Exception (throw) import Data.Foldable (find) @@ -17,8 +17,8 @@ import Test.Tasty.Golden languages :: [FilePath] languages = ["go", "javascript", "json", "python", "ruby", "typescript", "tsx"] -spec :: (?session :: TaskSession) => TestTree -spec = testGroup "Integration (golden tests)" $ fmap testsForLanguage languages +testTree :: (?session :: TaskSession) => TestTree +testTree = testGroup "Integration (golden tests)" $ fmap testsForLanguage languages testsForLanguage :: (?session :: TaskSession) => FilePath -> TestTree testsForLanguage language = do diff --git a/test/Parsing/Spec.hs b/test/Parsing/Spec.hs index f8e9616556..7ccd638b8e 100644 --- a/test/Parsing/Spec.hs +++ b/test/Parsing/Spec.hs @@ -12,7 +12,7 @@ import SpecHelpers import TreeSitter.JSON (tree_sitter_json, Grammar) spec :: Spec -spec = parallel $ do +spec = do describe "parseToAST" $ do let source = toJSONSource [1 :: Int .. 10000] let largeBlob = sourceBlob "large.json" JSON source diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 4ebe8743c8..69b60eede8 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -28,7 +28,7 @@ import SpecHelpers spec :: Spec -spec = parallel $ do +spec = do describe "tableOfContentsBy" $ do prop "drops all nodes with the constant Nothing function" $ \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff ListableSyntax () ()) `shouldBe` [] diff --git a/test/Reprinting/Spec.hs b/test/Reprinting/Spec.hs index 549257b402..e8ceae66e7 100644 --- a/test/Reprinting/Spec.hs +++ b/test/Reprinting/Spec.hs @@ -28,7 +28,7 @@ spec = describe "reprinting" $ do let path = "test/fixtures/javascript/reprinting/map.json" (src, tree) <- runIO $ do src <- blobSource <$> readBlobFromFile' (File path Language.JSON) - tree <- parseFile jsonParser path + tree <- parseFileQuiet jsonParser path pure (src, tree) describe "tokenization" $ do diff --git a/test/Rewriting/Go/Spec.hs b/test/Rewriting/Go/Spec.hs index c7796a2099..975804ee43 100644 --- a/test/Rewriting/Go/Spec.hs +++ b/test/Rewriting/Go/Spec.hs @@ -30,11 +30,11 @@ loopMatcher = target <* go where spec :: Spec spec = describe "recursively" $ do it "extracts integers" $ do - parsed <- parseFile goParser "test/fixtures/go/matching/integers.go" + parsed <- parseFileQuiet goParser "test/fixtures/go/matching/integers.go" let matched = recursively integerMatcher parsed sort matched `shouldBe` ["1", "2", "3"] it "counts for loops" $ do - parsed <- parseFile goParser "test/fixtures/go/matching/for.go" + parsed <- parseFileQuiet goParser "test/fixtures/go/matching/for.go" let matched = recursively @[] @(Term _ _) loopMatcher parsed length matched `shouldBe` 2 diff --git a/test/Rewriting/JSON/Spec.hs b/test/Rewriting/JSON/Spec.hs index d910cd7c15..95e80cf13a 100644 --- a/test/Rewriting/JSON/Spec.hs +++ b/test/Rewriting/JSON/Spec.hs @@ -44,7 +44,7 @@ spec = describe "rewriting" $ do bytes <- runIO $ Source.fromUTF8 <$> B.readFile path refactored <- runIO $ do - json <- parseFile jsonParser path + json <- parseFileQuiet jsonParser path let result = rewrite @Maybe (History.mark Unmodified json) (topDownAny onTrees) maybe (fail "rewrite failed") pure result diff --git a/test/Rewriting/Python/Spec.hs b/test/Rewriting/Python/Spec.hs index 623cecfa4d..42975044dc 100644 --- a/test/Rewriting/Python/Spec.hs +++ b/test/Rewriting/Python/Spec.hs @@ -25,11 +25,11 @@ docstringMatcher = spec :: Spec spec = describe "matching/python" $ do it "matches top-level docstrings" $ do - parsed <- parseFile pythonParser "test/fixtures/python/matching/docstrings.py" + parsed <- parseFileQuiet pythonParser "test/fixtures/python/matching/docstrings.py" let matched = recursively @[] docstringMatcher parsed length matched `shouldBe` 2 it "matches docstrings recursively" $ do - parsed <- parseFile pythonParser "test/fixtures/python/matching/docstrings_nested.py" + parsed <- parseFileQuiet pythonParser "test/fixtures/python/matching/docstrings_nested.py" let matched = recursively @[] docstringMatcher parsed length matched `shouldBe` 3 diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 7cef8c864d..c65c93a692 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -1,4 +1,4 @@ -module Semantic.CLI.Spec (spec) where +module Semantic.CLI.Spec (testTree) where import Data.ByteString.Builder import Semantic.Api hiding (Blob, BlobPair, File) @@ -11,8 +11,8 @@ import SpecHelpers import Test.Tasty import Test.Tasty.Golden -spec :: TestTree -spec = testGroup "Semantic.CLI" +testTree :: TestTree +testTree = testGroup "Semantic.CLI" [ testGroup "parseDiffBuilder" $ fmap testForDiffFixture diffFixtures , testGroup "parseTermBuilder" $ fmap testForParseFixture parseFixtures ] @@ -41,7 +41,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) = testForParseFixture :: (String, [Blob] -> TaskEff Builder, [File], FilePath) -> TestTree testForParseFixture (format, runParse, files, expected) = goldenVsStringDiff - ("diff fixture renders to " <> format <> " " <> show files) + ("diff fixture renders to " <> format) renderDiff expected (fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index c57b30e5e4..2f8fc3203a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -7,31 +7,31 @@ import Data.List import System.Directory import System.Exit (ExitCode (..)) import System.IO.Temp -import System.Process +import Data.String import Data.Blob import Data.Handle import SpecHelpers hiding (readFile) import qualified Semantic.Git as Git - +import Shelly (shelly, silently, cd, run_) spec :: Spec -spec = parallel $ do +spec = do describe "readBlobsFromGitRepo" $ do hasGit <- runIO $ isJust <$> findExecutable "git" when hasGit . it "should read from a git directory" $ do -- This temporary directory will be cleaned after use. blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - let commands = [ "cd " <> dir - , "git init" - , "touch foo.py bar.rb" - , "git add foo.py bar.rb" - , "git config user.name 'Test'" - , "git config user.email 'test@test.test'" - , "git commit -am 'test commit'" - ] - exit <- system (intercalate " && " commands) - when (exit /= ExitSuccess) (fail ("Couldn't run git properly in dir " <> dir)) + shelly $ silently $ do + cd (fromString dir) + let git = run_ "git" + git ["init"] + run_ "touch" ["foo.py", "bar.rb"] + git ["add", "foo.py", "bar.rb"] + git ["config", "user.name", "'Test'"] + git ["config", "user.email", "'test@test.test'"] + git ["commit", "-am", "'test commit'"] + readBlobsFromGitRepo (dir ".git") (Git.OID "HEAD") [] let files = sortOn fileLanguage (blobFile <$> blobs) files `shouldBe` [ File "foo.py" Python @@ -50,9 +50,7 @@ spec = parallel $ do let a = sourceBlob "method.rb" Ruby "def foo; end" let b = sourceBlob "method.rb" Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do - putStrLn "step 1" blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" - putStrLn "done" blobs `shouldBe` [Diffing a b] it "returns blobs when there's no before" $ do @@ -84,15 +82,15 @@ spec = parallel $ do it "throws on blank input" $ do h <- openFileForReading "test/fixtures/cli/blank.json" - readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1) + readBlobPairsFromHandle h `shouldThrow` jsonException it "throws if language field not given" $ do h <- openFileForReading "test/fixtures/cli/diff-no-language.json" - readBlobsFromHandle h `shouldThrow` (== ExitFailure 1) + readBlobsFromHandle h `shouldThrow` jsonException it "throws if null on before and after" $ do h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json" - readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1) + readBlobPairsFromHandle h `shouldThrow` jsonException describe "readBlobsFromHandle" $ do it "returns blobs for valid JSON encoded parse input" $ do @@ -103,9 +101,13 @@ spec = parallel $ do it "throws on blank input" $ do h <- openFileForReading "test/fixtures/cli/blank.json" - readBlobsFromHandle h `shouldThrow` (== ExitFailure 1) + readBlobsFromHandle h `shouldThrow` jsonException where blobsFromFilePath path = do h <- openFileForReading path blobs <- readBlobPairsFromHandle h pure blobs + +jsonException :: Selector InvalidJSONException +jsonException = const True + diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index ba06a3dbd4..91a3b1d254 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -1,24 +1,28 @@ module Semantic.Spec (spec) where +import Control.Exception (fromException) +import SpecHelpers + +import Data.Blob (NoLanguageForBlob (..)) import Semantic.Api hiding (Blob) import Semantic.Git -import System.Exit - -import SpecHelpers -- we need some lenses here, oof setBlobLanguage :: Language -> Blob -> Blob setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }} spec :: Spec -spec = parallel $ do +spec = do describe "parseBlob" $ do it "returns error if given an unknown language (json)" $ do output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n" it "throws if given an unknown language for sexpression output" $ do - runTaskOrDie (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]) `shouldThrow` (== ExitFailure 1) + res <- runTaskWithOptions defaultOptions (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" it "renders with the specified renderer" $ do output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermSExpression [methodsBlob] diff --git a/test/Semantic/Stat/Spec.hs b/test/Semantic/Stat/Spec.hs index 47d9bfd0d1..74b607a963 100644 --- a/test/Semantic/Stat/Spec.hs +++ b/test/Semantic/Stat/Spec.hs @@ -1,4 +1,6 @@ -module Semantic.Stat.Spec (spec) where +{-# LANGUAGE TemplateHaskell #-} + +module Semantic.Stat.Spec (testTree) where import Control.Exception import Network.Socket hiding (recv) @@ -7,80 +9,95 @@ import Semantic.Telemetry.Stat import Semantic.Config import System.Environment -import SpecHelpers +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Runners withSocketPair :: ((Socket, Socket) -> IO c) -> IO c withSocketPair = bracket create release where create = socketPair AF_UNIX Datagram defaultProtocol release (client, server) = close client >> close server -withEnvironment :: String -> String -> (() -> IO ()) -> IO () -withEnvironment key value = bracket (setEnv key value) (const (unsetEnv key)) +withEnvironment :: String -> String -> IO () -> IO () +withEnvironment key value = bracket (setEnv key value) (const (unsetEnv key)) . const -- NOTE: These cannot easily run in parallel because we test things like -- setting/unsetting the environment. -spec :: Spec -spec = do - describe "defaultStatsClient" $ do - it "sets appropriate defaults" $ do - StatsClient{..} <- defaultStatsClient - statsClientNamespace `shouldBe` "semantic" - statsClientUDPHost `shouldBe` "127.0.0.1" - statsClientUDPPort `shouldBe` "28125" - - around (withEnvironment "STATS_ADDR" "localhost:8125") $ - it "takes STATS_ADDR from environment" $ do - StatsClient{..} <- defaultStatsClient - statsClientUDPHost `shouldBe` "localhost" - statsClientUDPPort `shouldBe` "8125" - - around (withEnvironment "STATS_ADDR" "localhost") $ - it "handles STATS_ADDR with just hostname" $ do - StatsClient{..} <- defaultStatsClient - statsClientUDPHost `shouldBe` "localhost" - statsClientUDPPort `shouldBe` "28125" - - around (withEnvironment "DOGSTATSD_HOST" "0.0.0.0") $ - it "takes DOGSTATSD_HOST from environment" $ do - StatsClient{..} <- defaultStatsClient - statsClientUDPHost `shouldBe` "0.0.0.0" - statsClientUDPPort `shouldBe` "28125" - - describe "renderDatagram" $ do - let key = "app.metric" - - describe "counters" $ do - it "renders increment" $ - renderDatagram "" (increment key []) `shouldBe` "app.metric:1|c" - it "renders decrement" $ - renderDatagram "" (decrement key []) `shouldBe` "app.metric:-1|c" - it "renders count" $ - renderDatagram "" (count key 8 []) `shouldBe` "app.metric:8|c" - - it "renders statsClientNamespace" $ - renderDatagram "pre" (increment key []) `shouldBe` "pre.app.metric:1|c" - - describe "tags" $ do - it "renders a tag" $ do - let inc = increment key [("key", "value")] - renderDatagram "" inc `shouldBe` "app.metric:1|c|#key:value" - it "renders a tag without value" $ do - let inc = increment key [("a", "")] - renderDatagram "" inc `shouldBe` "app.metric:1|c|#a" - it "renders tags" $ do - let inc = increment key [("key", "value"), ("a", "true")] - renderDatagram "" inc `shouldBe` "app.metric:1|c|#key:value,a:true" - it "renders tags without value" $ do - let inc = increment key [("key", "value"), ("a", "")] - renderDatagram "" inc `shouldBe` "app.metric:1|c|#key:value,a" - - describe "sendStat" $ - it "delivers datagram" $ do - client@StatsClient{..} <- defaultStatsClient - withSocketPair $ \(clientSoc, serverSoc) -> do - sendStat client { statsClientUDPSocket = clientSoc } (increment "app.metric" []) - info <- recv serverSoc 1024 - info `shouldBe` "semantic.app.metric:1|c" +testTree :: TestTree +testTree = testCaseSteps "Semantic.Stat.Spec" $ \step -> do + step "Sets appropriate defaults" + case_sets_appropriate_defaults + step "Takes stats addr from environment" + case_takes_stats_addr_from_environment + step "Handles stats addr with just hostname" + case_handles_stats_addr_with_just_hostname + step "takes dogstats host from environment" + case_takes_stats_addr_from_environment + step "rendering" + case_render_counters *> case_render_tags + step "stats deliver datagram" + case_sendstat_delivers_datagram + + +case_sets_appropriate_defaults :: Assertion +case_sets_appropriate_defaults = do + StatsClient{..} <- defaultStatsClient + statsClientNamespace @?= "semantic" + statsClientUDPHost @?= "127.0.0.1" + statsClientUDPPort @?= "28125" + +case_takes_stats_addr_from_environment :: Assertion +case_takes_stats_addr_from_environment = + withEnvironment "STATS_ADDR" "localhost:8125" $ do + StatsClient{..} <- defaultStatsClient + statsClientUDPHost @?= "localhost" + statsClientUDPPort @?= "8125" + +case_handles_stats_addr_with_just_hostname :: Assertion +case_handles_stats_addr_with_just_hostname = + withEnvironment "STATS_ADDR" "localhost" $ do + StatsClient{..} <- defaultStatsClient + statsClientUDPHost @?= "localhost" + statsClientUDPPort @?= "28125" + +case_takes_dogstats_host_from_environment :: Assertion +case_takes_dogstats_host_from_environment = + withEnvironment "DOGSTATSD_HOST" "0.0.0.0" $ do + StatsClient{..} <- defaultStatsClient + statsClientUDPHost @?= "0.0.0.0" + statsClientUDPPort @?= "28125" + +key :: String +key = "app.metric" + +case_render_counters :: Assertion +case_render_counters = do + renderDatagram "" (increment key []) @?= "app.metric:1|c" + renderDatagram "" (decrement key []) @?= "app.metric:-1|c" + renderDatagram "" (count key 8 []) @?= "app.metric:8|c" + renderDatagram "pre" (increment key []) @?= "pre.app.metric:1|c" + +case_render_tags :: Assertion +case_render_tags = do + let incTag = increment key [("key", "value")] + renderDatagram "" incTag @?= "app.metric:1|c|#key:value" + + let tagWithoutValue = increment key [("a", "")] + renderDatagram "" tagWithoutValue @?= "app.metric:1|c|#a" + + let tags = increment key [("key", "value"), ("a", "true")] + renderDatagram "" tags @?= "app.metric:1|c|#key:value,a:true" + + let tagsWithoutValue = increment key [("key", "value"), ("a", "")] + renderDatagram "" tagsWithoutValue @?= "app.metric:1|c|#key:value,a" + +case_sendstat_delivers_datagram :: Assertion +case_sendstat_delivers_datagram = do + client@StatsClient{..} <- defaultStatsClient + withSocketPair $ \(clientSoc, serverSoc) -> do + sendStat client { statsClientUDPSocket = clientSoc } (increment "app.metric" []) + info <- recv serverSoc 1024 + info @?= "semantic.app.metric:1|c" -- Defaults are all driven by defaultConfig. defaultStatsClient :: IO StatsClient diff --git a/test/Spec.hs b/test/Spec.hs index d5ff3ab7ce..c58e8515f1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -44,9 +44,10 @@ import Test.Tasty.Hspec as Tasty tests :: (?session :: TaskSession) => [TestTree] tests = - [ Integration.Spec.spec - , Semantic.CLI.Spec.spec + [ Integration.Spec.testTree + , Semantic.CLI.Spec.testTree , Data.Source.Spec.testTree + , Semantic.Stat.Spec.testTree ] -- We can't bring this out of the IO monad until we divest @@ -64,40 +65,38 @@ allTests = do -- using one or the other.") Instead, create a new TestTree value -- in your spec module and add it to the above 'tests' list. legacySpecs :: (?session :: TaskSession) => Spec -legacySpecs = 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.Graph" Data.Graph.Spec.spec - describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec - describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec - describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec - describe "Data.Range" Data.Range.Spec.spec - describe "Data.Scientific" Data.Scientific.Spec.spec - describe "Data.Semigroup.App" Data.Semigroup.App.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 "Graphing.Calls" Graphing.Calls.Spec.spec - describe "Numeric" Numeric.Spec.spec - describe "Rendering.TOC" Rendering.TOC.Spec.spec - describe "Reprinting.Spec" Reprinting.Spec.spec - describe "Rewriting.Go" Rewriting.Go.Spec.spec - describe "Rewriting.JSON" Rewriting.JSON.Spec.spec - describe "Rewriting.Python" Rewriting.Python.Spec.spec - describe "Tags.Spec" Tags.Spec.spec - describe "Semantic" Semantic.Spec.spec - describe "Semantic.IO" Semantic.IO.Spec.spec - describe "Parsing" Parsing.Spec.spec +legacySpecs = 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.Graph" Data.Graph.Spec.spec + describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec + describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec + describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec + describe "Data.Range" Data.Range.Spec.spec + describe "Data.Scientific" Data.Scientific.Spec.spec + describe "Data.Semigroup.App" Data.Semigroup.App.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 "Graphing.Calls" Graphing.Calls.Spec.spec + describe "Numeric" Numeric.Spec.spec + describe "Rendering.TOC" Rendering.TOC.Spec.spec + describe "Reprinting.Spec" Reprinting.Spec.spec + describe "Rewriting.Go" Rewriting.Go.Spec.spec + describe "Rewriting.JSON" Rewriting.JSON.Spec.spec + describe "Rewriting.Python" Rewriting.Python.Spec.spec + describe "Tags.Spec" Tags.Spec.spec + describe "Semantic" Semantic.Spec.spec + describe "Semantic.IO" Semantic.IO.Spec.spec + describe "Parsing" Parsing.Spec.spec main :: IO () diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index f094648a0d..eeb99b7eb8 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -6,7 +6,7 @@ import Tags.Tagging spec :: Spec -spec = parallel $ do +spec = do describe "go" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go"