Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit b62277f

Browse files
author
Patrick Thomson
authored
Merge pull request #167 from github/quiet-test-spew
Quiet debug spew in specs.
2 parents 5796962 + b17a2c0 commit b62277f

File tree

30 files changed

+242
-311
lines changed

30 files changed

+242
-311
lines changed

‎semantic.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ common dependencies
6464
, scientific ^>= 0.3.6.2
6565
, safe-exceptions ^>= 0.1.7.0
6666
, semilattices ^>= 0.0.0.3
67+
, shelly >= 1.5 && <2
6768
, text ^>= 1.2.3.1
6869
, these >= 0.7 && <1
6970
, unix ^>= 2.7.2.2
@@ -307,7 +308,6 @@ library
307308
, reducers ^>= 3.12.3
308309
, semigroupoids ^>= 5.3.2
309310
, servant ^>= 0.15
310-
, shelly >= 1.5 && <2
311311
, split ^>= 0.2.3.3
312312
, stm-chans ^>= 3.0.0.4
313313
, template-haskell ^>= 2.14
@@ -393,6 +393,7 @@ test-suite test
393393
, tasty-golden ^>= 2.3.2
394394
, tasty-hedgehog ^>= 1.0.0.1
395395
, tasty-hspec ^>= 1.1.5.1
396+
, tasty-hunit ^>= 0.10.0.2
396397
, HUnit ^>= 1.6.0.0
397398
, leancheck >= 0.8 && <1
398399
, temporary ^>= 1.3

‎src/Data/Blob.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module Data.Blob
55
, Blob(..)
66
, Blobs(..)
77
, blobLanguage
8+
, NoLanguageForBlob (..)
89
, blobPath
910
, makeBlob
1011
, decodeBlobs

