8703a73 · rowtype-yoga/purescript-native

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

3+

4+import Prelude (Unit, unit, pure)

5+import Prelude (Unit, unit, pure)

6+

7+import Control.Monad.Eff (Eff)

8+

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

6+

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

3+

4+import Prelude (Unit, unit)

5+import Prelude (pure)

6+

7+import Control.Monad.Eff (Eff)

8+

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

4+

5+import Prelude hiding (one)

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

7+

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

4+

5+import Prelude

6+import Control.Monad.Eff

7+

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

4+

5+import Data.Unit

6+

7+import Control.Monad.Eff as E

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

9+

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

3+

4+x = 0

examples/warning/OverlappingInstances.pursnew file+17

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

1+-- @shouldWarnWith OverlappingInstances

2+module Main where

3+

4+class Test a where

5+ test :: a -> a

6+

7+instance testRefl :: Test a where

8+ test x = x

9+

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

4+

5+data X = A | B

6+

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

3+

4+import Prelude

5+

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

7+data Unit = Unit

8+

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

3+

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

3+

4+t :: Boolean

5+t = true

examples/warning/UnusedDctorExplicitImport.pursnew file+8

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

1+-- @shouldWarnWith UnusedDctorExplicitImport

2+module Main where

3+

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

5+

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

3+

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

5+

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

3+

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

5+

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

3+

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

5+import Control.Monad.Eff (Eff)

6+

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

3+

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

5+

6+import Data.Unit (Unit, unit)

7+

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

3+

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

6+

7+x :: Int

8+x = 0 :: _

9+

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

psc/Main.hs+21−44

@@ -1,48 +1,42 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TupleSections #-}

5{-# LANGUAGE TupleSections #-}

5

6

6module Main where

7module Main where

7

8

8−import Control.Applicative

9+import Control.Applicative

9−import Control.Monad

10+import Control.Monad

10−import Control.Monad.Error.Class (MonadError(..))

11−import Control.Monad.Writer.Strict

11+import Control.Monad.Writer.Strict

12

13−import Data.List (isSuffixOf, partition)

14−import Data.Version (showVersion)

15−import qualified Data.Map as M

16import qualified Data.Aeson as A

13import qualified Data.Aeson as A

17import qualified Data.ByteString.Lazy as B

14import qualified Data.ByteString.Lazy as B

18import qualified Data.ByteString.UTF8 as BU8

15import qualified Data.ByteString.UTF8 as BU8

16+import qualified Data.Map as M

17+import Data.Version (showVersion)

19

18

20−import Options.Applicative as Opts

19+import qualified Language.PureScript as P

20+import Language.PureScript.Errors.JSON

21+import Language.PureScript.Make

21

22

22−import System.Exit (exitSuccess, exitFailure)

23+import Options.Applicative as Opts

23−import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)

24−import System.IO.UTF8

25−import System.FilePath.Glob (glob)

26

24

27−import qualified Language.PureScript as P

28import qualified Paths_purescript as Paths

25import qualified Paths_purescript as Paths

29

26

30−import Language.PureScript.Make

27+import System.Exit (exitSuccess, exitFailure)

31−import Language.PureScript.Errors.JSON

28+import System.FilePath.Glob (glob)

29+import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)

30+import System.IO.UTF8

32

31

33data PSCMakeOptions = PSCMakeOptions

32data PSCMakeOptions = PSCMakeOptions

34 { pscmInput :: [FilePath]

33 { pscmInput :: [FilePath]

35− , pscmForeignInput :: [FilePath]

36 , pscmOutputDir :: FilePath

34 , pscmOutputDir :: FilePath

37 , pscmOpts :: P.Options

35 , pscmOpts :: P.Options

38 , pscmUsePrefix :: Bool

36 , pscmUsePrefix :: Bool

39 , pscmJSONErrors :: Bool

37 , pscmJSONErrors :: Bool

40 }

38 }

41

39

42−data InputOptions = InputOptions

43− { ioInputFiles :: [FilePath]

44− }

45−

46-- | Argumnets: verbose, use JSON, warnings, errors

40-- | Argumnets: verbose, use JSON, warnings, errors

47printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()

41printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()

48printWarningsAndErrors verbose False warnings errors = do

42printWarningsAndErrors verbose False warnings errors = do

@@ -65,14 +59,12 @@ compile PSCMakeOptions{..} = do

65 when (null input && not pscmJSONErrors) $ do

59 when (null input && not pscmJSONErrors) $ do

66 hPutStrLn stderr "psc: No input files."

60 hPutStrLn stderr "psc: No input files."

67 exitFailure

61 exitFailure

68− let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input

69− moduleFiles <- readInput (InputOptions pursFiles)

62+ moduleFiles <- readInput input

70− inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput

71− foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)

72 (makeErrors, makeWarnings) <- runMake pscmOpts $ do

63 (makeErrors, makeWarnings) <- runMake pscmOpts $ do

73− (ms, foreigns) <- parseInputs moduleFiles foreignFiles

64+ ms <- P.parseModulesFromFiles id moduleFiles

74− let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms

65+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms

66+ foreigns <- inferForeignModules filePathMap

75− makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix

67+ let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix

76 P.make makeActions (map snd ms)

68 P.make makeActions (map snd ms)

77 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors

69 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors

78 exitSuccess

70 exitSuccess

@@ -89,28 +81,14 @@ globWarningOnMisses warn = concatMapM globWithWarning

89 return paths

81 return paths

90 concatMapM f = liftM concat . mapM f

82 concatMapM f = liftM concat . mapM f

91

83

92−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

84+readInput :: [FilePath] -> IO [(FilePath, String)]

93−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile

85+readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile

94−

95−parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

96− => [(Either P.RebuildPolicy FilePath, String)]

97− -> [(FilePath, P.ForeignJS)]

98− -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)

99−parseInputs modules foreigns =

100− (,) <$> P.parseModulesFromFiles (either (const "") id) modules

101− <*> P.parseForeignModulesFromFiles foreigns

102

86

103inputFile :: Parser FilePath

87inputFile :: Parser FilePath

104inputFile = strArgument $

88inputFile = strArgument $

105 metavar "FILE"

89 metavar "FILE"

106 <> help "The input .purs file(s)"

90 <> help "The input .purs file(s)"

107

91

108−inputForeignFile :: Parser FilePath

109−inputForeignFile = strOption $

110− short 'f'

111− <> long "ffi"

112− <> help "The input .js file(s) providing foreign import implementations"

113−

114outputDirectory :: Parser FilePath

92outputDirectory :: Parser FilePath

115outputDirectory = strOption $

93outputDirectory = strOption $

116 short 'o'

94 short 'o'

@@ -173,7 +151,6 @@ options = P.Options <$> noTco

173

151

174pscMakeOptions :: Parser PSCMakeOptions

152pscMakeOptions :: Parser PSCMakeOptions

175pscMakeOptions = PSCMakeOptions <$> many inputFile

153pscMakeOptions = PSCMakeOptions <$> many inputFile

176− <*> many inputForeignFile

177 <*> outputDirectory

154 <*> outputDirectory

178 <*> options

155 <*> options

179 <*> (not <$> noPrefix)

156 <*> (not <$> noPrefix)

psci/Main.hs+4−16

@@ -37,7 +37,6 @@ import System.FilePath.Glob (glob)

37data PSCiOptions = PSCiOptions

38 { psciMultiLineMode :: Bool

39 , psciInputFile :: [FilePath]

40− , psciForeignInputFiles :: [FilePath]

41 , psciInputNodeFlags :: [String]

40 , psciInputNodeFlags :: [String]

42 }

41 }

43

42

@@ -52,12 +51,6 @@ inputFile = Opts.strArgument $

52 Opts.metavar "FILE"

51 Opts.metavar "FILE"

53 <> Opts.help "Optional .purs files to load on start"

52 <> Opts.help "Optional .purs files to load on start"

54

53

55−inputForeignFile :: Opts.Parser FilePath

56−inputForeignFile = Opts.strOption $

57− Opts.short 'f'

58− <> Opts.long "ffi"

59− <> Opts.help "The input .js file(s) providing foreign import implementations"

60−

61nodeFlagsFlag :: Opts.Parser [String]

54nodeFlagsFlag :: Opts.Parser [String]

62nodeFlagsFlag = Opts.option parser $

55nodeFlagsFlag = Opts.option parser $

63 Opts.long "node-opts"

56 Opts.long "node-opts"

@@ -70,7 +63,6 @@ nodeFlagsFlag = Opts.option parser $

70psciOptions :: Opts.Parser PSCiOptions

63psciOptions :: Opts.Parser PSCiOptions

71psciOptions = PSCiOptions <$> multiLineMode

64psciOptions = PSCiOptions <$> multiLineMode

72 <*> many inputFile

65 <*> many inputFile

73− <*> many inputForeignFile

74 <*> nodeFlagsFlag

66 <*> nodeFlagsFlag

75

67

76version :: Opts.Parser (a -> a)

68version :: Opts.Parser (a -> a)

@@ -107,24 +99,20 @@ main = getOpt >>= loop

107 loop :: PSCiOptions -> IO ()

99 loop :: PSCiOptions -> IO ()

108 loop PSCiOptions{..} = do

