831b23a · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #2137 from garyb/warnings-tests

831b23aGary Burgess10 years ago

examples/warning/DuplicateExportRef.pursnew file+30

compare with golang

unifiedsplit

@@ -0,0 +1,30 @@

1+-- @shouldWarnWith DuplicateExportRef

2+-- @shouldWarnWith DuplicateExportRef

3+-- @shouldWarnWith DuplicateExportRef

4+-- @shouldWarnWith DuplicateExportRef

5+-- @shouldWarnWith DuplicateExportRef

6+-- @shouldWarnWith DuplicateExportRef

7+-- @shouldWarnWith DuplicateExportRef

8+module Main

9+ ( X(X, X), X

10+ , fn, fn

11+ , (!), (!)

12+ , class Y, class Y

13+ , Natural, type (~>), type (~>)

14+ , module Prelude, module Prelude

15+ ) where

16+

17+import Prelude (Unit)

18+

19+data X = X

20+

21+fn :: X -> X -> X

22+fn _ _ = X

23+

24+infix 2 fn as !

25+

26+class Y a

27+

28+type Natural f g = forall a. f a -> g a

29+

30+infixl 1 type Natural as ~>

examples/warning/DuplicateImport.pursnew file+10

@@ -0,0 +1,10 @@

1+-- @shouldWarnWith DuplicateImport

2+module Main where

4+import Prelude (Unit, unit, pure)

5+import Prelude (Unit, unit, pure)

7+import Control.Monad.Eff (Eff)

9+main :: Eff () Unit

10+main = pure unit

examples/warning/DuplicateImportRef.pursnew file+18

@@ -0,0 +1,18 @@

1+-- @shouldWarnWith DuplicateImportRef

2+-- @shouldWarnWith DuplicateImportRef

3+-- @shouldWarnWith DuplicateImportRef

4+-- @shouldWarnWith DuplicateImportRef

5+module Main where

7+import Prelude

8+ ( Unit, Unit

9+ , unit, unit

10+ , class Functor, class Functor

11+ , (<>), (<>)

12+ )

13+

14+u :: Unit

15+u = unit <> unit

16+

17+fid :: forall f a. Functor f => f a -> f a

18+fid fa = fa

examples/warning/DuplicateSelectiveImport.pursnew file+10

@@ -0,0 +1,10 @@

1+-- @shouldWarnWith DuplicateSelectiveImport

2+module Main where

4+import Prelude (Unit, unit)

5+import Prelude (pure)

7+import Control.Monad.Eff (Eff)

9+main :: Eff () Unit

10+main = pure unit

examples/warning/HidingImport.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldWarnWith HidingImport

2+-- @shouldWarnWith HidingImport

3+module Main where

5+import Prelude hiding (one)

6+import Control.Monad.Eff hiding (runPure)

8+main :: Eff () Unit

9+main = pure unit

examples/warning/ImplicitImport.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldWarnWith ImplicitImport

2+-- @shouldWarnWith ImplicitImport

3+module Main where

5+import Prelude

6+import Control.Monad.Eff

8+main :: Eff () Unit

9+main = pure unit

examples/warning/ImplicitQualifiedImport.pursnew file+11

@@ -0,0 +1,11 @@

1+-- @shouldWarnWith ImplicitQualifiedImport

2+-- @shouldWarnWith ImplicitQualifiedImport

3+module Main where

5+import Data.Unit

7+import Control.Monad.Eff as E

8+import Control.Monad.Eff.Console as E

10+main :: E.Eff (console :: E.CONSOLE) Unit

11+main = E.log "test"

examples/warning/MissingTypeDeclaration.pursnew file+4

@@ -0,0 +1,4 @@

1+-- @shouldWarnWith MissingTypeDeclaration

2+module Main where

4+x = 0

examples/warning/OverlappingInstances.pursnew file+17

@@ -0,0 +1,17 @@

1+-- @shouldWarnWith OverlappingInstances

2+module Main where

4+class Test a where

5+ test :: a -> a

7+instance testRefl :: Test a where

8+ test x = x

10+instance testInt :: Test Int where

11+ test _ = 0

12+