‎src/Data/Handle.hs‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE GADTs #-}
1+
{-# LANGUAGE DeriveAnyClass, GADTs #-}
22

33
module Data.Handle
44
( Handle (..)
@@ -11,14 +11,15 @@ module Data.Handle
1111
, readBlobPairsFromHandle
1212
, readFromHandle
1313
, openFileForReading
14+
, InvalidJSONException (..)
1415
) where
1516

1617
import Prologue
1718

19+
import Control.Exception (throw)
1820
import Data.Aeson
1921
import qualified Data.ByteString.Lazy as BL
2022
import qualified Data.ByteString.Lazy.Char8 as BLC
21-
import System.Exit
2223
import qualified System.IO as IO
2324

2425
import Data.Blob
@@ -58,9 +59,14 @@ readPathsFromHandle (ReadHandle h) = liftIO $ fmap BLC.unpack . BLC.lines <$> BL
5859
readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
5960
readBlobPairsFromHandle = fmap blobs <$> readFromHandle
6061

62+
newtype InvalidJSONException = InvalidJSONException String
63+
deriving (Eq, Show, Exception)
64+
65+
-- | Read JSON-encoded data from a 'Handle'. Throws
66+
-- 'InvalidJSONException' on parse failure.
6167
readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
6268
readFromHandle (ReadHandle h) = do
6369
input <- liftIO $ BL.hGetContents h
6470
case eitherDecode input of
65-
Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
71+
Left e -> throw (InvalidJSONException e)
6672
Right d -> pure d

‎src/Semantic/Util.hs‎

Lines changed: 25 additions & 127 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
{-# LANGUAGE CPP, ConstraintKinds, Rank2Types, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
2-
{-# OPTIONS_GHC -Wno-missing-signatures -O0 #-}
1+
{-# LANGUAGE CPP, ConstraintKinds, PartialTypeSignatures, Rank2Types, ScopedTypeVariables, TypeFamilies,
2+
TypeOperators #-}
3+
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-partial-type-signatures -O0 #-}
34
module Semantic.Util
45
( evalGoProject
56
, evalPHPProject
@@ -10,6 +11,7 @@ module Semantic.Util
1011
, mergeErrors
1112
, reassociate
1213
, parseFile
14+
, parseFileQuiet
1315
) where
1416

1517
import Prelude hiding (readFile)
@@ -30,6 +32,7 @@ import Data.Blob.IO
3032
import Data.Graph (topologicalSort)
3133
import qualified Data.Language as Language
3234
import Data.List (uncons)
35+
import Data.Location
3336
import Data.Project hiding (readFile)
3437
import Data.Quieterm (Quieterm, quieterm)
3538
import Data.Sum (weaken)
@@ -47,70 +50,11 @@ import Semantic.Task
4750
import System.Exit (die)
4851
import System.FilePath.Posix (takeDirectory)
4952

50-
import Data.Location
51-
52-
-- The type signatures in these functions are pretty gnarly, but these functions
53-
-- are hit sufficiently often in the CLI and test suite so as to merit avoiding
54-
-- the overhead of repeated type inference. If you have to hack on these functions,
55-
-- it's recommended to remove all the type signatures and add them back when you
56-
-- are done (type holes in GHCi will help here).
57-
58-
justEvaluating :: Evaluator
59-
term
60-
Precise
61-
(Value term Precise)
62-
(ResumableC
63-
(BaseError (ValueError term Precise))
64-
(ResumableC
65-
(BaseError (AddressError Precise (Value term Precise)))
66-
(ResumableC
67-
(BaseError ResolutionError)
68-
(ResumableC
69-
(BaseError
70-
(EvalError term Precise (Value term Precise)))
71-
(ResumableC
72-
(BaseError (HeapError Precise))
73-
(ResumableC
74-
(BaseError (ScopeError Precise))
75-
(ResumableC
76-
(BaseError
77-
(UnspecializedError
78-
Precise (Value term Precise)))
79-
(ResumableC
80-
(BaseError
81-
(LoadError
82-
Precise
83-
(Value term Precise)))
84-
(FreshC
85-
(StateC
86-
(ScopeGraph
87-
Precise)
88-
(StateC
89-
(Heap
90-
Precise
91-
Precise
92-
(Value
93-
term
94-
Precise))
95-
(TraceByPrintingC
96-
(LiftC
97-
IO)))))))))))))
98-
result
99-
-> IO
100-
(Heap Precise Precise (Value term Precise),
101-
(ScopeGraph Precise,
102-
Either
103-
(SomeError
104-
(Sum
105-
'[BaseError (ValueError term Precise),
106-
BaseError (AddressError Precise (Value term Precise)),
107-
BaseError ResolutionError,
108-
BaseError (EvalError term Precise (Value term Precise)),
109-
BaseError (HeapError Precise),
110-
BaseError (ScopeError Precise),
111-
BaseError (UnspecializedError Precise (Value term Precise)),
112-
BaseError (LoadError Precise (Value term Precise))]))
113-
result))
53+
justEvaluating :: Evaluator term Precise (Value term Precise) _ result
54+
-> IO ( Heap Precise Precise (Value term Precise),
55+
( ScopeGraph Precise
56+
, Either (SomeError (Sum _)) result)
57+
)
11458
justEvaluating
11559
= runM
11660
. runEvaluator
@@ -128,75 +72,27 @@ justEvaluating
12872
. runAddressError
12973
. runValueError
13074

131-
type FileEvaluator syntax =
75+
type FileEvaluator err syntax =
13276
[FilePath]
13377
-> IO
134-
(Heap
135-
Precise
136-
Precise
137-
(Value
138-
(Quieterm (Sum syntax) Location) Precise),
139-
(ScopeGraph Precise,
140-
Either
141-
(SomeError
142-
(Sum
143-
'[BaseError
144-
(ValueError
145-
(Quieterm (Sum syntax) Location)
146-
Precise),
147-
BaseError
148-
(AddressError
149-
Precise
150-
(Value
151-
(Quieterm
152-
(Sum syntax) Location)
153-
Precise)),
154-
BaseError ResolutionError,
155-
BaseError
156-
(EvalError
157-
(Quieterm (Sum syntax) Location)
158-
Precise
159-
(Value
160-
(Quieterm
161-
(Sum syntax) Location)
162-
Precise)),
163-
BaseError (HeapError Precise),
164-
BaseError (ScopeError Precise),
165-
BaseError
166-
(UnspecializedError
167-
Precise
168-
(Value
169-
(Quieterm
170-
(Sum syntax) Location)
171-
Precise)),
172-
BaseError
173-
(LoadError
174-
Precise
175-
(Value
176-
(Quieterm
177-
(Sum syntax) Location)
178-
Precise))]))
179-
(ModuleTable
180-
(Module
181-
(ModuleResult
182-
Precise
183-
(Value
184-
(Quieterm (Sum syntax) Location)
185-
Precise))))))
78+
( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise),
79+
( ScopeGraph Precise
80+
, Either (SomeError (Sum err))
81+
(ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Location) Precise))))))
18682

187-
evalGoProject :: FileEvaluator Language.Go.Assignment.Syntax
83+
evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax
18884
evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser
18985

190-
evalRubyProject :: FileEvaluator Language.Ruby.Assignment.Syntax
86+
evalRubyProject :: FileEvaluator _ Language.Ruby.Assignment.Syntax
19187
evalRubyProject = justEvaluating <=< evaluateProject (Proxy @'Language.Ruby) rubyParser
19288

193-
evalPHPProject :: FileEvaluator Language.PHP.Assignment.Syntax
89+
evalPHPProject :: FileEvaluator _ Language.PHP.Assignment.Syntax
19490
evalPHPProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser
19591

196-
evalPythonProject :: FileEvaluator Language.Python.Assignment.Syntax
197-
evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser
92+
evalPythonProject :: FileEvaluator _ Language.Python.Assignment.Syntax
93+
evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser
19894

199-
evalTypeScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
95+
evalTypeScriptProject :: FileEvaluator _ Language.TypeScript.Assignment.Syntax
20096
evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser
20197

20298
evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger statter ->
@@ -218,11 +114,13 @@ evaluateProject' session proxy parser paths = do
218114
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
219115
either (die . displayException) pure res
220116

221-
parseFile :: Parser term -> FilePath -> IO term
117+
parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
222118
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
119+
parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
223120

224-
runTask' :: TaskEff a -> IO a
121+
runTask', runTaskQuiet :: TaskEff a -> IO a
225122
runTask' task = runTaskWithOptions debugOptions task >>= either (die . displayException) pure
123+
runTaskQuiet task = runTaskWithOptions defaultOptions task >>= either (die . displayException) pure
226124

227125
mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
228126
mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)

‎test/Analysis/Go/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import SpecHelpers
88

99

1010
spec :: (?session :: TaskSession) => Spec
11-
spec = parallel $ do
11+
spec = do
1212
describe "Go" $ do
1313
it "imports and wildcard imports" $ do
1414
(scopeGraph, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]

‎test/Analysis/PHP/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import SpecHelpers
99

1010

1111
spec :: (?session :: TaskSession) => Spec
12-
spec = parallel $ do
12+
spec = do
1313
describe "PHP" $ do
1414
xit "evaluates include and require" $ do
1515
(scopeGraph, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]

‎test/Analysis/Python/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import SpecHelpers
1010

1111

1212
spec :: (?session :: TaskSession) => Spec
13-
spec = parallel $ do
13+
spec = do
1414
describe "Python" $ do
1515
it "imports" $ do
1616
(scopeGraph, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]

‎test/Analysis/Ruby/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ import SpecHelpers
1515

1616

1717
spec :: (?session :: TaskSession) => Spec
18-
spec = parallel $ do
18+
spec = do
1919
describe "Ruby" $ do
2020
it "evaluates require_relative" $ do
2121
(scopeGraph, (heap, res)) <- evaluate ["main.rb", "foo.rb"]

‎test/Analysis/TypeScript/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import qualified Language.TypeScript.Assignment as TypeScript
2323
import SpecHelpers
2424

2525
spec :: (?session :: TaskSession) => Spec
26-
spec = parallel $ do
26+
spec = do
2727
describe "TypeScript" $ do
2828
it "qualified export from" $ do
2929
(scopeGraph, (heap, res)) <- evaluate ["main6.ts", "baz.ts", "foo.ts"]

‎test/Assigning/Assignment/Spec.hs‎

Lines changed: 26 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -44,35 +44,37 @@ spec = do
4444
`shouldBe`
4545
Right [Out "hello"]
4646

47-
it "distributes through overlapping committed choices, matching the left alternative" $
48-
fst <$> runAssignment "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]])
49-
`shouldBe`
50-
Right (Out "(green)")
47+
describe "distributing through overlapping committed choices" $ do
5148

52-
it "distributes through overlapping committed choices, matching the right alternative" $
53-
fst <$> runAssignment "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]])
54-
`shouldBe`
55-
Right (Out "(blue)")
49+
it "matches the left alternative" $
50+
fst <$> runAssignment "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]])
51+
`shouldBe`
52+
Right (Out "(green)")
5653

57-
it "distributes through overlapping committed choices, matching the left alternatives" $
58-
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 []])
59-
`shouldBe`
60-
Right [Out "green", Out "green"]
54+
it "matches the right alternative" $
55+
fst <$> runAssignment "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]])
56+
`shouldBe`
57+
Right (Out "(blue)")
6158

62-
it "distributes through overlapping committed choices, matching the empty list" $
63-
fst <$> runAssignment "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []])
64-
`shouldBe`
65-
Right (Left [])
59+
it "matches the left alternatives" $
60+
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 []])
61+
`shouldBe`
62+
Right [Out "green", Out "green"]
6663

67-
it "distributes through overlapping committed choices, dropping anonymous nodes & matching the left alternative" $
68-
fst <$> runAssignment "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []])
69-
`shouldBe`
70-
Right (Out "green")
64+
it "matches the empty list" $
65+
fst <$> runAssignment "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []])
66+
`shouldBe`
67+
Right (Left [])
7168

72-
it "distributes through overlapping committed choices, dropping anonymous nodes & matching the right alternative" $
73-
fst <$> runAssignment "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []])
74-
`shouldBe`
75-
Right (Out "blue")
69+
it "drops anonymous nodes & matches the left alternative" $
70+
fst <$> runAssignment "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []])
71+
`shouldBe`
72+
Right (Out "green")
73+
74+
it "drops anonymous nodes & matches the right alternative" $
75+
fst <$> runAssignment "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []])
76+
`shouldBe`
77+
Right (Out "blue")
7678

7779
it "alternates repetitions, matching the left alternative" $
7880
fst <$> runAssignment "green green" (many green <|> many blue) (makeState [node Green 0 5 [], node Green 6 11 []])

0 commit comments

Comments
 (0)