100 loop PSCiOptions{..} = do

109 inputFiles <- concat <$> traverse glob psciInputFile

101 inputFiles <- concat <$> traverse glob psciInputFile

110− foreignFiles <- concat <$> traverse glob psciForeignInputFiles

111 e <- runExceptT $ do

102 e <- runExceptT $ do

112 modules <- ExceptT (loadAllModules inputFiles)

103 modules <- ExceptT (loadAllModules inputFiles)

113 unless (supportModuleIsDefined (map snd modules)) . liftIO $ do

104 unless (supportModuleIsDefined (map snd modules)) . liftIO $ do

114 putStrLn supportModuleMessage

105 putStrLn supportModuleMessage

115 exitFailure

106 exitFailure

116− foreigns <- ExceptT . runMake $ do

117− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> P.readTextFile inFile)

118− P.parseForeignModulesFromFiles foreignFilesContent

119− (externs, env) <- ExceptT . runMake . make foreigns . map snd $ modules

107+ (externs, env) <- ExceptT . runMake . make $ modules

120− return (modules, foreigns, externs, env)

108+ return (modules, externs, env)

121 case e of

109 case e of

122 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

110 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

123− Right (modules, foreigns, externs, env) -> do

111+ Right (modules, externs, env) -> do

124 historyFilename <- getHistoryFilename

112 historyFilename <- getHistoryFilename

125 let settings = defaultSettings { historyFile = Just historyFilename }

113 let settings = defaultSettings { historyFile = Just historyFilename }

126 initialState = PSCiState [] [] (zip (map snd modules) externs)

114 initialState = PSCiState [] [] (zip (map snd modules) externs)

127− config = PSCiConfig inputFiles foreigns psciInputNodeFlags env

115+ config = PSCiConfig inputFiles psciInputNodeFlags env

128 runner = flip runReaderT config

116 runner = flip runReaderT config

129 . flip evalStateT initialState

117 . flip evalStateT initialState

130 . runInputT (setComplete completion settings)

118 . runInputT (setComplete completion settings)

purescript.cabal+2−1

@@ -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

@@ -179,7 +181,6 @@ library

179 Language.PureScript.Parser.Lexer

181 Language.PureScript.Parser.Lexer

180 Language.PureScript.Parser.Common

182 Language.PureScript.Parser.Common

181 Language.PureScript.Parser.Declarations

183 Language.PureScript.Parser.Declarations

182− Language.PureScript.Parser.JS

183 Language.PureScript.Parser.Kinds

184 Language.PureScript.Parser.Kinds

184 Language.PureScript.Parser.State

185 Language.PureScript.Parser.State

185 Language.PureScript.Parser.Types

186 Language.PureScript.Parser.Types

src/Language/PureScript/Docs/Convert/ReExports.hs+13−6

@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports

4

5import Prelude.Compat

6

7−import Control.Arrow ((&&&), first, second)

7+import Control.Arrow ((&&&), second)

8import Control.Monad

9import Control.Monad.Reader.Class (MonadReader, ask)

10import Control.Monad.State.Class (MonadState, gets, modify)

@@ -96,7 +96,7 @@ getReExports env mn =

96-- * Filters type class declarations to ensure that only re-exported type

97-- class members are listed.

98--

99−collectDeclarations ::

99+collectDeclarations :: forall m.

100 (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>

101 P.Imports ->

102 P.Exports ->

@@ -111,13 +111,20 @@ collectDeclarations imports exports = do

111 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

112

113 let filteredTypes = filterDataConstructors expCtors types

114− let filteredClasses = filterTypeClassMembers (map fst expVals) classes

114+ let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes

115

116 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps]))

117

118 where

119+

120+ collect

121+ :: (Eq a, Show a)

122+ => (P.ModuleName -> a -> m (P.ModuleName, [b]))

123+ -> [P.ImportRecord a]

124+ -> Map a P.ModuleName

125+ -> m (Map P.ModuleName [b])

119 collect lookup' imps exps = do

126 collect lookup' imps exps = do

120− imps' <- traverse (findImport imps) exps

127+ imps' <- traverse (findImport imps) $ Map.toList exps

121 Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

128 Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

122

129

123 expVals = P.exportedValues exports

130 expVals = P.exportedValues exports

@@ -126,13 +133,13 @@ collectDeclarations imports exports = do

126 expValOps = P.exportedValueOps exports

133 expValOps = P.exportedValueOps exports

127 impValOps = concat (Map.elems (P.importedValueOps imports))

134 impValOps = concat (Map.elems (P.importedValueOps imports))

128

135

129− expTypes = map (first fst) (P.exportedTypes exports)

136+ expTypes = Map.map snd (P.exportedTypes exports)

130 impTypes = concat (Map.elems (P.importedTypes imports))

137 impTypes = concat (Map.elems (P.importedTypes imports))

131

138

132 expTypeOps = P.exportedTypeOps exports

139 expTypeOps = P.exportedTypeOps exports

133 impTypeOps = concat (Map.elems (P.importedTypeOps imports))

140 impTypeOps = concat (Map.elems (P.importedTypeOps imports))

134

141

135− expCtors = concatMap (snd . fst) (P.exportedTypes exports)

142+ expCtors = concatMap fst (Map.elems (P.exportedTypes exports))

136

143

137 expTCs = P.exportedTypeClasses exports

144 expTCs = P.exportedTypeClasses exports

138 impTCs = concat (Map.elems (P.importedTypeClasses imports))

145 impTCs = concat (Map.elems (P.importedTypeClasses imports))

src/Language/PureScript/Errors.hs−6

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

128 | DuplicateImportRef Name

129 | DuplicateExportRef Name

130 | IntOutOfRange Integer String Integer Integer

131− | RedundantEmptyHidingImport ModuleName

132 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

131 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

133 | ImplicitImport ModuleName [DeclarationRef]

132 | ImplicitImport ModuleName [DeclarationRef]

134 | HidingImport ModuleName [DeclarationRef]

133 | HidingImport ModuleName [DeclarationRef]

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

298 DuplicateImportRef{} -> "DuplicateImportRef"

297 DuplicateImportRef{} -> "DuplicateImportRef"

299 DuplicateExportRef{} -> "DuplicateExportRef"

298 DuplicateExportRef{} -> "DuplicateExportRef"

300 IntOutOfRange{} -> "IntOutOfRange"

299 IntOutOfRange{} -> "IntOutOfRange"

301− RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

302 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

300 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

303 ImplicitImport{} -> "ImplicitImport"

301 ImplicitImport{} -> "ImplicitImport"

304 HidingImport{} -> "HidingImport"

302 HidingImport{} -> "HidingImport"

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

422errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

420errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

423errorSuggestion err = case err of

421errorSuggestion err = case err of

424 UnusedImport{} -> emptySuggestion

422 UnusedImport{} -> emptySuggestion

425− RedundantEmptyHidingImport{} -> emptySuggestion

426 DuplicateImport{} -> emptySuggestion

423 DuplicateImport{} -> emptySuggestion

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

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

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

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

@@ -882,9 +879,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

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

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

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

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

884

881

885− renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

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

887−

888 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

882 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

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

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

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

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

src/Language/PureScript/Ide/Rebuild.hs+14−13

@@ -19,8 +19,6 @@ import Data.Maybe (fromJust, mapMaybe)

19import qualified Data.Set as S

20import qualified Language.PureScript as P

21import Language.PureScript.Errors.JSON

22−import System.FilePath (replaceExtension)

23−import System.Directory (doesFileExist)

24import System.IO.UTF8 (readUTF8File)

22import System.IO.UTF8 (readUTF8File)

25

23

26rebuildFile

24rebuildFile

@@ -37,23 +35,26 @@ rebuildFile path = do

37 Right [m] -> pure m

35 Right [m] -> pure m

38 Right _ -> throwError . GeneralError $ "Please define exactly one module."

36 Right _ -> throwError . GeneralError $ "Please define exactly one module."

39

37

38+ -- Externs files must be sorted ahead of time, so that they get applied

39+ -- correctly to the 'Environment'.

40 externs <- sortExterns m . M.delete (P.getModuleName m) =<< getExternFiles

41

42 outputDirectory <- confOutputPath . envConfiguration <$> ask

43

44− let foreignModule = replaceExtension path "js"

44+ -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign

45− foreignExists <- liftIO (doesFileExist foreignModule)

45+ -- modules using their file paths, we need to specify the path in the 'Map'.

46+ let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)

47+ foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path))

46

48

49+ -- Silence progress update messages during the build

47− let ma = P.buildMakeActions outputDirectory

50+ let actions = (P.buildMakeActions outputDirectory filePathMap foreigns False)

48− (M.singleton (P.getModuleName m) (Left P.RebuildAlways))

51+ { P.progress = const (pure ()) }

49− (if foreignExists

52+

50− then M.singleton (P.getModuleName m) foreignModule

53+ -- Rebuild the single module using the cached externs

51− else M.empty)

52− False

53 (result, warnings) <- liftIO

54 (result, warnings) <- liftIO

54− . P.runMake P.defaultOptions

55+ . P.runMake P.defaultOptions

55− . P.rebuildModule (ma { P.progress = const (pure ()) }) externs

56+ . P.rebuildModule actions externs

56− $ m