13+-- The OverlappingInstances instances warning only arises when there are two

14+-- choices for a dictionary, not when the instances are defined. So without

15+-- `value` this module would not raise a warning.

16+value :: Int

17+value = test 1

examples/warning/OverlappingPattern.pursnew file+15

@@ -0,0 +1,15 @@

1+-- @shouldWarnWith OverlappingPattern

2+-- @shouldWarnWith OverlappingPattern

3+module Main where

5+data X = A | B

7+pat1 :: X -> Boolean

8+pat1 A = true

9+pat1 A = true

10+pat1 B = false

11+

12+pat2 :: X -> Boolean

13+pat2 A = true

14+pat2 _ = false

15+pat2 B = false

examples/warning/ScopeShadowing.pursnew file+13

@@ -0,0 +1,13 @@

1+-- @shouldWarnWith ScopeShadowing

2+module Main where

4+import Prelude

6+-- No warning at the definition, only when the name is later resolved

7+data Unit = Unit

9+-- This is only a warning as the `Prelude` import is implicit. If `Unit` was

10+-- named explicitly in an import list, then this refernce to `Unit`

11+-- would be a `ScopeConflict` error instead.

12+test :: Unit

13+test = const Unit unit

examples/warning/ShadowedTypeVar.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldWarnWith ShadowedTypeVar

2+module Main where

4+f :: forall a. (forall a. a -> a) -> a -> a

5+f g x = g x

examples/warning/UnnecessaryFFIModule.jsnew file+1

@@ -0,0 +1 @@

1+exports.out = null;

examples/warning/UnnecessaryFFIModule.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldWarnWith UnnecessaryFFIModule

2+module Main where

4+t :: Boolean

5+t = true

examples/warning/UnusedDctorExplicitImport.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldWarnWith UnusedDctorExplicitImport

2+module Main where

4+import Data.Ordering (Ordering(EQ, LT))

6+f :: Ordering -> Ordering

7+f EQ = EQ

8+f x = x

examples/warning/UnusedDctorImportAll.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldWarnWith UnusedDctorImport

2+module Main where

4+import Data.Ordering (Ordering(..))

6+f :: Ordering -> Ordering

7+f x = x

examples/warning/UnusedDctorImportExplicit.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldWarnWith UnusedDctorImport

2+module Main where

4+import Data.Ordering (Ordering(EQ))

6+f :: Ordering -> Ordering

7+f x = x

examples/warning/UnusedExplicitImport.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldWarnWith UnusedExplicitImport

2+module Main where

4+import Prelude (Unit, unit, pure, bind)

5+import Control.Monad.Eff (Eff)

7+main :: Eff () Unit

8+main = pure unit

examples/warning/UnusedFFIImplementations.jsnew file+2

@@ -0,0 +1,2 @@

1+exports.yes = true;

2+exports.no = false;

examples/warning/UnusedFFIImplementations.pursnew file+4

@@ -0,0 +1,4 @@

1+-- @shouldWarnWith UnusedFFIImplementations

2+module Main where

4+foreign import yes :: Boolean

examples/warning/UnusedImport.pursnew file+14

@@ -0,0 +1,14 @@

1+-- @shouldWarnWith UnusedImport

2+-- @shouldWarnWith UnusedImport

3+-- @shouldWarnWith UnusedImport

4+module Main where

6+import Data.Unit (Unit, unit)

8+-- All of the below are unused

9+import Control.Monad.Eff

10+import Control.Monad.Eff.Console as Console

11+import Test.Assert ()

12+

13+main :: Unit

14+main = unit

examples/warning/UnusedTypeVar.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldWarnWith UnusedTypeVar

2+module Main where

4+f :: forall a b. a -> a

5+f x = x

examples/warning/WildcardInferredType.pursnew file+23

@@ -0,0 +1,23 @@

1+-- @shouldWarnWith WildcardInferredType

2+-- @shouldWarnWith WildcardInferredType

3+-- @shouldWarnWith WildcardInferredType

4+-- @shouldWarnWith WildcardInferredType

5+module Main where

7+x :: Int

8+x = 0 :: _

10+y :: _

11+y = 0

12+

13+z :: Int