57+ $ m

57 case result of

58 case result of

58 Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors

59 Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors

59 Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings

60 Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings

src/Language/PureScript/Interactive.hs+24−29

@@ -53,40 +53,41 @@ runMake mk = fst <$> P.runMake P.defaultOptions mk

53

54-- | Rebuild a module, using the cached externs data for dependencies.

55rebuild

56− :: M.Map P.ModuleName FilePath

57− -> [P.ExternsFile]

56+ :: [P.ExternsFile]

58 -> P.Module

57 -> P.Module

59 -> P.Make (P.ExternsFile, P.Environment)

58 -> P.Make (P.ExternsFile, P.Environment)

60−rebuild foreignFiles loadedExterns m = do

59+rebuild loadedExterns m = do

61 externs <- P.rebuildModule buildActions loadedExterns m

60 externs <- P.rebuildModule buildActions loadedExterns m

62 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))

61 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))

63 where

62 where

64 buildActions :: P.MakeActions P.Make

63 buildActions :: P.MakeActions P.Make

64+ buildActions =

65− buildActions = (P.buildMakeActions modulesDir

65+ (P.buildMakeActions modulesDir

66− filePathMap

66+ filePathMap

67− foreignFiles

67+ M.empty

68− False) { P.progress = const (return ()) }

68+ False) { P.progress = const (return ()) }

69

70 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)

71 filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)

72

73-- | Build the collection of modules from scratch. This is usually done on startup.

74make

75− :: M.Map P.ModuleName FilePath

76− -> [P.Module]

75+ :: [(FilePath, P.Module)]

77 -> P.Make ([P.ExternsFile], P.Environment)

76 -> P.Make ([P.ExternsFile], P.Environment)

78−make foreignFiles ms = do

77+make ms = do

78+ foreignFiles <- P.inferForeignModules filePathMap

79− externs <- P.make buildActions ms

79+ externs <- P.make (buildActions foreignFiles) (map snd ms)

80 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)

81 where

82− buildActions :: P.MakeActions P.Make

82+ buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make

83+ buildActions foreignFiles =

83− buildActions = (P.buildMakeActions modulesDir

84+ P.buildMakeActions modulesDir

84− filePathMap

85+ filePathMap

85− foreignFiles

86+ foreignFiles

86− False)

87+ False

87

88

88 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)

89 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)

89− filePathMap = M.fromList $ map (\m -> (P.getModuleName m, Left P.RebuildAlways)) ms

90+ filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms

90

91

91-- | Performs a PSCi command

92-- | Performs a PSCi command

92handleCommand

93handleCommand

@@ -115,8 +116,7 @@ handleResetState = do

115 files <- asks psciLoadedFiles

116 files <- asks psciLoadedFiles

116 e <- runExceptT $ do

117 e <- runExceptT $ do

117 modules <- ExceptT . liftIO $ loadAllModules files

118 modules <- ExceptT . liftIO $ loadAllModules files

118− foreignFiles <- asks psciForeignFiles

119− (externs, _) <- ExceptT . liftIO . runMake . make foreignFiles . map snd $ modules

119+ (externs, _) <- ExceptT . liftIO . runMake . make $ modules

120 return (map snd modules, externs)

121 case e of

122 Left errs -> printErrors errs

@@ -132,9 +132,8 @@ handleExpression

132handleExpression val = do

133 st <- get

134 let m = createTemporaryModule True st val

135− foreignFiles <- asks psciForeignFiles

136 nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)

135 nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)

137− e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m

136+ e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

138 case e of

137 case e of

139 Left errs -> printErrors errs

138 Left errs -> printErrors errs

140 Right _ -> do

139 Right _ -> do

@@ -157,8 +156,7 @@ handleDecls

157handleDecls ds = do

156handleDecls ds = do

158 st <- gets (updateLets (++ ds))

157 st <- gets (updateLets (++ ds))

159 let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral []))

158 let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral []))

160− foreignFiles <- asks psciForeignFiles

161− e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m

159+ e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

162 case e of

160 case e of

163 Left err -> printErrors err

161 Left err -> printErrors err

164 Right _ -> put st

162 Right _ -> put st

@@ -212,9 +210,8 @@ handleImport

212 -> m ()

210 -> m ()

213handleImport im = do

211handleImport im = do

214 st <- gets (updateImportedModules (im :))

212 st <- gets (updateImportedModules (im :))

215− foreignFiles <- asks psciForeignFiles

216 let m = createTemporaryModuleForImports st

213 let m = createTemporaryModuleForImports st

217− e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m

214+ e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

218 case e of

215 case e of

219 Left errs -> printErrors errs

216 Left errs -> printErrors errs

220 Right _ -> put st

217 Right _ -> put st

@@ -226,9 +223,8 @@ handleTypeOf

226 -> m ()

223 -> m ()

227handleTypeOf val = do

224handleTypeOf val = do

228 st <- get

225 st <- get

229− foreignFiles <- asks psciForeignFiles

230 let m = createTemporaryModule False st val

226 let m = createTemporaryModule False st val

231− e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m

227+ e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

232 case e of

228 case e of

233 Left errs -> printErrors errs

229 Left errs -> printErrors errs

234 Right (_, env') ->

230 Right (_, env') ->

@@ -243,10 +239,9 @@ handleKindOf

243 -> m ()

239 -> m ()

244handleKindOf typ = do

240handleKindOf typ = do

245 st <- get

241 st <- get

246− foreignFiles <- asks psciForeignFiles

247 let m = createTemporaryModuleForKind st typ

242 let m = createTemporaryModuleForKind st typ

248 mName = P.ModuleName [P.ProperName "$PSCI"]

243 mName = P.ModuleName [P.ProperName "$PSCI"]

249− e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m

244+ e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

250 case e of

245 case e of

251 Left errs -> printErrors errs

246 Left errs -> printErrors errs

252 Right (_, env') ->

247 Right (_, env') ->

src/Language/PureScript/Interactive/Types.hs−2

@@ -5,7 +5,6 @@ module Language.PureScript.Interactive.Types where

5

6import Prelude.Compat

7

8−import Data.Map (Map)

9import qualified Language.PureScript as P

8import qualified Language.PureScript as P

10

9

11-- | The PSCI configuration.

10-- | The PSCI configuration.

@@ -14,7 +13,6 @@ import qualified Language.PureScript as P

14--

13--

15data PSCiConfig = PSCiConfig

14data PSCiConfig = PSCiConfig

16 { psciLoadedFiles :: [FilePath]

15 { psciLoadedFiles :: [FilePath]

17− , psciForeignFiles :: Map P.ModuleName FilePath

18 , psciNodeFlags :: [String]

16 , psciNodeFlags :: [String]

19 , psciEnvironment :: P.Environment

17 , psciEnvironment :: P.Environment

20 } deriving Show

18 } deriving Show

src/Language/PureScript/Linter/Exhaustive.hs+33−24

@@ -14,6 +14,7 @@ import Control.Applicative

14import Control.Arrow (first, second)

15import Control.Monad (unless)

16import Control.Monad.Writer.Class

17+import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)

17

18

18import Data.Function (on)

19import Data.Function (on)

19import Data.List (foldl', sortBy, nub)

20import Data.List (foldl', sortBy, nub)

@@ -45,7 +46,7 @@ data RedundancyError = Incomplete | Unknown

45-- Qualifies a propername from a given qualified propername and a default module name

46-- Qualifies a propername from a given qualified propername and a default module name

46--

47--

47qualifyName

48qualifyName

48− :: (ProperName a)

49+ :: ProperName a

49 -> ModuleName

50 -> ModuleName

50 -> Qualified (ProperName b)

51 -> Qualified (ProperName b)

51 -> Qualified (ProperName a)

52 -> Qualified (ProperName a)

@@ -231,7 +232,7 @@ missingAlternative env mn ca uncovered

231--

232--

232checkExhaustive

233checkExhaustive

233 :: forall m

234 :: forall m

234− . (MonadWriter MultipleErrors m)

235+ . (MonadWriter MultipleErrors m, MonadSupply m)

235 => Environment

236 => Environment

236 -> ModuleName

237 -> ModuleName

237 -> Int

238 -> Int

@@ -262,7 +263,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (

262 _ -> return ()

263 _ -> return ()

263 if null bss

264 if null bss

264 then return expr

265 then return expr

265− else return (addPartialConstraint (second null (splitAt 5 bss)) expr)

266+ else addPartialConstraint (second null (splitAt 5 bss)) expr

266 where

267 where

267 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

268 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

268 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

269 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

@@ -273,34 +274,42 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (

273 --

274 --

274 -- The binder information is provided so that it can be embedded in the constraint,

275 -- The binder information is provided so that it can be embedded in the constraint,

275 -- and then included in the error message.

276 -- and then included in the error message.

276− addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr

277+ addPartialConstraint :: MonadSupply m => ([[Binder]], Bool) -> Expr -> m Expr

277− addPartialConstraint (bss, complete) e =

278+ addPartialConstraint (bss, complete) e = do

279+ tyVar <- ("p" ++) . show <$> fresh

280+ var <- freshName

281+ return $

282+ Let

283+ [ partial var tyVar ]

278− Let [ partial ] (App (Var (Qualified Nothing (Ident C.__unused))) e)

284+ $ App (Var (Qualified Nothing (Ident C.__unused))) e

279 where

285 where

280− partial :: Declaration

286+ partial :: String -> String -> Declaration

287+ partial var tyVar =

281− partial = ValueDeclaration (Ident C.__unused)

288+ ValueDeclaration (Ident C.__unused) Private [] $ Right $

282− Private

283− []

284− (Right (TypedValue True (Abs (Left (Ident "x"))

289+ TypedValue

290+ True

285− (Var (Qualified Nothing (Ident "x"))))

291+ (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))

286− ty))

292+ (ty tyVar)

287−

293+

288− ty :: Type

294+ ty :: String -> Type

289− ty = ForAll "a" (ConstrainedType [ Constraint (Qualified (Just (ModuleName [ProperName C.prim]))

295+ ty tyVar =

290− (ProperName "Partial"))

296+ ForAll tyVar

291− []

297+ ( ConstrainedType

298+ [ Constraint C.Partial [] (Just constraintData) ]

299+ $ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar)

300+ )

301+ Nothing

302+

303+ constraintData :: ConstraintData

304+ constraintData =

292− (Just (PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete))

305+ PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete

293− ]

294− (TypeApp (TypeApp tyFunction (TypeVar "a"))

295− (TypeVar "a")))

296− Nothing

297

306

298-- |

307-- |

299-- Exhaustivity checking

308-- Exhaustivity checking

300--

309--

301checkExhaustiveExpr

310checkExhaustiveExpr

302 :: forall m

311 :: forall m

303− . MonadWriter MultipleErrors m

312+ . (MonadWriter MultipleErrors m, MonadSupply m)

304 => Environment

313 => Environment

305 -> ModuleName

314 -> ModuleName

306 -> Expr

315 -> Expr

src/Language/PureScript/Linter/Imports.hs+39−46

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

6

7import Prelude.Compat

8

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

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

10import Control.Monad.Writer.Class

11

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

59

60

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

@@ -158,17 +157,17 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

158 -- that are implicitly exported and then re-exported.

157 -- that are implicitly exported and then re-exported.

159 elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

158 elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

160 elaborateUsed scope mne used =

159 elaborateUsed scope mne used =

160+ foldr go used

161− let classes = extractByQual mne (importedTypeClasses scope) TyClassName

161+ $ extractByQual mne (importedTypeClasses scope) TyClassName

162− types = extractByQual mne (importedTypes scope) TyName

162+ ++ extractByQual mne (importedTypes scope) TyName

163− dctors = extractByQual mne (importedDataConstructors scope) DctorName

163+ ++ extractByQual mne (importedDataConstructors scope) DctorName

164− values = extractByQual mne (importedValues scope) IdentName

164+ ++ extractByQual mne (importedValues scope) IdentName

165− in foldr go used (classes ++ types ++ dctors ++ values)

166 where

165 where

167 go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports

166 go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports

168 go (q, name) = M.alter (Just . maybe [name] (name :)) q

167 go (q, name) = M.alter (Just . maybe [name] (name :)) q

169

168

170 extractByQual

169 extractByQual

171− :: (Eq a)

170+ :: Eq a

172 => ModuleName

171 => ModuleName

173 -> M.Map (Qualified a) [ImportRecord a]

172 -> M.Map (Qualified a) [ImportRecord a]

174 -> (a -> Name)

173 -> (a -> Name)

@@ -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

@@ -213,7 +215,15 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

213 checkImplicit warning =

215 checkImplicit warning =

214 if null allRefs

216 if null allRefs

215 then unused

217 then unused

216− else warn (warning mni allRefs)

218+ else warn (warning mni (map simplifyTypeRef allRefs))

219+ where

220+ -- Replace explicit type refs with data constructor lists from listing the

221+ -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion

222+ -- message.

223+ simplifyTypeRef :: DeclarationRef -> DeclarationRef

224+ simplifyTypeRef (TypeRef name (Just dctors))

225+ | not (null dctors) = TypeRef name Nothing

226+ simplifyTypeRef other = other

217

227

218 checkExplicit

228 checkExplicit

219 :: [DeclarationRef]

229 :: [DeclarationRef]

@@ -248,30 +258,35 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

248 warn :: SimpleErrorMessage -> m Bool

258 warn :: SimpleErrorMessage -> m Bool

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

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

250

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.

251 unless' :: Bool -> m Bool -> m Bool

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

252− unless' True m = m

268+ unless' False m = m

253− unless' False _ = return False

269+ unless' True _ = return False

254

270

255 allRefs :: [DeclarationRef]

271 allRefs :: [DeclarationRef]

256 allRefs = findUsedRefs env mni qualifierName names

272 allRefs = findUsedRefs env mni qualifierName names

257

273

258 dtys

274 dtys

259 :: ModuleName

275 :: ModuleName

260− -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

276+ -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

261− dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

277+ dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env

262

278

263 dctorsForType

279 dctorsForType

264 :: ModuleName

280 :: ModuleName

265 -> ProperName 'TypeName

281 -> ProperName 'TypeName

266 -> [ProperName 'ConstructorName]

282 -> [ProperName 'ConstructorName]

267− dctorsForType mn tn =

283+ dctorsForType mn tn = maybe [] fst $ tn `M.lookup` dtys mn

268− maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn)

269

284

270 typeForDCtor

285 typeForDCtor

271 :: ModuleName

286 :: ModuleName

272 -> ProperName 'ConstructorName

287 -> ProperName 'ConstructorName

273 -> Maybe (ProperName 'TypeName)

288 -> Maybe (ProperName 'TypeName)

274− typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn)

289+ typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn))

275

290

276findUsedRefs

291findUsedRefs

277 :: Env

292 :: Env

@@ -310,8 +325,8 @@ findUsedRefs env mni qn names =

310 findTypeForDctor mn dctor =

325 findTypeForDctor mn dctor =

311 case mn `M.lookup` env of

326 case mn `M.lookup` env of

312 Just (_, _, exps) ->

327 Just (_, _, exps) ->

313− case find (elem dctor . snd . fst) (exportedTypes exps) of

328+ case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of

314− Just ((ty, _), _) -> ty

329+ Just (ty, _) -> ty

315 Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

330 Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

316 Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

331 Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

317

332

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

345 tell $ errorMessage $ DuplicateImport mn t2 q2

360 tell $ errorMessage $ DuplicateImport mn t2 q2

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

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

347 else return xs

362 else return xs

348−

349−-- |

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

351−-- imports.

352−--

353−checkEmptyImport

354− :: MonadWriter MultipleErrors m

355− => ModuleName

356− -> Imports

357− -> ImportDeclarationType

358− -> m ()

359−checkEmptyImport importModule imps (Hiding _) = do

360− let isEmptyImport

361− = M.null (importedTypes imps)

362− && M.null (importedTypeOps imps)

363− && M.null (importedDataConstructors imps)

364− && M.null (importedTypeClasses imps)

365− && M.null (importedValues imps)

366− && M.null (importedValueOps imps)

367− when isEmptyImport . tell . errorMessage $

368− RedundantEmptyHidingImport importModule

369−checkEmptyImport _ _ _ = return ()

src/Language/PureScript/Make.hs+31−21

@@ -17,6 +17,7 @@ module Language.PureScript.Make

17 , makeIO

18 , readTextFile

19 , buildMakeActions

20+ , inferForeignModules

20 ) where

21 ) where

21

22

22import Prelude.Compat

23import Prelude.Compat

@@ -75,7 +76,7 @@ import SourceMap

75import SourceMap.Types

76import SourceMap.Types

76

77

77import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

78import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

78−import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)

79+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

79import System.IO.Error (tryIOError)

80import System.IO.Error (tryIOError)

80import System.IO.UTF8 (readUTF8File, writeUTF8File)

81import System.IO.UTF8 (readUTF8File, writeUTF8File)

81

82

@@ -98,31 +99,22 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn

98--

99--

99-- * The details of how files are read/written etc.

100-- * The details of how files are read/written etc.

100--

101--

101−data MakeActions m = MakeActions {

102+data MakeActions m = MakeActions

102− -- |

103+ { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

103− -- Get the timestamp for the input file(s) for a module. If there are multiple

104+ -- ^ Get the timestamp for the input file(s) for a module. If there are multiple

104− -- files (.purs and foreign files, for example) the timestamp should be for

105+ -- files (@.purs@ and foreign files, for example) the timestamp should be for

105 -- the most recently modified file.

106 -- the most recently modified file.

106− --

107− getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

108− -- |

109− -- Get the timestamp for the output files for a module. This should be the

110− -- timestamp for the oldest modified file, or Nothing if any of the required

111− -- output files are missing.

112− --

113 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)

107 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)

114− -- |

108+ -- ^ Get the timestamp for the output files for a module. This should be the

115− -- Read the externs file for a module as a string and also return the actual

109+ -- timestamp for the oldest modified file, or 'Nothing' if any of the required

116− -- path for the file.

110+ -- output files are missing.

117 , readExterns :: ModuleName -> m (FilePath, Externs)

111 , readExterns :: ModuleName -> m (FilePath, Externs)

118− -- |

112+ -- ^ Read the externs file for a module as a string and also return the actual

119− -- Run the code generator for the module and write any required output files.

113+ -- path for the file.

120− --

121 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()

114 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()

122− -- |

115+ -- ^ Run the code generator for the module and write any required output files.

123− -- Respond to a progress update.

124− --

125 , progress :: ProgressMessage -> m ()

116 , progress :: ProgressMessage -> m ()

117+ -- ^ Respond to a progress update.

126 }

118 }

127

119

128-- |

120-- |

@@ -297,6 +289,24 @@ makeIO f io = do

297readTextFile :: FilePath -> Make String

289readTextFile :: FilePath -> Make String

298readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

290readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

299

291

292+-- | Infer the module name for a module by looking for the same filename with

293+-- a .js extension.

294+inferForeignModules

295+ :: forall m

296+ . MonadIO m

297+ => M.Map ModuleName (Either RebuildPolicy FilePath)

298+ -> m (M.Map ModuleName FilePath)

299+inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule

300+ where

301+ inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)

302+ inferForeignModule (Left _) = return Nothing

303+ inferForeignModule (Right path) = do

304+ let jsFile = replaceExtension path "js"

305+ exists <- liftIO $ doesFileExist jsFile

306+ if exists

307+ then return (Just jsFile)

308+ else return Nothing

309+

300-- |

310-- |

301-- A set of make actions that read and write modules from the given directory.

311-- A set of make actions that read and write modules from the given directory.

302--

312--

src/Language/PureScript/Parser.hs−1

@@ -17,7 +17,6 @@ module Language.PureScript.Parser (module P) where

17

18import Language.PureScript.Parser.Common as P

19import Language.PureScript.Parser.Declarations as P

20−import Language.PureScript.Parser.JS as P

21import Language.PureScript.Parser.Kinds as P

20import Language.PureScript.Parser.Kinds as P

22import Language.PureScript.Parser.Lexer as P

21import Language.PureScript.Parser.Lexer as P

23import Language.PureScript.Parser.State as P

22import Language.PureScript.Parser.State as P

src/Language/PureScript/Parser/JS.hsdeleted−46

@@ -1,46 +0,0 @@

1−module Language.PureScript.Parser.JS

2− ( ForeignJS()

3− , parseForeignModulesFromFiles

4− ) where

5−

6−import Prelude.Compat hiding (lex)

7−

8−import Control.Monad (forM_, when, msum)

9−import Control.Monad.Error.Class (MonadError(..))

10−import Control.Monad.Writer.Class (MonadWriter(..))

11−

12−import Data.Function (on)

13−import Data.List (sortBy, groupBy)

14−import qualified Data.Map as M

15−

16−import Language.PureScript.Errors

17−import Language.PureScript.Names

18−import Language.PureScript.Parser.Common

19−import Language.PureScript.Parser.Lexer

20−

21−import qualified Text.Parsec as PS

22−

23−type ForeignJS = String

24−

25−parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

26− => [(FilePath, ForeignJS)]

27− -> m (M.Map ModuleName FilePath)

28−parseForeignModulesFromFiles files = do

29− foreigns <- parU files $ \(path, file) ->

30− case findModuleName (lines file) of

31− Just name -> return (name, path)

32− Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing)

33− let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns

34− forM_ grouped $ \grp ->

35− when (length grp > 1) $ do

36− let mn = fst (head grp)

37− paths = map snd grp

38− tell $ errorMessage $ MultipleFFIModules mn paths

39− return $ M.fromList foreigns

40−

41−findModuleName :: [String] -> Maybe ModuleName

42−findModuleName = msum . map parseComment

43− where

44− parseComment :: String -> Maybe ModuleName

45− parseComment s = either (const Nothing) Just $

46− lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof)

src/Language/PureScript/Sugar/Names.hs+28−22

@@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names

10

11import Prelude.Compat

12

13−import Control.Arrow (first)

13+import Control.Arrow (first, second)

14import Control.Monad

15import Control.Monad.Error.Class (MonadError(..))

16import Control.Monad.State.Lazy

@@ -72,10 +72,10 @@ desugarImportsWithEnv externs modules = do

72 return $ M.insert efModuleName (ss, imps, exps) env

73 where

74

75− exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

75+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

76− exportedTypes = mapMaybe toExportedType efExports

76+ exportedTypes = M.fromList $ mapMaybe toExportedType efExports

77 where

78− toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

78+ toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName))

79 where

80 forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

81 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

@@ -83,17 +83,17 @@ desugarImportsWithEnv externs modules = do

83 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

84 toExportedType _ = Nothing

85

86− exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

86+ exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName

87− exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports

87+ exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports

88

89− exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

89+ exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName

90− exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports

90+ exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports

91

92− exportedValues :: [(Ident, ModuleName)]

92+ exportedValues :: M.Map Ident ModuleName

93− exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports

93+ exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports

94

95− exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

95+ exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

96− exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports

96+ exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports

97

98 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

99 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

@@ -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-- |

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

122elaborateExports :: Exports -> Module -> Module

123elaborateExports exps (Module ss coms mn decls refs) =

124 Module ss coms mn decls $

125− Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++

125+ Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++

126 map TypeOpRef (my exportedTypeOps) ++

127 map TypeClassRef (my exportedTypeClasses) ++

128 map ValueRef (my exportedValues) ++

@@ -131,8 +131,14 @@ elaborateExports exps (Module ss coms mn decls refs) =

131 where

132 -- Extracts a list of values from the exports and filters out any values that

133 -- are re-exports from other modules.

134− my :: (Exports -> [(a, ModuleName)]) -> [a]

134+ my :: (Exports -> M.Map a ModuleName) -> [a]

135− my f = fst `map` filter ((== mn) . snd) (f exps)

135+ my = map fst <$> filt (== mn)

136+

137+ myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])]

138+ myTypes = second fst <$> filt ((== mn) . snd) exportedTypes

139+

140+ filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)]

141+ filt predicate f = M.toList $ predicate `M.filter` f exps

136

142

137-- |

143-- |

138-- Replaces all local names with qualified names within a module and checks that all existing

144-- Replaces all local names with qualified names within a module and checks that all existing

@@ -294,26 +300,26 @@ renameInModule env imports (Module ss coms mn decls exps) =

294

300

295 -- Used when performing an update to qualify values and classes with their

301 -- Used when performing an update to qualify values and classes with their

296 -- module of original definition.

302 -- module of original definition.

297− resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)

303+ resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a)

298− resolve as name = mkQualified name <$> name `lookup` as

304+ resolve as name = mkQualified name <$> name `M.lookup` as

299

305

300 -- Used when performing an update to qualify types with their module of

306 -- Used when performing an update to qualify types with their module of

301 -- original definition.

307 -- original definition.

302 resolveType

308 resolveType

303− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

309+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

304 -> ProperName 'TypeName

310 -> ProperName 'TypeName

305 -> Maybe (Qualified (ProperName 'TypeName))

311 -> Maybe (Qualified (ProperName 'TypeName))

306 resolveType tys name =

312 resolveType tys name =

307− mkQualified name . snd <$> find ((== name) . fst . fst) tys

313+ mkQualified name . snd <$> M.lookup name tys

308

314

309 -- Used when performing an update to qualify data constructors with their

315 -- Used when performing an update to qualify data constructors with their

310 -- module of original definition.

316 -- module of original definition.

311 resolveDctor

317 resolveDctor

312− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

318+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

313 -> ProperName 'ConstructorName

319 -> ProperName 'ConstructorName

314 -> Maybe (Qualified (ProperName 'ConstructorName))

320 -> Maybe (Qualified (ProperName 'ConstructorName))

315 resolveDctor tys name =

321 resolveDctor tys name =

316− mkQualified name . snd <$> find (elem name . snd . fst) tys

322+ mkQualified name . snd <$> find (elem name . fst) tys

317

323

318 -- Update names so unqualified references become qualified, and locally

324 -- Update names so unqualified references become qualified, and locally

319 -- qualified references are replaced with their canoncial qualified names

325 -- qualified references are replaced with their canoncial qualified names

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

48

50

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

56

58

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

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

src/Language/PureScript/Sugar/Names/Env.hs+41−39

@@ -26,7 +26,7 @@ import Control.Monad.Error.Class (MonadError(..))

26import Control.Monad.Writer.Class (MonadWriter(..))

27

28import Data.Function (on)

29−import Data.List (groupBy, sortBy, nub, delete)

29+import Data.List (groupBy, sortBy, delete)

30import Data.Maybe (fromJust, mapMaybe)

31import qualified Data.Map as M

32import qualified Data.Set as S

@@ -92,7 +92,9 @@ data Imports = Imports

92 --

93 , importedValueOps :: ImportMap (OpName 'ValueOpName)

94 -- |

95− -- The modules that have been imported into the current scope.

95+ -- The name of modules that have been imported into the current scope that

96+ -- can be re-exported. If a module is imported with `as` qualification, the

97+ -- `as` name appears here, otherwise the original name.

96 --

98 --

97 , importedModules :: S.Set ModuleName

99 , importedModules :: S.Set ModuleName

98 -- |

100 -- |

@@ -114,37 +116,34 @@ nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.

114data Exports = Exports

116data Exports = Exports

115 {

117 {

116 -- |

118 -- |

117− -- The types exported from each module along with the module they originally

119+ -- The exported types along with the module they originally came from.

118− -- came from.

119 --

120 --

120− exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

121+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

121 -- |

122 -- |

122− -- The type operators exported from each module along with the module they

123+ -- The exported type operators along with the module they originally came

123− -- originally came from.

124+ -- from.

124 --

125 --

125− , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

126+ , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName

126 -- |

127 -- |

127− -- The classes exported from each module along with the module they originally

128+ -- The exported classes along with the module they originally came from.

128− -- came from.

129 --

130− , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

130+ , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName

131 -- |

132− -- The values exported from each module along with the module they originally

132+ -- The exported values along with the module they originally came from.

133− -- came from.

134 --

133 --

135− , exportedValues :: [(Ident, ModuleName)]

134+ , exportedValues :: M.Map Ident ModuleName

136 -- |

135 -- |

137− -- The value operators exported from each module along with the module they

136+ -- The exported value operators along with the module they originally came

138− -- originally came from.

137+ -- from.

139 --

138 --

140− , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

139+ , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

141 } deriving (Show, Read)

140 } deriving (Show, Read)

142

141

143-- |

142-- |

144-- An empty 'Exports' value.

143-- An empty 'Exports' value.

145--

144--

146nullExports :: Exports

145nullExports :: Exports

147−nullExports = Exports [] [] [] [] []

146+nullExports = Exports M.empty M.empty M.empty M.empty M.empty

148

147

149-- |

148-- |

150-- The imports and exports for a collection of modules. The 'SourceSpan' is used

149-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -177,11 +176,11 @@ envModuleExports (_, _, exps) = exps

177primExports :: Exports

176primExports :: Exports

178primExports =

177primExports =

179 nullExports

178 nullExports

180− { exportedTypes = mkTypeEntry `map` M.keys primTypes

179+ { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes

181− , exportedTypeClasses = mkClassEntry `map` M.keys primClasses

180+ , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses

182 }

181 }

183 where

182 where

184− mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

183+ mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))

185 mkClassEntry (Qualified mn name) = (name, fromJust mn)

184 mkClassEntry (Qualified mn name) = (name, fromJust mn)

186

185

187-- | Environment which only contains the Prim module.

186-- | Environment which only contains the Prim module.

@@ -202,20 +201,21 @@ exportType

202 -> ModuleName

201 -> ModuleName

203 -> m Exports

202 -> m Exports

204exportType exps name dctors mn = do

203exportType exps name dctors mn = do

205− let exTypes' = exportedTypes exps

204+ let exTypes = exportedTypes exps

206− let exTypes = filter ((/= mn) . snd) exTypes'

207− let exDctors = (snd . fst) `concatMap` exTypes

208 let exClasses = exportedTypeClasses exps

205 let exClasses = exportedTypeClasses exps

209− when (any ((== name) . fst . fst) exTypes) $

206+ case name `M.lookup` exTypes of

210− throwConflictError ConflictingTypeDecls name

207+ Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name

208+ _ -> return ()

211− when (any ((== coerceProperName name) . fst) exClasses) $

209+ when (coerceProperName name `M.member` exClasses) $

212 throwConflictError TypeConflictsWithClass name

210 throwConflictError TypeConflictsWithClass name

213 forM_ dctors $ \dctor -> do

211 forM_ dctors $ \dctor -> do

214− when (dctor `elem` exDctors) $

212+ when (dctorExists (coerceProperName dctor) `any` exTypes) $

215 throwConflictError ConflictingCtorDecls dctor

213 throwConflictError ConflictingCtorDecls dctor

216− when (any ((== coerceProperName dctor) . fst) exClasses) $

214+ when (coerceProperName dctor `M.member` exClasses) $

217 throwConflictError CtorConflictsWithClass dctor

215 throwConflictError CtorConflictsWithClass dctor

218− return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

216+ return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes }

217+ where

218+ dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors'

219

220-- |

221-- Safely adds a type operator to some exports, returning an error if a

@@ -242,10 +242,9 @@ exportTypeClass

242 -> m Exports

243exportTypeClass exps name mn = do

244 let exTypes = exportedTypes exps

245− let exDctors = (snd . fst) `concatMap` exTypes

246− when (any ((== coerceProperName name) . fst . fst) exTypes) $

245+ when (coerceProperName name `M.member` exTypes) $

247 throwConflictError ClassConflictsWithType name

246 throwConflictError ClassConflictsWithType name

248− when (coerceProperName name `elem` exDctors) $

247+ when ((elem (coerceProperName name) . fst) `any` exTypes) $

249 throwConflictError ClassConflictsWithCtor name

248 throwConflictError ClassConflictsWithCtor name

250 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

249 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

251 return $ exps { exportedTypeClasses = classes }

250 return $ exps { exportedTypeClasses = classes }

@@ -282,16 +281,19 @@ exportValueOp exps op mn = do

282-- case an error is returned.

281-- case an error is returned.

283--

282--

284addExport

283addExport

285− :: (MonadError MultipleErrors m, Eq a)

284+ :: (MonadError MultipleErrors m, Ord a)

286 => (a -> SimpleErrorMessage)

285 => (a -> SimpleErrorMessage)

287 -> a

286 -> a

288 -> ModuleName

287 -> ModuleName

289− -> [(a, ModuleName)]

288+ -> M.Map a ModuleName

290− -> m [(a, ModuleName)]

289+ -> m (M.Map a ModuleName)

291addExport what name mn exports =

290addExport what name mn exports =

292− if any (\(name', mn') -> name == name' && mn /= mn') exports

291+ case M.lookup name exports of

292+ Just mn'

293+ | mn == mn' -> return exports

293− then throwConflictError what name

294+ | otherwise -> throwConflictError what name

295+ Nothing ->

294− else return $ nub $ (name, mn) : exports

296+ return $ M.insert name mn exports

295

297

296-- |

298-- |

297-- Raises an error for when there is more than one definition for something.

299-- Raises an error for when there is more than one definition for something.

src/Language/PureScript/Sugar/Names/Exports.hs+36−32

@@ -10,7 +10,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))

10import Control.Monad.Error.Class (MonadError(..))

11

12import Data.Foldable (traverse_)

13−import Data.List (find, intersect)

13+import Data.List (intersect)

14import Data.Maybe (fromMaybe, mapMaybe)

15import qualified Data.Map as M

16

@@ -76,11 +76,11 @@ resolveExports env ss mn imps exps refs =

76 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

77 warnAndRethrowWithPosition pos $ elaborateModuleExports result r

78 elaborateModuleExports result (ModuleRef name) | name == mn = do

79− let types' = exportedTypes result ++ exportedTypes exps

79+ let types' = exportedTypes result `M.union` exportedTypes exps

80− let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

80+ let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps

81− let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

81+ let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps

82− let values' = exportedValues result ++ exportedValues exps

82+ let values' = exportedValues result `M.union` exportedValues exps

83− let valueOps' = exportedValueOps result ++ exportedValueOps exps

83+ let valueOps' = exportedValueOps result `M.union` exportedValueOps exps

84 return result

85 { exportedTypes = types'

86 , exportedTypeOps = typeOps'

@@ -155,11 +155,12 @@ resolveExports env ss mn imps exps refs =

155 go

156 :: Qualified (ProperName 'TypeName)

157 -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)

158+ go (Qualified (Just mn'') name) =

158− go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159+ fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159− exps' <- envModuleExports <$> mn'' `M.lookup` env

160+ exps' <- envModuleExports <$> mn'' `M.lookup` env

160− ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

161+ (dctors', mnOrig) <- name `M.lookup` exportedTypes exps'

161− let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors

162+ let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors

162− return ((name, relevantDctors `intersect` dctors'), mnOrig)

163+ return ((name, relevantDctors `intersect` dctors'), mnOrig)

163 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

164 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

164

165

165 -- Looks up an imported type operator and re-qualifies it with the original

166 -- Looks up an imported type operator and re-qualifies it with the original

@@ -194,10 +195,14 @@ resolveExports env ss mn imps exps refs =

194 . fromMaybe (internalError "Missing value in resolveValueOp")

195 . fromMaybe (internalError "Missing value in resolveValueOp")

195 $ resolve exportedValueOps op

196 $ resolve exportedValueOps op

196

197

198+ resolve

199+ :: Ord a

197− resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

200+ => (Exports -> M.Map a ModuleName)

201+ -> Qualified a

202+ -> Maybe (Qualified a)

198 resolve f (Qualified (Just mn'') a) = do

203 resolve f (Qualified (Just mn'') a) = do

199 exps' <- envModuleExports <$> mn'' `M.lookup` env

204 exps' <- envModuleExports <$> mn'' `M.lookup` env

200− mn''' <- snd <$> find ((== a) . fst) (f exps')

205+ mn''' <- a `M.lookup` f exps'

201 return $ Qualified (Just mn''') a

206 return $ Qualified (Just mn''') a

202 resolve _ _ = internalError "Unqualified value in resolve"

207 resolve _ _ = internalError "Unqualified value in resolve"

203

208

@@ -219,11 +224,11 @@ filterModule

219 -> [DeclarationRef]

224 -> [DeclarationRef]

220 -> m Exports

225 -> m Exports

221filterModule mn exps refs = do

226filterModule mn exps refs = do

222− types <- foldM filterTypes [] refs

227+ types <- foldM filterTypes M.empty refs

223− typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs

228+ typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs

224− classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) [] refs

229+ classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs

225− values <- foldM (filterExport IdentName getValueRef exportedValues) [] refs

230+ values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs

226− valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) [] refs

231+ valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs

227 return Exports

232 return Exports

228 { exportedTypes = types

233 { exportedTypes = types

229 , exportedTypeOps = typeOps

234 , exportedTypeOps = typeOps

@@ -235,21 +240,19 @@ filterModule mn exps refs = do

235 where

240 where

236

241

237 filterTypes

242 filterTypes

238− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

243+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

239 -> DeclarationRef

244 -> DeclarationRef

240− -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

245+ -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName))

241 filterTypes result (PositionedDeclarationRef pos _ r) =

246 filterTypes result (PositionedDeclarationRef pos _ r) =

242 rethrowWithPosition pos $ filterTypes result r

247 rethrowWithPosition pos $ filterTypes result r

243 filterTypes result (TypeRef name expDcons) =

248 filterTypes result (TypeRef name expDcons) =

244− case matchType `find` exportedTypes exps of

249+ case name `M.lookup` exportedTypes exps of

245 Nothing -> throwError . errorMessage . UnknownExport $ TyName name

250 Nothing -> throwError . errorMessage . UnknownExport $ TyName name

246− Just ((_, dcons), _) -> do

251+ Just (dcons, _) -> do

247 let expDcons' = fromMaybe dcons expDcons

252 let expDcons' = fromMaybe dcons expDcons

248 traverse_ (checkDcon name dcons) expDcons'

253 traverse_ (checkDcon name dcons) expDcons'

249− return $ ((name, expDcons'), mn) : result

254+ return $ M.insert name (expDcons', mn) result

250 where

255 where

251− -- Finds a type declaration by matching its name and defining module

252− matchType ((name', _), mn') = name == name' && mn == mn'

253 -- Ensures a data constructor is exportable for a given type. Takes a type

256 -- Ensures a data constructor is exportable for a given type. Takes a type

254 -- name, a list of exportable data constructors for the type, and the name of

257 -- name, a list of exportable data constructors for the type, and the name of

255 -- the data constructor to check.

258 -- the data constructor to check.

@@ -264,18 +267,19 @@ filterModule mn exps refs = do

264 filterTypes result _ = return result

267 filterTypes result _ = return result

265

268

266 filterExport

269 filterExport

267− :: Eq a

270+ :: Ord a

268 => (a -> Name)

271 => (a -> Name)

269 -> (DeclarationRef -> Maybe a)

272 -> (DeclarationRef -> Maybe a)

270− -> (Exports -> [(a, ModuleName)])

273+ -> (Exports -> M.Map a ModuleName)

271− -> [(a, ModuleName)]

274+ -> M.Map a ModuleName

272 -> DeclarationRef

275 -> DeclarationRef

273− -> m [(a, ModuleName)]

276+ -> m (M.Map a ModuleName)

274 filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

277 filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

275 rethrowWithPosition pos $ filterExport toName get fromExps result r

278 rethrowWithPosition pos $ filterExport toName get fromExps result r

276 filterExport toName get fromExps result ref

279 filterExport toName get fromExps result ref

277 | Just name <- get ref =

280 | Just name <- get ref =

278− if (name, mn) `elem` fromExps exps

281+ case name `M.lookup` fromExps exps of

279− then return $ (name, mn) : result

282+ -- TODO: I'm not sure if we actually need to check mn == mn' here -gb

283+ Just mn' | mn == mn' -> return $ M.insert name mn result

280− else throwError . errorMessage . UnknownExport $ toName name

284+ _ -> throwError . errorMessage . UnknownExport $ toName name

281 filterExport _ _ _ result _ = return result

285 filterExport _ _ _ result _ = return result

src/Language/PureScript/Sugar/Names/Imports.hs+31−34

@@ -7,12 +7,10 @@ module Language.PureScript.Sugar.Names.Imports

7

8import Prelude.Compat

9

10−import Control.Arrow (first)

11import Control.Monad

10import Control.Monad

12import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Error.Class (MonadError(..))

13

12

14import Data.Foldable (for_, traverse_)

13import Data.Foldable (for_, traverse_)

15−import Data.List (find)

16import Data.Maybe (fromMaybe)

14import Data.Maybe (fromMaybe)

17import qualified Data.Map as M

15import qualified Data.Map as M

18import qualified Data.Set as S

16import qualified Data.Set as S

@@ -118,30 +116,30 @@ resolveImport importModule exps imps impQual = resolveByType

118 check (PositionedDeclarationRef pos _ r) =

116 check (PositionedDeclarationRef pos _ r) =

119 rethrowWithPosition pos $ check r

117 rethrowWithPosition pos $ check r

120 check (ValueRef name) =

118 check (ValueRef name) =

121− checkImportExists IdentName (fst `map` exportedValues exps) name

119+ checkImportExists IdentName (exportedValues exps) name

122 check (ValueOpRef op) =

120 check (ValueOpRef op) =

123− checkImportExists ValOpName (fst `map` exportedValueOps exps) op

121+ checkImportExists ValOpName (exportedValueOps exps) op

124 check (TypeRef name dctors) = do

122 check (TypeRef name dctors) = do

125− checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name

123+ checkImportExists TyName (exportedTypes exps) name

126− let allDctors = fst `map` allExportedDataConstructors name

124+ let (allDctors, _) = allExportedDataConstructors name

127 for_ dctors $ traverse_ (checkDctorExists name allDctors)

125 for_ dctors $ traverse_ (checkDctorExists name allDctors)

128 check (TypeOpRef name) =

126 check (TypeOpRef name) =

129− checkImportExists TyOpName (fst `map` exportedTypeOps exps) name

127+ checkImportExists TyOpName (exportedTypeOps exps) name

130 check (TypeClassRef name) =

128 check (TypeClassRef name) =

131− checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name

129+ checkImportExists TyClassName (exportedTypeClasses exps) name

132 check (ModuleRef name) | isHiding =

130 check (ModuleRef name) | isHiding =

133 throwError . errorMessage $ ImportHidingModule name

131 throwError . errorMessage $ ImportHidingModule name

134 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

132 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

135

133

136 -- Check that an explicitly imported item exists in the module it is being imported from

134 -- Check that an explicitly imported item exists in the module it is being imported from

137 checkImportExists

135 checkImportExists

138− :: Eq a

136+ :: Ord a

139 => (a -> Name)

137 => (a -> Name)

140− -> [a]

138+ -> M.Map a b

141 -> a

139 -> a

142 -> m ()

140 -> m ()

143 checkImportExists toName exports item

141 checkImportExists toName exports item

144− = when (item `notElem` exports)

142+ = when (item `M.notMember` exports)

145 . throwError . errorMessage

143 . throwError . errorMessage

146 $ UnknownImport importModule (toName item)

144 $ UnknownImport importModule (toName item)

147

145

@@ -177,35 +175,34 @@ resolveImport importModule exps imps impQual = resolveByType

177 -- Import all symbols

175 -- Import all symbols

178 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

176 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

179 importAll importer =

177 importAll importer =

180− foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

178+ foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps))

181− >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps)

179+ >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps))

182− >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps)

180+ >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps))

183− >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps)

181+ >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps))

184− >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps)

182+ >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps))

185

183

186 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

184 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

187 importRef prov imp (PositionedDeclarationRef pos _ r) =

185 importRef prov imp (PositionedDeclarationRef pos _ r) =

188 rethrowWithPosition pos $ importRef prov imp r

186 rethrowWithPosition pos $ importRef prov imp r

189 importRef prov imp (ValueRef name) = do

187 importRef prov imp (ValueRef name) = do

190− let values' = updateImports (importedValues imp) (exportedValues exps) name prov

188+ let values' = updateImports (importedValues imp) (exportedValues exps) id name prov

191 return $ imp { importedValues = values' }

189 return $ imp { importedValues = values' }

192 importRef prov imp (ValueOpRef name) = do

190 importRef prov imp (ValueOpRef name) = do

193− let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) name prov

191+ let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov

194 return $ imp { importedValueOps = valueOps' }

192 return $ imp { importedValueOps = valueOps' }

195 importRef prov imp (TypeRef name dctors) = do

193 importRef prov imp (TypeRef name dctors) = do

196− let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov

194+ let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov

195+ let (dctorNames, mn) = allExportedDataConstructors name

197− let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

196+ dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName

198− exportedDctors = allExportedDataConstructors name

197+ dctorLookup = M.fromList $ map (, mn) dctorNames

199− dctorNames :: [ProperName 'ConstructorName]

200− dctorNames = fst `map` exportedDctors

201− maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

198+ traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors

202− let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

199+ let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

203 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

200 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

204 importRef prov imp (TypeOpRef name) = do

201 importRef prov imp (TypeOpRef name) = do

205− let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov

202+ let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov

206 return $ imp { importedTypeOps = ops' }

203 return $ imp { importedTypeOps = ops' }

207 importRef prov imp (TypeClassRef name) = do

204 importRef prov imp (TypeClassRef name) = do

208− let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

205+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov

209 return $ imp { importedTypeClasses = typeClasses' }

206 return $ imp { importedTypeClasses = typeClasses' }

210 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

207 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

211 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

208 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

@@ -213,23 +210,23 @@ resolveImport importModule exps imps impQual = resolveByType

213 -- Find all exported data constructors for a given type

210 -- Find all exported data constructors for a given type

214 allExportedDataConstructors

211 allExportedDataConstructors

215 :: ProperName 'TypeName

212 :: ProperName 'TypeName

216− -> [(ProperName 'ConstructorName, ModuleName)]

213+ -> ([ProperName 'ConstructorName], ModuleName)

217 allExportedDataConstructors name =

214 allExportedDataConstructors name =

218− case find ((== name) . fst . fst) (exportedTypes exps) of

219− Nothing -> internalError "Invalid state in allExportedDataConstructors"

215+ fromMaybe (internalError "Invalid state in allExportedDataConstructors")

220− Just ((_, dctors), mn) -> map (, mn) dctors

216+ $ name `M.lookup` exportedTypes exps

221

217

222 -- Add something to an import resolution list

218 -- Add something to an import resolution list

223 updateImports

219 updateImports

224 :: (Ord a)

220 :: (Ord a)

225 => M.Map (Qualified a) [ImportRecord a]

221 => M.Map (Qualified a) [ImportRecord a]

222+ -> M.Map a b

226− -> [(a, ModuleName)]

223+ -> (b -> ModuleName)

227 -> a

224 -> a

228 -> ImportProvenance

225 -> ImportProvenance

229 -> M.Map (Qualified a) [ImportRecord a]

226 -> M.Map (Qualified a) [ImportRecord a]

230− updateImports imps' exps' name prov =

227+ updateImports imps' exps' expName name prov =

231 let

228 let

232− mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

229+ mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps')

233 rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov

230 rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov

234 in

231 in

235 M.alter

232 M.alter

tests/Language/PureScript/Ide/Integration.hs−1

@@ -131,7 +131,6 @@ isSuccess (ExitFailure _) = False

131fileGlob :: String

132fileGlob = unwords

133 [ "\"src/**/*.purs\""

134− , "\"src/**/*.js\""

135 ]

134 ]

136

135

137-- Integration Testing API

136-- Integration Testing API

tests/TestCompiler.hs+90−57

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

27

28import Data.Char (isSpace)

29import Data.Function (on)

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

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

31import Data.Maybe (mapMaybe)

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

33+import Data.Tuple (swap)

33

34

34import qualified Data.Map as M

35import qualified Data.Map as M

35

36

36import Control.Monad

37import Control.Monad

37−import Control.Arrow ((>>>))

38+import Control.Arrow ((***), (>>>))

38

39

39import Control.Monad.Reader

40import Control.Monad.Reader

40import Control.Monad.Writer.Strict

41import Control.Monad.Writer.Strict

@@ -57,59 +58,58 @@ main = hspec spec

57spec :: Spec

58spec :: Spec

58spec = do

59spec = do

59

60

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

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

61 cwd <- getCurrentDirectory

62 cwd <- getCurrentDirectory

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

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

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

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

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

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

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

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

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

66 passingFiles <- getTestFiles passing <$> testGlob passing

68 passingFiles <- getTestFiles passing <$> testGlob passing

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

67 failingFiles <- getTestFiles failing <$> testGlob failing

70 failingFiles <- getTestFiles failing <$> testGlob failing

68 supportPurs <- supportFiles "purs"

71 supportPurs <- supportFiles "purs"

69− supportForeigns <- loadForeigns =<< supportFiles "js"

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

75+ foreigns <- inferForeignModules modules

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

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

74 return (zip (map snd modules) externs)

77 return (zip (map snd modules) externs)

75 case supportExterns of

78 case supportExterns of

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

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

77− Right externs -> return (externs, supportForeigns, passingFiles, failingFiles)

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

78

81

79− context ("Passing examples") $ do

82+ context "Passing examples" $

80− forM_ passingTestCases $ \(testPurs, testJS) ->

83+ forM_ passingTestCases $ \testPurs ->

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

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

82− testForeigns <- loadForeigns testJS

83− assertCompiles supportExterns testPurs (supportForeigns <> testForeigns)

85+ assertCompiles supportExterns testPurs

84

86

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, testJS) -> 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

89− it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do

98+ it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $

90− testForeigns <- loadForeigns testJS

91− assertDoesNotCompile supportExterns testPurs (supportForeigns <> testForeigns) expectedFailures

99+ assertDoesNotCompile supportExterns testPurs expectedFailures

92

100

93 where

101 where

94

102

95 -- A glob for all purs and js files within a test directory

103 -- A glob for all purs and js files within a test directory

96 testGlob :: FilePath -> IO [FilePath]

104 testGlob :: FilePath -> IO [FilePath]

97− testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir

105+ testGlob = Glob.globDir1 (Glob.compile "**/*.purs")

98−

99− -- Loads foreign modules from source files

100− loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath)

101− loadForeigns paths = do

102− files <- forM paths (\f -> (f,) <$> readUTF8File f)

103− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files

104− return foreigns

105

106

106 -- Groups the test files so that a top-level file can have dependencies in a

107 -- Groups the test files so that a top-level file can have dependencies in a

107 -- subdirectory of the same name. The inner tuple contains a list of the

108 -- subdirectory of the same name. The inner tuple contains a list of the

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

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

109− getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])]

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

110 getTestFiles baseDir

111 getTestFiles baseDir

111− = map (partition ((== ".purs") . takeExtensions))

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

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

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

114 . sortBy (compare `on` extractPrefix)

115 . map (makeRelative baseDir)

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

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

119 -- will be under a subdirectory.

120 getTestMain :: [FilePath] -> FilePath

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

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

122

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

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

@@ -133,9 +133,26 @@ spec = do

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

134 -- determine expected failures

135 getShouldFailWith :: FilePath -> IO [String]

136− 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

137 where

145 where

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

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

147+

148+inferForeignModules

149+ :: MonadIO m

150+ => [(FilePath, P.Module)]

151+ -> m (M.Map P.ModuleName FilePath)

152+inferForeignModules = P.inferForeignModules . fromList

153+ where

154+ fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)

155+ fromList = M.fromList . map ((P.getModuleName *** Right) . swap)

139

156

140trim :: String -> String

157trim :: String -> String

141trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

158trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

@@ -167,20 +184,18 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

167 text <- readUTF8File inputFile

184 text <- readUTF8File inputFile

168 return (inputFile, text)

185 return (inputFile, text)

169

186

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

171−

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

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

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

188+runTest = P.runMake P.defaultOptions

174

189

175compile

190compile

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

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

177 -> [FilePath]

192 -> [FilePath]

178− -> M.Map P.ModuleName 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)

181−compile supportExterns inputFiles foreigns check = silence $ runTest $ do

195+compile 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

198+ foreigns <- inferForeignModules ms

184 liftIO (check (map snd ms))

199 liftIO (check (map snd ms))

185 let actions = makeActions foreigns

200 let actions = makeActions foreigns

186 case ms of

201 case ms of

@@ -190,22 +205,32 @@ compile supportExterns inputFiles foreigns check = silence $ runTest $ do

190assert

205assert

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

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

192 -> [FilePath]

207 -> [FilePath]

193− -> M.Map P.ModuleName 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

197−assert supportExterns inputFiles foreigns check f = do

211+assert supportExterns inputFiles check f = do

198− e <- compile supportExterns inputFiles foreigns 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− -> M.Map P.ModuleName FilePath

206 -> Expectation

231 -> Expectation

207−assertCompiles supportExterns inputFiles foreigns =

232+assertCompiles supportExterns inputFiles =

208− assert supportExterns inputFiles foreigns checkMain $ \e ->

233+ assert supportExterns inputFiles checkMain $ \e ->

209 case e of

234 case e of

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

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

211 Right _ -> do

236 Right _ -> do

@@ -220,19 +245,33 @@ assertCompiles supportExterns inputFiles foreigns =

220 | 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

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

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

222 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+

223 where

264 where

224− checkMain ms =

265+ printAllWarnings warnings =

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

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

226− (fail "Main module missing")

227

267

228assertDoesNotCompile

268assertDoesNotCompile

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

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

230 -> [FilePath]

270 -> [FilePath]

231− -> M.Map P.ModuleName FilePath

232 -> [String]

271 -> [String]

233 -> Expectation

272 -> Expectation

234−assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith =

273+assertDoesNotCompile supportExterns inputFiles shouldFailWith =

235− assert supportExterns inputFiles foreigns noPreCheck $ \e ->

274+ assert supportExterns inputFiles noPreCheck $ \e ->

236 case e of

275 case e of

237 Left errs ->

276 Left errs ->

238 return $ if null shouldFailWith

277 return $ if null shouldFailWith

@@ -245,9 +284,3 @@ assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith =

245

284

246 where

285 where

247 noPreCheck = const (return ())

286 noPreCheck = const (return ())

248−

249− checkShouldFailWith expected errs =

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

251− in if sort expected == sort actual

252− then Nothing

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