14+z =

15+ let n :: _

16+ n = 0

17+ in n

18+

19+w :: Int

20+w = n

21+ where

22+ n :: _

23+ n = 0

purescript.cabal+2

@@ -66,6 +66,8 @@ extra-source-files: examples/passing/*.purs

66 , examples/failing/InstanceExport/*.purs

67 , examples/failing/OrphanInstance/*.purs

68 , examples/failing/OverlappingReExport/*.purs

69+ , examples/warning/*.purs

70+ , examples/warning/*.js

69 , examples/docs/bower_components/purescript-prelude/src/*.purs

71 , examples/docs/bower_components/purescript-prelude/src/*.purs

70 , examples/docs/bower.json

72 , examples/docs/bower.json

71 , examples/docs/src/*.purs

73 , examples/docs/src/*.purs

src/Language/PureScript/Errors.hs−6

@@ -127,7 +127,6 @@ data SimpleErrorMessage

127 | DuplicateImportRef Name

128 | DuplicateExportRef Name

129 | IntOutOfRange Integer String Integer Integer

130− | RedundantEmptyHidingImport ModuleName

131 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

130 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

132 | ImplicitImport ModuleName [DeclarationRef]

131 | ImplicitImport ModuleName [DeclarationRef]

133 | HidingImport ModuleName [DeclarationRef]

132 | HidingImport ModuleName [DeclarationRef]

@@ -297,7 +296,6 @@ errorCode em = case unwrapErrorMessage em of

297 DuplicateImportRef{} -> "DuplicateImportRef"

296 DuplicateImportRef{} -> "DuplicateImportRef"

298 DuplicateExportRef{} -> "DuplicateExportRef"

297 DuplicateExportRef{} -> "DuplicateExportRef"

299 IntOutOfRange{} -> "IntOutOfRange"

298 IntOutOfRange{} -> "IntOutOfRange"

300− RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

301 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

299 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

302 ImplicitImport{} -> "ImplicitImport"

300 ImplicitImport{} -> "ImplicitImport"

303 HidingImport{} -> "HidingImport"

301 HidingImport{} -> "HidingImport"

@@ -418,7 +416,6 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error

418errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

416errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

419errorSuggestion err = case err of

417errorSuggestion err = case err of

420 UnusedImport{} -> emptySuggestion

418 UnusedImport{} -> emptySuggestion

421− RedundantEmptyHidingImport{} -> emptySuggestion

422 DuplicateImport{} -> emptySuggestion

419 DuplicateImport{} -> emptySuggestion

423 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

420 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

424 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

421 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

@@ -868,9 +865,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

868 paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."

865 paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."

869 , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]

866 , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]

870

867

871− renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

872− line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

873−

874 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

868 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

875 paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."

869 paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."

876 , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"

870 , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"

src/Language/PureScript/Linter/Imports.hs+18−32

@@ -6,7 +6,7 @@ module Language.PureScript.Linter.Imports

7import Prelude.Compat

9−import Control.Monad (join, unless, when, foldM, (<=<))

9+import Control.Monad (join, unless, foldM, (<=<))

10import Control.Monad.Writer.Class

12import Data.Function (on)

@@ -54,7 +54,8 @@ lintImports

54 -> Env

55 -> UsedImports

56 -> m ()

57−lintImports (Module _ _ _ _ Nothing) _ _ = return ()

57+lintImports (Module _ _ _ _ Nothing) _ _ =

58+ internalError "lintImports needs desugared exports"

58lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

59lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

60 -- TODO: this needs some work to be easier to understand

61 -- TODO: this needs some work to be easier to understand

@@ -100,13 +101,11 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

100 maybe id warnWithPosition pos $

101 maybe id warnWithPosition pos $

101 tell $ errorMessage $ DuplicateSelectiveImport mnq

102 tell $ errorMessage $ DuplicateSelectiveImport mnq

102

103

103− for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> do

104+ for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) ->

104 warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of

105 warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of

105 Explicit refs -> refs

106 Explicit refs -> refs

106 Hiding refs -> refs

107 Hiding refs -> refs

107 _ -> []

108 _ -> []

108− for_ (M.lookup mn env) $ \(_, imported, _) ->

109− checkEmptyImport mnq imported typ

110

109

111 where

110 where

112

111

@@ -120,9 +119,9 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

120 countOpenImports :: Declaration -> Int

119 countOpenImports :: Declaration -> Int

121 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

120 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

122 countOpenImports (ImportDeclaration mn' Implicit Nothing)

121 countOpenImports (ImportDeclaration mn' Implicit Nothing)

123− | not (isPrim mn') = 1

122+ | not (isPrim mn' || mn == mn') = 1

124 countOpenImports (ImportDeclaration mn' (Hiding _) Nothing)

123 countOpenImports (ImportDeclaration mn' (Hiding _) Nothing)

125− | not (isPrim mn') = 1

124+ | not (isPrim mn' || mn == mn') = 1

126 countOpenImports _ = 0

125 countOpenImports _ = 0

127

126

128 -- Checks whether a module is the Prim module - used to suppress any checks

127 -- Checks whether a module is the Prim module - used to suppress any checks

@@ -199,7 +198,10 @@ lintImportDecl

199lintImportDecl env mni qualifierName names declType allowImplicit =

198lintImportDecl env mni qualifierName names declType allowImplicit =

200 case declType of

199 case declType of

201 Implicit -> case qualifierName of

200 Implicit -> case qualifierName of

201+ Nothing ->

202+ if null allRefs

203+ then unused

202− Nothing -> unless' allowImplicit (checkImplicit ImplicitImport)

204+ else unless' allowImplicit (checkImplicit ImplicitImport)

203 Just q -> unless' (q `elem` mapMaybe getQual names) unused

205 Just q -> unless' (q `elem` mapMaybe getQual names) unused

204 Hiding _ -> unless' allowImplicit (checkImplicit HidingImport)

206 Hiding _ -> unless' allowImplicit (checkImplicit HidingImport)

205 Explicit [] -> unused

207 Explicit [] -> unused

@@ -256,9 +258,15 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

256 warn :: SimpleErrorMessage -> m Bool

258 warn :: SimpleErrorMessage -> m Bool

257 warn err = tell (errorMessage err) >> return True

259 warn err = tell (errorMessage err) >> return True

258

260

261+ -- Unless the boolean is true, run the action. Return false when the action is

262+ -- not run, otherwise return whatever the action does.

263+ --

264+ -- The return value is intended for cases where we want to track whether some

265+ -- work was done, as there may be further conditions in the action that mean

266+ -- it ends up doing nothing.

259 unless' :: Bool -> m Bool -> m Bool

267 unless' :: Bool -> m Bool -> m Bool

260− unless' True m = m

268+ unless' False m = m

261− unless' False _ = return False

269+ unless' True _ = return False

262

270

263 allRefs :: [DeclarationRef]

271 allRefs :: [DeclarationRef]

264 allRefs = findUsedRefs env mni qualifierName names

272 allRefs = findUsedRefs env mni qualifierName names

@@ -352,25 +360,3 @@ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

352 tell $ errorMessage $ DuplicateImport mn t2 q2

360 tell $ errorMessage $ DuplicateImport mn t2 q2

353 return $ (pos, t2, q2) : xs

361 return $ (pos, t2, q2) : xs

354 else return xs

362 else return xs

355−

356−-- |

357−-- Checks that an import with a hiding reference is not hiding all possible

358−-- imports.

359−--

360−checkEmptyImport

361− :: MonadWriter MultipleErrors m

362− => ModuleName

363− -> Imports

364− -> ImportDeclarationType

365− -> m ()

366−checkEmptyImport importModule imps (Hiding _) = do

367− let isEmptyImport

368− = M.null (importedTypes imps)

369− && M.null (importedTypeOps imps)

370− && M.null (importedDataConstructors imps)

371− && M.null (importedTypeClasses imps)

372− && M.null (importedValues imps)

373− && M.null (importedValueOps imps)

374− when isEmptyImport . tell . errorMessage $

375− RedundantEmptyHidingImport importModule

376−checkEmptyImport _ _ _ = return ()

src/Language/PureScript/Sugar/Names.hs+1−1

@@ -111,7 +111,7 @@ desugarImportsWithEnv externs modules = do

111 warnAndRethrow (addHint (ErrorInModule mn)) $ do

112 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

113 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)

114− lintImports m env used

114+ lintImports m' env used

115 return m'

116

117-- |

src/Language/PureScript/Sugar/Names/Common.hs+3−1

@@ -43,15 +43,17 @@ warnDuplicateRefs pos toError refs = do

43 -- referenced type is used in the duplicate check - constructors are handled

44 -- separately

45 deleteCtors :: DeclarationRef -> DeclarationRef

46+ deleteCtors (PositionedDeclarationRef ss com ref) =

47+ PositionedDeclarationRef ss com (deleteCtors ref)

46 deleteCtors (TypeRef pn _) = TypeRef pn Nothing

48 deleteCtors (TypeRef pn _) = TypeRef pn Nothing

47 deleteCtors other = other

49 deleteCtors other = other

49 -- Extracts the names of duplicate constructor references from TypeRefs.

51 -- Extracts the names of duplicate constructor references from TypeRefs.

50 extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]

52 extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]

53+ extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref

51 extractCtors pos' (TypeRef _ (Just dctors)) =

54 extractCtors pos' (TypeRef _ (Just dctors)) =

52 let dupes = dctors \\ nub dctors

55 let dupes = dctors \\ nub dctors

53 in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes

56 in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes

54− extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref

55 extractCtors _ _ = Nothing

57 extractCtors _ _ = Nothing

57 -- Converts a DeclarationRef into a name for an error message.

59 -- Converts a DeclarationRef into a name for an error message.

tests/TestCompiler.hs+65−30

@@ -27,7 +27,7 @@ import qualified Language.PureScript as P

28import Data.Char (isSpace)

29import Data.Function (on)

30−import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy)

30+import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

31import Data.Maybe (mapMaybe)

32import Data.Time.Clock (UTCTime())

33import Data.Tuple (swap)

@@ -58,31 +58,40 @@ main = hspec spec

58spec :: Spec

59spec = do

61− (supportExterns, passingTestCases, failingTestCases) <- runIO $ do

61+ (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do

62 cwd <- getCurrentDirectory

63 let passing = cwd </> "examples" </> "passing"

64+ let warning = cwd </> "examples" </> "warning"

64 let failing = cwd </> "examples" </> "failing"

65 let failing = cwd </> "examples" </> "failing"

65 let supportDir = cwd </> "tests" </> "support" </> "bower_components"

66 let supportDir = cwd </> "tests" </> "support" </> "bower_components"

66 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir

67 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir

67 passingFiles <- getTestFiles passing <$> testGlob passing

68 passingFiles <- getTestFiles passing <$> testGlob passing

69+ warningFiles <- getTestFiles warning <$> testGlob warning

68 failingFiles <- getTestFiles failing <$> testGlob failing

70 failingFiles <- getTestFiles failing <$> testGlob failing

69 supportPurs <- supportFiles "purs"

71 supportPurs <- supportFiles "purs"

70 supportPursFiles <- readInput supportPurs

72 supportPursFiles <- readInput supportPurs

71 supportExterns <- runExceptT $ do

73 supportExterns <- runExceptT $ do

72 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

74 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

73 foreigns <- inferForeignModules modules

75 foreigns <- inferForeignModules modules

74− externs <- ExceptT . runTest $ P.make (makeActions foreigns) (map snd modules)

76+ externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

75 return (zip (map snd modules) externs)

77 return (zip (map snd modules) externs)

76 case supportExterns of

78 case supportExterns of

77 Left errs -> fail (P.prettyPrintMultipleErrors False errs)

79 Left errs -> fail (P.prettyPrintMultipleErrors False errs)

78− Right externs -> return (externs, passingFiles, failingFiles)

80+ Right externs -> return (externs, passingFiles, warningFiles, failingFiles)

80− context ("Passing examples") $ do

82+ context "Passing examples" $

81 forM_ passingTestCases $ \testPurs ->

83 forM_ passingTestCases $ \testPurs ->

82 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

84 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

83 assertCompiles supportExterns testPurs

85 assertCompiles supportExterns testPurs

87+ context "Warning examples" $

88+ forM_ warningTestCases $ \testPurs -> do

89+ let mainPath = getTestMain testPurs

90+ expectedWarnings <- runIO $ getShouldWarnWith mainPath

91+ it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $

92+ assertCompilesWithWarnings supportExterns testPurs expectedWarnings

93+

85− context ("Failing examples") $ do

94+ context "Failing examples" $

86 forM_ failingTestCases $ \testPurs -> do

95 forM_ failingTestCases $ \testPurs -> do

87 let mainPath = getTestMain testPurs

96 let mainPath = getTestMain testPurs

88 expectedFailures <- runIO $ getShouldFailWith mainPath

97 expectedFailures <- runIO $ getShouldFailWith mainPath

@@ -100,8 +109,7 @@ spec = do

100 -- .purs files and the .js files for the test case.

109 -- .purs files and the .js files for the test case.

101 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]

110 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]

102 getTestFiles baseDir

111 getTestFiles baseDir

103− = map (filter ((== ".purs") . takeExtensions))

112+ = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))

104− . map (map (baseDir </>))

105 . groupBy ((==) `on` extractPrefix)

113 . groupBy ((==) `on` extractPrefix)

106 . sortBy (compare `on` extractPrefix)

114 . sortBy (compare `on` extractPrefix)

107 . map (makeRelative baseDir)

115 . map (makeRelative baseDir)

@@ -110,7 +118,7 @@ spec = do

110 -- by the file with the shortest path name, as everything but the main file

118 -- by the file with the shortest path name, as everything but the main file

111 -- will be under a subdirectory.

119 -- will be under a subdirectory.

112 getTestMain :: [FilePath] -> FilePath

120 getTestMain :: [FilePath] -> FilePath

113− getTestMain = head . sortBy (compare `on` length)

121+ getTestMain = minimumBy (compare `on` length)

114

122

115 -- Extracts the filename part of a .purs file, or if the file is in a

123 -- Extracts the filename part of a .purs file, or if the file is in a

116 -- subdirectory, the first part of that directory path.

124 -- subdirectory, the first part of that directory path.

@@ -125,9 +133,17 @@ spec = do

125 -- Scans a file for @shouldFailWith directives in the comments, used to

133 -- Scans a file for @shouldFailWith directives in the comments, used to

126 -- determine expected failures

134 -- determine expected failures

127 getShouldFailWith :: FilePath -> IO [String]

135 getShouldFailWith :: FilePath -> IO [String]

128− getShouldFailWith = fmap extractFailWiths . readUTF8File

136+ getShouldFailWith = extractPragma "shouldFailWith"

137+

138+ -- Scans a file for @shouldWarnWith directives in the comments, used to

139+ -- determine expected warnings

140+ getShouldWarnWith :: FilePath -> IO [String]

141+ getShouldWarnWith = extractPragma "shouldWarnWith"

142+

143+ extractPragma :: String -> FilePath -> IO [String]

144+ extractPragma pragma = fmap go . readUTF8File

129 where

145 where

130− extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim

146+ go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim

131

147

132inferForeignModules

148inferForeignModules

133 :: MonadIO m

149 :: MonadIO m

@@ -168,16 +184,14 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

168 text <- readUTF8File inputFile

184 text <- readUTF8File inputFile

169 return (inputFile, text)

185 return (inputFile, text)

170

186

171−type TestM = WriterT [(FilePath, String)] IO

172−

173−runTest :: P.Make a -> IO (Either P.MultipleErrors a)

187+runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)

174−runTest = fmap fst . P.runMake P.defaultOptions

188+runTest = P.runMake P.defaultOptions

175

189

176compile

190compile

177 :: [(P.Module, P.ExternsFile)]

191 :: [(P.Module, P.ExternsFile)]

178 -> [FilePath]

192 -> [FilePath]

179 -> ([P.Module] -> IO ())

193 -> ([P.Module] -> IO ())

180− -> IO (Either P.MultipleErrors [P.ExternsFile])

194+ -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

181compile supportExterns inputFiles check = silence $ runTest $ do

195compile supportExterns inputFiles check = silence $ runTest $ do

182 fs <- liftIO $ readInput inputFiles

196 fs <- liftIO $ readInput inputFiles

183 ms <- P.parseModulesFromFiles id fs

197 ms <- P.parseModulesFromFiles id fs

@@ -192,18 +206,30 @@ assert

192 :: [(P.Module, P.ExternsFile)]

206 :: [(P.Module, P.ExternsFile)]

193 -> [FilePath]

207 -> [FilePath]

194 -> ([P.Module] -> IO ())

208 -> ([P.Module] -> IO ())

195− -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String))

209+ -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))

196 -> Expectation

210 -> Expectation

197assert supportExterns inputFiles check f = do

211assert supportExterns inputFiles check f = do

198− e <- compile supportExterns inputFiles check

212+ (e, w) <- compile supportExterns inputFiles check

199− maybeErr <- f e

213+ maybeErr <- f (const w <$> e)

200 maybe (return ()) expectationFailure maybeErr

214 maybe (return ()) expectationFailure maybeErr

201

215

216+checkMain :: [P.Module] -> IO ()

217+checkMain ms =

218+ unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)

219+ (fail "Main module missing")

220+

221+checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String

222+checkShouldFailWith expected errs =

223+ let actual = map P.errorCode $ P.runMultipleErrors errs

224+ in if sort expected == sort actual

225+ then Nothing

226+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

227+

202assertCompiles

228assertCompiles

203 :: [(P.Module, P.ExternsFile)]

229 :: [(P.Module, P.ExternsFile)]

204 -> [FilePath]

230 -> [FilePath]

205 -> Expectation

231 -> Expectation

206−assertCompiles supportExterns inputFiles = do

232+assertCompiles supportExterns inputFiles =

207 assert supportExterns inputFiles checkMain $ \e ->

233 assert supportExterns inputFiles checkMain $ \e ->

208 case e of

234 case e of

209 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs

235 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs

@@ -219,17 +245,32 @@ assertCompiles supportExterns inputFiles = do

219 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

245 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

220 Just (ExitFailure _, _, err) -> return $ Just err

246 Just (ExitFailure _, _, err) -> return $ Just err

221 Nothing -> return $ Just "Couldn't find node.js executable"

247 Nothing -> return $ Just "Couldn't find node.js executable"

248+

249+assertCompilesWithWarnings

250+ :: [(P.Module, P.ExternsFile)]

251+ -> [FilePath]

252+ -> [String]

253+ -> Expectation

254+assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =

255+ assert supportExterns inputFiles checkMain $ \e ->

256+ case e of

257+ Left errs ->

258+ return . Just . P.prettyPrintMultipleErrors False $ errs

259+ Right warnings ->

260+ return

261+ . fmap (printAllWarnings warnings)

262+ $ checkShouldFailWith shouldWarnWith warnings

263+

222 where

264 where

223− checkMain ms =

265+ printAllWarnings warnings =

224− unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)

266+ (<> "\n\n" <> P.prettyPrintMultipleErrors False warnings)

225− (fail "Main module missing")

226

267

227assertDoesNotCompile

268assertDoesNotCompile

228 :: [(P.Module, P.ExternsFile)]

269 :: [(P.Module, P.ExternsFile)]

229 -> [FilePath]

270 -> [FilePath]

230 -> [String]

271 -> [String]

231 -> Expectation

272 -> Expectation

232−assertDoesNotCompile supportExterns inputFiles shouldFailWith = do

273+assertDoesNotCompile supportExterns inputFiles shouldFailWith =

233 assert supportExterns inputFiles noPreCheck $ \e ->

274 assert supportExterns inputFiles noPreCheck $ \e ->

234 case e of

275 case e of

235 Left errs ->

276 Left errs ->

@@ -243,9 +284,3 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith = do

243

284

244 where

285 where

245 noPreCheck = const (return ())

286 noPreCheck = const (return ())

246−

247− checkShouldFailWith expected errs =

248− let actual = map P.errorCode $ P.runMultipleErrors errs

249− in if sort expected == sort actual

250− then Nothing

251− else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual