8703a73 · rowtype-yoga/purescript-native

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

Merge branch '0.9' into 2070

commit8703a732ce6510d2c653fdc5d4dab4bd923c9ed8 authorPhil Freeman <paf31@cantab.net> dateSun 22 May 2016, 11:09 (10 years ago) parent18c3993 ca98825

43 files changed+645−441

compare with golang

unifiedsplit

examples/warning/DuplicateExportRef.pursnew file+30

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

1+-- @shouldWarnWith DuplicateExportRef

2+-- @shouldWarnWith DuplicateExportRef

3+-- @shouldWarnWith DuplicateExportRef

4+-- @shouldWarnWith DuplicateExportRef

5+-- @shouldWarnWith DuplicateExportRef

6+-- @shouldWarnWith DuplicateExportRef

7+-- @shouldWarnWith DuplicateExportRef

8+module Main

9+ ( X(X, X), X

10+ , fn, fn

11+ , (!), (!)

12+ , class Y, class Y

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

14+ , module Prelude, module Prelude

15+ ) where

16+

17+import Prelude (Unit)

18+

19+data X = X

20+

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

22+fn _ _ = X

23+

24+infix 2 fn as !

25+

26+class Y a

27+

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

29+

30+infixl 1 type Natural as ~>

examples/warning/DuplicateImport.pursnew file+10

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

1+-- @shouldWarnWith DuplicateImport

2+module Main where

4+import Prelude (Unit, unit, pure)

5+import Prelude (Unit, unit, pure)

7+import Control.Monad.Eff (Eff)

9+main :: Eff () Unit

10+main = pure unit

examples/warning/DuplicateImportRef.pursnew file+18

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

1+-- @shouldWarnWith DuplicateImportRef

2+-- @shouldWarnWith DuplicateImportRef

3+-- @shouldWarnWith DuplicateImportRef

4+-- @shouldWarnWith DuplicateImportRef

5+module Main where

7+import Prelude

8+ ( Unit, Unit

9+ , unit, unit

10+ , class Functor, class Functor

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

12+ )

13+

14+u :: Unit

15+u = unit <> unit

16+

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

18+fid fa = fa

examples/warning/DuplicateSelectiveImport.pursnew file+10

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

1+-- @shouldWarnWith DuplicateSelectiveImport

2+module Main where

4+import Prelude (Unit, unit)

5+import Prelude (pure)

7+import Control.Monad.Eff (Eff)

9+main :: Eff () Unit

10+main = pure unit

examples/warning/HidingImport.pursnew file+9

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

1+-- @shouldWarnWith HidingImport

2+-- @shouldWarnWith HidingImport

3+module Main where

5+import Prelude hiding (one)

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

8+main :: Eff () Unit

9+main = pure unit

examples/warning/ImplicitImport.pursnew file+9

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

1+-- @shouldWarnWith ImplicitImport

2+-- @shouldWarnWith ImplicitImport

3+module Main where

5+import Prelude

6+import Control.Monad.Eff

8+main :: Eff () Unit

9+main = pure unit

examples/warning/ImplicitQualifiedImport.pursnew file+11

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

1+-- @shouldWarnWith ImplicitQualifiedImport

2+-- @shouldWarnWith ImplicitQualifiedImport

3+module Main where

5+import Data.Unit

7+import Control.Monad.Eff as E

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

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

11+main = E.log "test"

examples/warning/MissingTypeDeclaration.pursnew file+4

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

1+-- @shouldWarnWith MissingTypeDeclaration

2+module Main where

4+x = 0

examples/warning/OverlappingInstances.pursnew file+17

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

1+-- @shouldWarnWith OverlappingInstances

2+module Main where

4+class Test a where

5+ test :: a -> a

7+instance testRefl :: Test a where

8+ test x = x

10+instance testInt :: Test Int where

11+ test _ = 0

12+

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

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

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

16+value :: Int

17+value = test 1

examples/warning/OverlappingPattern.pursnew file+15

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

1+-- @shouldWarnWith OverlappingPattern

2+-- @shouldWarnWith OverlappingPattern

3+module Main where

5+data X = A | B

7+pat1 :: X -> Boolean

8+pat1 A = true

9+pat1 A = true

10+pat1 B = false

11+

12+pat2 :: X -> Boolean

13+pat2 A = true

14+pat2 _ = false

15+pat2 B = false

examples/warning/ScopeShadowing.pursnew file+13

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

1+-- @shouldWarnWith ScopeShadowing

2+module Main where

4+import Prelude

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

7+data Unit = Unit

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

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

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

12+test :: Unit

13+test = const Unit unit

examples/warning/ShadowedTypeVar.pursnew file+5

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

1+-- @shouldWarnWith ShadowedTypeVar

2+module Main where

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

5+f g x = g x

examples/warning/UnnecessaryFFIModule.jsnew file+1

@@ -0,0 +1 @@

1+exports.out = null;

examples/warning/UnnecessaryFFIModule.pursnew file+5

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

1+-- @shouldWarnWith UnnecessaryFFIModule

2+module Main where

4+t :: Boolean

5+t = true

examples/warning/UnusedDctorExplicitImport.pursnew file+8

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

1+-- @shouldWarnWith UnusedDctorExplicitImport

2+module Main where

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

6+f :: Ordering -> Ordering

7+f EQ = EQ

8+f x = x

examples/warning/UnusedDctorImportAll.pursnew file+7

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

1+-- @shouldWarnWith UnusedDctorImport

2+module Main where

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

6+f :: Ordering -> Ordering

7+f x = x

examples/warning/UnusedDctorImportExplicit.pursnew file+7

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

1+-- @shouldWarnWith UnusedDctorImport

2+module Main where

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

6+f :: Ordering -> Ordering

7+f x = x

examples/warning/UnusedExplicitImport.pursnew file+8

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

1+-- @shouldWarnWith UnusedExplicitImport

2+module Main where

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

5+import Control.Monad.Eff (Eff)

7+main :: Eff () Unit

8+main = pure unit

examples/warning/UnusedFFIImplementations.jsnew file+2

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

1+exports.yes = true;

2+exports.no = false;

examples/warning/UnusedFFIImplementations.pursnew file+4

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

1+-- @shouldWarnWith UnusedFFIImplementations

2+module Main where

4+foreign import yes :: Boolean

examples/warning/UnusedImport.pursnew file+14

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

1+-- @shouldWarnWith UnusedImport

2+-- @shouldWarnWith UnusedImport

3+-- @shouldWarnWith UnusedImport

4+module Main where

6+import Data.Unit (Unit, unit)

8+-- All of the below are unused

9+import Control.Monad.Eff

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

11+import Test.Assert ()

12+

13+main :: Unit

14+main = unit

examples/warning/UnusedTypeVar.pursnew file+5

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

1+-- @shouldWarnWith UnusedTypeVar

2+module Main where

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

5+f x = x

examples/warning/WildcardInferredType.pursnew file+23

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

1+-- @shouldWarnWith WildcardInferredType

2+-- @shouldWarnWith WildcardInferredType

3+-- @shouldWarnWith WildcardInferredType

4+-- @shouldWarnWith WildcardInferredType

5+module Main where

7+x :: Int

8+x = 0 :: _

10+y :: _

11+y = 0

12+

13+z :: Int

14+z =

15+ let n :: _

16+ n = 0

17+ in n

18+

19+w :: Int

20+w = n

21+ where

22+ n :: _

23+ n = 0

psc/Main.hs+21−44

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

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TupleSections #-}

67module Main where

8−import Control.Applicative

9−import Control.Monad

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

11−import Control.Monad.Writer.Strict

9+import Control.Applicative

10+import Control.Monad

11+import Control.Monad.Writer.Strict

1212

13−import Data.List (isSuffixOf, partition)

14−import Data.Version (showVersion)

15−import qualified Data.Map as M

1613import qualified Data.Aeson as A

1714import qualified Data.ByteString.Lazy as B

1815import qualified Data.ByteString.UTF8 as BU8

16+import qualified Data.Map as M

17+import Data.Version (showVersion)

1918

20−import Options.Applicative as Opts

19+import qualified Language.PureScript as P

20+import Language.PureScript.Errors.JSON

21+import Language.PureScript.Make

2122

22−import System.Exit (exitSuccess, exitFailure)

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

24−import System.IO.UTF8

25−import System.FilePath.Glob (glob)

23+import Options.Applicative as Opts

2624

27−import qualified Language.PureScript as P

2825import qualified Paths_purescript as Paths

2926

30−import Language.PureScript.Make

31−import Language.PureScript.Errors.JSON

27+import System.Exit (exitSuccess, exitFailure)

28+import System.FilePath.Glob (glob)

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

30+import System.IO.UTF8

3231

3332data PSCMakeOptions = PSCMakeOptions

3433 { pscmInput :: [FilePath]

35− , pscmForeignInput :: [FilePath]

3634 , pscmOutputDir :: FilePath

3735 , pscmOpts :: P.Options

3836 , pscmUsePrefix :: Bool

3937 , pscmJSONErrors :: Bool

4038 }

4139

42−data InputOptions = InputOptions

43− { ioInputFiles :: [FilePath]

44− }

45−

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

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

4842printWarningsAndErrors verbose False warnings errors = do

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

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

6660 hPutStrLn stderr "psc: No input files."

6761 exitFailure

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

69− moduleFiles <- readInput (InputOptions pursFiles)

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

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

62+ moduleFiles <- readInput input

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

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

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

75− makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix

64+ ms <- P.parseModulesFromFiles id moduleFiles

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

66+ foreigns <- inferForeignModules filePathMap

67+ let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix

7668 P.make makeActions (map snd ms)

7769 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors

7870 exitSuccess

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

8981 return paths

9082 concatMapM f = liftM concat . mapM f

9183

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

93−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right 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

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

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

10286

10387inputFile :: Parser FilePath

10488inputFile = strArgument $

10589 metavar "FILE"

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

10791

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−

11492outputDirectory :: Parser FilePath

11593outputDirectory = strOption $

11694 short 'o'

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

173151

174152pscMakeOptions :: Parser PSCMakeOptions

175153pscMakeOptions = PSCMakeOptions <$> many inputFile

176− <*> many inputForeignFile

177154 <*> outputDirectory

178155 <*> options

179156 <*> (not <$> noPrefix)

psci/Main.hs+4−16

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

3737data PSCiOptions = PSCiOptions

3838 { psciMultiLineMode :: Bool

3939 , psciInputFile :: [FilePath]

40− , psciForeignInputFiles :: [FilePath]

4140 , psciInputNodeFlags :: [String]

4241 }

4342

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

5251 Opts.metavar "FILE"

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

5453

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−

6154nodeFlagsFlag :: Opts.Parser [String]

6255nodeFlagsFlag = Opts.option parser $

6356 Opts.long "node-opts"

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

7063psciOptions :: Opts.Parser PSCiOptions

7164psciOptions = PSCiOptions <$> multiLineMode

7265 <*> many inputFile

73− <*> many inputForeignFile

7466 <*> nodeFlagsFlag

7567

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

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

10799 loop :: PSCiOptions -> IO ()

108100 loop PSCiOptions{..} = do

109101 inputFiles <- concat <$> traverse glob psciInputFile

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

111102 e <- runExceptT $ do

112103 modules <- ExceptT (loadAllModules inputFiles)

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

114105 putStrLn supportModuleMessage

115106 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

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

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

108+ return (modules, externs, env)

121109 case e of

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

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

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

124112 historyFilename <- getHistoryFilename

125113 let settings = defaultSettings { historyFile = Just historyFilename }

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

127− config = PSCiConfig inputFiles foreigns psciInputNodeFlags env

115+ config = PSCiConfig inputFiles psciInputNodeFlags env

128116 runner = flip runReaderT config

129117 . flip evalStateT initialState

130118 . runInputT (setComplete completion settings)

purescript.cabal+2−1

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

6666 , examples/failing/InstanceExport/*.purs

6767 , examples/failing/OrphanInstance/*.purs

6868 , examples/failing/OverlappingReExport/*.purs

69+ , examples/warning/*.purs

70+ , examples/warning/*.js

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

7072 , examples/docs/bower.json

7173 , examples/docs/src/*.purs

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

179181 Language.PureScript.Parser.Lexer

180182 Language.PureScript.Parser.Common

181183 Language.PureScript.Parser.Declarations

182− Language.PureScript.Parser.JS

183184 Language.PureScript.Parser.Kinds

184185 Language.PureScript.Parser.State

185186 Language.PureScript.Parser.Types

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

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

55import Prelude.Compat

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

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

88import Control.Monad

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

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

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

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

9797-- class members are listed.

9898--

99−collectDeclarations ::

99+collectDeclarations :: forall m.

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

101101 P.Imports ->

102102 P.Exports ->

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

111111 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

112112

113113 let filteredTypes = filterDataConstructors expCtors types

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

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

115115

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

117117

118118 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])

119126 collect lookup' imps exps = do

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

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

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

122129

123130 expVals = P.exportedValues exports

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

126133 expValOps = P.exportedValueOps exports

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

128135

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

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

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

131138

132139 expTypeOps = P.exportedTypeOps exports

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

134141

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

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

136143

137144 expTCs = P.exportedTypeClasses exports

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

src/Language/PureScript/Errors.hs−6

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

128128 | DuplicateImportRef Name

129129 | DuplicateExportRef Name

130130 | IntOutOfRange Integer String Integer Integer

131− | RedundantEmptyHidingImport ModuleName

132131 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

133132 | ImplicitImport ModuleName [DeclarationRef]

134133 | HidingImport ModuleName [DeclarationRef]

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

298297 DuplicateImportRef{} -> "DuplicateImportRef"

299298 DuplicateExportRef{} -> "DuplicateExportRef"

300299 IntOutOfRange{} -> "IntOutOfRange"

301− RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

302300 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

303301 ImplicitImport{} -> "ImplicitImport"

304302 HidingImport{} -> "HidingImport"

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

422420errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

423421errorSuggestion err = case err of

424422 UnusedImport{} -> emptySuggestion

425− RedundantEmptyHidingImport{} -> emptySuggestion

426423 DuplicateImport{} -> emptySuggestion

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

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

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

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

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

884881

885− renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

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

887−

888882 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

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

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

1919import qualified Data.Set as S

2020import qualified Language.PureScript as P

2121import Language.PureScript.Errors.JSON

22−import System.FilePath (replaceExtension)

23−import System.Directory (doesFileExist)

2422import System.IO.UTF8 (readUTF8File)

2523

2624rebuildFile

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

3735 Right [m] -> pure m

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

3937

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

39+ -- correctly to the 'Environment'.

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

4141

4242 outputDirectory <- confOutputPath . envConfiguration <$> ask

4343

44− let foreignModule = replaceExtension path "js"

45− foreignExists <- liftIO (doesFileExist foreignModule)

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

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

4648

47− let ma = P.buildMakeActions outputDirectory

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

49− (if foreignExists

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

51− else M.empty)

52− False

49+ -- Silence progress update messages during the build

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

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

52+

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

5354 (result, warnings) <- liftIO

54− . P.runMake P.defaultOptions

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

56− $ m

55+ . P.runMake P.defaultOptions

56+ . P.rebuildModule actions externs

57+ $ m

5758 case result of

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

5960 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

5353

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

5555rebuild

56− :: M.Map P.ModuleName FilePath

57− -> [P.ExternsFile]

56+ :: [P.ExternsFile]

5857 -> P.Module

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

60−rebuild foreignFiles loadedExterns m = do

59+rebuild loadedExterns m = do

6160 externs <- P.rebuildModule buildActions loadedExterns m

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

6362 where

6463 buildActions :: P.MakeActions P.Make

65− buildActions = (P.buildMakeActions modulesDir

66− filePathMap

67− foreignFiles

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

64+ buildActions =

65+ (P.buildMakeActions modulesDir

66+ filePathMap

67+ M.empty

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

6969

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

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

7272

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

7474make

75− :: M.Map P.ModuleName FilePath

76− -> [P.Module]

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

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

78−make foreignFiles ms = do

79− externs <- P.make buildActions ms

77+make ms = do

78+ foreignFiles <- P.inferForeignModules filePathMap

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

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

8181 where

82− buildActions :: P.MakeActions P.Make

83− buildActions = (P.buildMakeActions modulesDir

84− filePathMap

85− foreignFiles

86− False)

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

83+ buildActions foreignFiles =

84+ P.buildMakeActions modulesDir

85+ filePathMap

86+ foreignFiles

87+ False

8788

8889 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

9091

9192-- | Performs a PSCi command

9293handleCommand

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

115116 files <- asks psciLoadedFiles

116117 e <- runExceptT $ do

117118 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

120120 return (map snd modules, externs)

121121 case e of

122122 Left errs -> printErrors errs

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

132132handleExpression val = do

133133 st <- get

134134 let m = createTemporaryModule True st val

135− foreignFiles <- asks psciForeignFiles

136135 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

138137 case e of

139138 Left errs -> printErrors errs

140139 Right _ -> do

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

157156handleDecls ds = do

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

159158 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

162160 case e of

163161 Left err -> printErrors err

164162 Right _ -> put st

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

212210 -> m ()

213211handleImport im = do

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

215− foreignFiles <- asks psciForeignFiles

216213 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

218215 case e of

219216 Left errs -> printErrors errs

220217 Right _ -> put st

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

226223 -> m ()

227224handleTypeOf val = do

228225 st <- get

229− foreignFiles <- asks psciForeignFiles

230226 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

232228 case e of

233229 Left errs -> printErrors errs

234230 Right (_, env') ->

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

243239 -> m ()

244240handleKindOf typ = do

245241 st <- get

246− foreignFiles <- asks psciForeignFiles

247242 let m = createTemporaryModuleForKind st typ

248243 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

250245 case e of

251246 Left errs -> printErrors errs

252247 Right (_, env') ->

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

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

66import Prelude.Compat

8−import Data.Map (Map)

98import qualified Language.PureScript as P

109

1110-- | The PSCI configuration.

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

1413--

1514data PSCiConfig = PSCiConfig

1615 { psciLoadedFiles :: [FilePath]

17− , psciForeignFiles :: Map P.ModuleName FilePath

1816 , psciNodeFlags :: [String]

1917 , psciEnvironment :: P.Environment

2018 } deriving Show

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

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

1414import Control.Arrow (first, second)

1515import Control.Monad (unless)

1616import Control.Monad.Writer.Class

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

1718

1819import Data.Function (on)

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

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

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

4647--

4748qualifyName

48− :: (ProperName a)

49+ :: ProperName a

4950 -> ModuleName

5051 -> Qualified (ProperName b)

5152 -> Qualified (ProperName a)

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

231232--

232233checkExhaustive

233234 :: forall m

234− . (MonadWriter MultipleErrors m)

235+ . (MonadWriter MultipleErrors m, MonadSupply m)

235236 => Environment

236237 -> ModuleName

237238 -> Int

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

262263 _ -> return ()

263264 if null bss

264265 then return expr

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

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

266267 where

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

268269 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

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

273274 --

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

275276 -- and then included in the error message.

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

277− addPartialConstraint (bss, complete) e =

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

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

278+ addPartialConstraint (bss, complete) e = do

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

280+ var <- freshName

281+ return $

282+ Let

283+ [ partial var tyVar ]

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

279285 where

280− partial :: Declaration

281− partial = ValueDeclaration (Ident C.__unused)

282− Private

283− []

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

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

286− ty))

287−

288− ty :: Type

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

290− (ProperName "Partial"))

291− []

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

293− ]

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

295− (TypeVar "a")))

296− Nothing

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

287+ partial var tyVar =

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

289+ TypedValue

290+ True

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

292+ (ty tyVar)

293+

294+ ty :: String -> Type

295+ ty tyVar =

296+ ForAll tyVar

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 =

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

297306

298307-- |

299308-- Exhaustivity checking

300309--

301310checkExhaustiveExpr

302311 :: forall m

303− . MonadWriter MultipleErrors m

312+ . (MonadWriter MultipleErrors m, MonadSupply m)

304313 => Environment

305314 -> ModuleName

306315 -> Expr

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

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

77import Prelude.Compat

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

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

1010import Control.Monad.Writer.Class

1111

1212import Data.Function (on)

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

5454 -> Env

5555 -> UsedImports

5656 -> m ()

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

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

58+ internalError "lintImports needs desugared exports"

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

5960

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

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

100101 maybe id warnWithPosition pos $

101102 tell $ errorMessage $ DuplicateSelectiveImport mnq

102103

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

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

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

105106 Explicit refs -> refs

106107 Hiding refs -> refs

107108 _ -> []

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

109− checkEmptyImport mnq imported typ

110109

111110 where

112111

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

120119 countOpenImports :: Declaration -> Int

121120 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

122121 countOpenImports (ImportDeclaration mn' Implicit Nothing)

123− | not (isPrim mn') = 1

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

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

125− | not (isPrim mn') = 1

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

126125 countOpenImports _ = 0

127126

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

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

159158 elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

160159 elaborateUsed scope mne used =

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

162− types = extractByQual mne (importedTypes scope) TyName

163− dctors = extractByQual mne (importedDataConstructors scope) DctorName

164− values = extractByQual mne (importedValues scope) IdentName

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

160+ foldr go used

161+ $ extractByQual mne (importedTypeClasses scope) TyClassName

162+ ++ extractByQual mne (importedTypes scope) TyName

163+ ++ extractByQual mne (importedDataConstructors scope) DctorName

164+ ++ extractByQual mne (importedValues scope) IdentName

166165 where

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

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

169168

170169 extractByQual

171− :: (Eq a)

170+ :: Eq a

172171 => ModuleName

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

174173 -> (a -> Name)

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

199198lintImportDecl env mni qualifierName names declType allowImplicit =

200199 case declType of

201200 Implicit -> case qualifierName of

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

201+ Nothing ->

202+ if null allRefs

203+ then unused

204+ else unless' allowImplicit (checkImplicit ImplicitImport)

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

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

205207 Explicit [] -> unused

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

213215 checkImplicit warning =

214216 if null allRefs

215217 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

217227

218228 checkExplicit

219229 :: [DeclarationRef]

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

248258 warn :: SimpleErrorMessage -> m Bool

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

250260

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.

251267 unless' :: Bool -> m Bool -> m Bool

252− unless' True m = m

253− unless' False _ = return False

268+ unless' False m = m

269+ unless' True _ = return False

254270

255271 allRefs :: [DeclarationRef]

256272 allRefs = findUsedRefs env mni qualifierName names

257273

258274 dtys

259275 :: ModuleName

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

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

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

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

262278

263279 dctorsForType

264280 :: ModuleName

265281 -> ProperName 'TypeName

266282 -> [ProperName 'ConstructorName]

267− dctorsForType mn tn =

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

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

269284

270285 typeForDCtor

271286 :: ModuleName

272287 -> ProperName 'ConstructorName

273288 -> 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))

275290

276291findUsedRefs

277292 :: Env

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

310325 findTypeForDctor mn dctor =

311326 case mn `M.lookup` env of

312327 Just (_, _, exps) ->

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

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

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

329+ Just (ty, _) -> ty

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

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

317332

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

345360 tell $ errorMessage $ DuplicateImport mn t2 q2

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

347362 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

1717 , makeIO

1818 , readTextFile

1919 , buildMakeActions

20+ , inferForeignModules

2021 ) where

2122

2223import Prelude.Compat

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

7576import SourceMap.Types

7677

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

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

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

7980import System.IO.Error (tryIOError)

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

8182

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

9899--

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

100101--

101−data MakeActions m = MakeActions {

102− -- |

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

102+data MakeActions m = MakeActions

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

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

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

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

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

114− -- |

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

116− -- path for the file.

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

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

110+ -- output files are missing.

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

118− -- |

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

120− --

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

113+ -- path for the file.

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

122− -- |

123− -- Respond to a progress update.

124− --

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

125116 , progress :: ProgressMessage -> m ()

117+ -- ^ Respond to a progress update.

126118 }

127119

128120-- |

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

297289readTextFile :: FilePath -> Make String

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

299291

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+

300310-- |

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

302312--

src/Language/PureScript/Parser.hs−1

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

1717

1818import Language.PureScript.Parser.Common as P

1919import Language.PureScript.Parser.Declarations as P

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

2120import Language.PureScript.Parser.Kinds as P

2221import Language.PureScript.Parser.Lexer as P

2322import 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

1010

1111import Prelude.Compat

1212

13−import Control.Arrow (first)

13+import Control.Arrow (first, second)

1414import Control.Monad

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

1616import Control.Monad.State.Lazy

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

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

7373 where

7474

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

76− exportedTypes = mapMaybe toExportedType efExports

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

76+ exportedTypes = M.fromList $ mapMaybe toExportedType efExports

7777 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))

7979 where

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

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

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

8383 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

8484 toExportedType _ = Nothing

8585

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

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

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

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

8888

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

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

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

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

9191

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

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

92+ exportedValues :: M.Map Ident ModuleName

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

9494

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

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

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

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

9797

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

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

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

111111 warnAndRethrow (addHint (ErrorInModule mn)) $ do

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

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

114− lintImports m env used

114+ lintImports m' env used

115115 return m'

116116

117117-- |

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

122122elaborateExports :: Exports -> Module -> Module

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

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

126126 map TypeOpRef (my exportedTypeOps) ++

127127 map TypeClassRef (my exportedTypeClasses) ++

128128 map ValueRef (my exportedValues) ++

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

131131 where

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

133133 -- are re-exports from other modules.

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

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

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

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

136142

137143-- |

138144-- 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) =

294300

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

296302 -- module of original definition.

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

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

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

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

299305

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

301307 -- original definition.

302308 resolveType

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

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

304310 -> ProperName 'TypeName

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

306312 resolveType tys name =

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

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

308314

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

310316 -- module of original definition.

311317 resolveDctor

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

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

313319 -> ProperName 'ConstructorName

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

315321 resolveDctor tys name =

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

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

317323

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

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

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

4444 -- separately

4545 deleteCtors :: DeclarationRef -> DeclarationRef

46+ deleteCtors (PositionedDeclarationRef ss com ref) =

47+ PositionedDeclarationRef ss com (deleteCtors ref)

4648 deleteCtors (TypeRef pn _) = TypeRef pn Nothing

4749 deleteCtors other = other

4850

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

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

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

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

5255 let dupes = dctors \\ nub dctors

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

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

5557 extractCtors _ _ = Nothing

5658

5759 -- 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(..))

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

2727

2828import Data.Function (on)

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

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

3030import Data.Maybe (fromJust, mapMaybe)

3131import qualified Data.Map as M

3232import qualified Data.Set as S

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

9292 --

9393 , importedValueOps :: ImportMap (OpName 'ValueOpName)

9494 -- |

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.

9698 --

9799 , importedModules :: S.Set ModuleName

98100 -- |

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

114116data Exports = Exports

115117 {

116118 -- |

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

118− -- came from.

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

119120 --

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

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

121122 -- |

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

123− -- originally came from.

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

124+ -- from.

124125 --

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

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

126127 -- |

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

128− -- came from.

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

129129 --

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

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

131131 -- |

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

133− -- came from.

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

134133 --

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

134+ , exportedValues :: M.Map Ident ModuleName

136135 -- |

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

138− -- originally came from.

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

137+ -- from.

139138 --

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

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

141140 } deriving (Show, Read)

142141

143142-- |

144143-- An empty 'Exports' value.

145144--

146145nullExports :: Exports

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

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

148147

149148-- |

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

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

177176primExports :: Exports

178177primExports =

179178 nullExports

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

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

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

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

182181 }

183182 where

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

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

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

186185

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

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

202201 -> ModuleName

203202 -> m Exports

204203exportType exps name dctors mn = do

205− let exTypes' = exportedTypes exps

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

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

204+ let exTypes = exportedTypes exps

208205 let exClasses = exportedTypeClasses exps

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

210− throwConflictError ConflictingTypeDecls name

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

206+ case name `M.lookup` exTypes of

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

208+ _ -> return ()

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

212210 throwConflictError TypeConflictsWithClass name

213211 forM_ dctors $ \dctor -> do

214− when (dctor `elem` exDctors) $

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

215213 throwConflictError ConflictingCtorDecls dctor

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

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

217215 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'

219219

220220-- |

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

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

242242 -> m Exports

243243exportTypeClass exps name mn = do

244244 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) $

247246 throwConflictError ClassConflictsWithType name

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

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

249248 throwConflictError ClassConflictsWithCtor name

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

251250 return $ exps { exportedTypeClasses = classes }

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

282281-- case an error is returned.

283282--

284283addExport

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

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

286285 => (a -> SimpleErrorMessage)

287286 -> a

288287 -> ModuleName

289− -> [(a, ModuleName)]

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

288+ -> M.Map a ModuleName

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

291290addExport what name mn exports =

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

293− then throwConflictError what name

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

291+ case M.lookup name exports of

292+ Just mn'

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

294+ | otherwise -> throwConflictError what name

295+ Nothing ->

296+ return $ M.insert name mn exports

295297

296298-- |

297299-- 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(..))

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

1111

1212import Data.Foldable (traverse_)

13−import Data.List (find, intersect)

13+import Data.List (intersect)

1414import Data.Maybe (fromMaybe, mapMaybe)

1515import qualified Data.Map as M

1616

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

7676 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

7777 warnAndRethrowWithPosition pos $ elaborateModuleExports result r

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

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

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

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

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

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

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

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

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

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

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

8484 return result

8585 { exportedTypes = types'

8686 , exportedTypeOps = typeOps'

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

155155 go

156156 :: Qualified (ProperName 'TypeName)

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

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

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

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

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

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

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

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

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

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

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

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

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

164165

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

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

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

195196 $ resolve exportedValueOps op

196197

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

198+ resolve

199+ :: Ord a

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

201+ -> Qualified a

202+ -> Maybe (Qualified a)

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

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

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

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

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

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

203208

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

219224 -> [DeclarationRef]

220225 -> m Exports

221226filterModule mn exps refs = do

222− types <- foldM filterTypes [] refs

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

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

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

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

227+ types <- foldM filterTypes M.empty refs

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

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

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

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

227232 return Exports

228233 { exportedTypes = types

229234 , exportedTypeOps = typeOps

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

235240 where

236241

237242 filterTypes

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

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

239244 -> DeclarationRef

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

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

241246 filterTypes result (PositionedDeclarationRef pos _ r) =

242247 rethrowWithPosition pos $ filterTypes result r

243248 filterTypes result (TypeRef name expDcons) =

244− case matchType `find` exportedTypes exps of

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

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

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

251+ Just (dcons, _) -> do

247252 let expDcons' = fromMaybe dcons expDcons

248253 traverse_ (checkDcon name dcons) expDcons'

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

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

250255 where

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

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

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

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

255258 -- the data constructor to check.

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

264267 filterTypes result _ = return result

265268

266269 filterExport

267− :: Eq a

270+ :: Ord a

268271 => (a -> Name)

269272 -> (DeclarationRef -> Maybe a)

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

271− -> [(a, ModuleName)]

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

274+ -> M.Map a ModuleName

272275 -> DeclarationRef

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

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

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

275278 rethrowWithPosition pos $ filterExport toName get fromExps result r

276279 filterExport toName get fromExps result ref

277280 | Just name <- get ref =

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

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

280− else throwError . errorMessage . UnknownExport $ toName name

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

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

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

281285 filterExport _ _ _ result _ = return result

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

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

88import Prelude.Compat

10−import Control.Arrow (first)

1110import Control.Monad

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

1312

1413import Data.Foldable (for_, traverse_)

15−import Data.List (find)

1614import Data.Maybe (fromMaybe)

1715import qualified Data.Map as M

1816import qualified Data.Set as S

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

118116 check (PositionedDeclarationRef pos _ r) =

119117 rethrowWithPosition pos $ check r

120118 check (ValueRef name) =

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

119+ checkImportExists IdentName (exportedValues exps) name

122120 check (ValueOpRef op) =

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

121+ checkImportExists ValOpName (exportedValueOps exps) op

124122 check (TypeRef name dctors) = do

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

126− let allDctors = fst `map` allExportedDataConstructors name

123+ checkImportExists TyName (exportedTypes exps) name

124+ let (allDctors, _) = allExportedDataConstructors name

127125 for_ dctors $ traverse_ (checkDctorExists name allDctors)

128126 check (TypeOpRef name) =

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

127+ checkImportExists TyOpName (exportedTypeOps exps) name

130128 check (TypeClassRef name) =

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

129+ checkImportExists TyClassName (exportedTypeClasses exps) name

132130 check (ModuleRef name) | isHiding =

133131 throwError . errorMessage $ ImportHidingModule name

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

135133

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

137135 checkImportExists

138− :: Eq a

136+ :: Ord a

139137 => (a -> Name)

140− -> [a]

138+ -> M.Map a b

141139 -> a

142140 -> m ()

143141 checkImportExists toName exports item

144− = when (item `notElem` exports)

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

145143 . throwError . errorMessage

146144 $ UnknownImport importModule (toName item)

147145

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

177175 -- Import all symbols

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

179177 importAll importer =

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

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

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

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

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

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

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

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

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

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

185183

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

187185 importRef prov imp (PositionedDeclarationRef pos _ r) =

188186 rethrowWithPosition pos $ importRef prov imp r

189187 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

191189 return $ imp { importedValues = values' }

192190 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

194192 return $ imp { importedValueOps = valueOps' }

195193 importRef prov imp (TypeRef name dctors) = do

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

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

198− exportedDctors = allExportedDataConstructors name

199− dctorNames :: [ProperName 'ConstructorName]

200− dctorNames = fst `map` exportedDctors

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

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

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

195+ let (dctorNames, mn) = allExportedDataConstructors name

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

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

198+ traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors

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

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

204201 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

206203 return $ imp { importedTypeOps = ops' }

207204 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

209206 return $ imp { importedTypeClasses = typeClasses' }

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

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

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

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

214211 allExportedDataConstructors

215212 :: ProperName 'TypeName

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

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

217214 allExportedDataConstructors name =

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

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

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

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

216+ $ name `M.lookup` exportedTypes exps

221217

222218 -- Add something to an import resolution list

223219 updateImports

224220 :: (Ord a)

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

226− -> [(a, ModuleName)]

222+ -> M.Map a b

223+ -> (b -> ModuleName)

227224 -> a

228225 -> ImportProvenance

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

230− updateImports imps' exps' name prov =

227+ updateImports imps' exps' expName name prov =

231228 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')

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

234231 in

235232 M.alter

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

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

131131fileGlob :: String

132132fileGlob = unwords

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

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

135134 ]

136135

137136-- Integration Testing API

tests/TestCompiler.hs+90−57

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

2727

2828import Data.Char (isSpace)

2929import Data.Function (on)

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

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

3131import Data.Maybe (mapMaybe)

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

33+import Data.Tuple (swap)

3334

3435import qualified Data.Map as M

3536

3637import Control.Monad

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

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

3839

3940import Control.Monad.Reader

4041import Control.Monad.Writer.Strict

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

5758spec :: Spec

5859spec = do

5960

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

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

6162 cwd <- getCurrentDirectory

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

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

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

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

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

6668 passingFiles <- getTestFiles passing <$> testGlob passing

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

6770 failingFiles <- getTestFiles failing <$> testGlob failing

6871 supportPurs <- supportFiles "purs"

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

7072 supportPursFiles <- readInput supportPurs

7173 supportExterns <- runExceptT $ do

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

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

75+ foreigns <- inferForeignModules modules

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

7477 return (zip (map snd modules) externs)

7578 case supportExterns of

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

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

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

7881

79− context ("Passing examples") $ do

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

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

82− testForeigns <- loadForeigns testJS

83− assertCompiles supportExterns testPurs (supportForeigns <> testForeigns)

82+ context "Passing examples" $

83+ forM_ passingTestCases $ \testPurs ->

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

85+ assertCompiles supportExterns testPurs

8486

85− context ("Failing examples") $ do

86− forM_ failingTestCases $ \(testPurs, testJS) -> do

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+

94+ context "Failing examples" $

95+ forM_ failingTestCases $ \testPurs -> do

8796 let mainPath = getTestMain testPurs

8897 expectedFailures <- runIO $ getShouldFailWith mainPath

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

90− testForeigns <- loadForeigns testJS

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

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

99+ assertDoesNotCompile supportExterns testPurs expectedFailures

92100

93101 where

94102

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

96104 testGlob :: FilePath -> IO [FilePath]

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

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+ testGlob = Glob.globDir1 (Glob.compile "**/*.purs")

105106

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

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

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

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

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

110111 getTestFiles baseDir

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

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

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

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

114114 . sortBy (compare `on` extractPrefix)

115115 . map (makeRelative baseDir)

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

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

119119 -- will be under a subdirectory.

120120 getTestMain :: [FilePath] -> FilePath

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

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

122122

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

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

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

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

134134 -- determine expected failures

135135 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

137145 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)

139156

140157trim :: String -> String

141158trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

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

167184 text <- readUTF8File inputFile

168185 return (inputFile, text)

169186

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

171−

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

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

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

188+runTest = P.runMake P.defaultOptions

174189

175190compile

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

177192 -> [FilePath]

178− -> M.Map P.ModuleName FilePath

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

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

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

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

195+compile supportExterns inputFiles check = silence $ runTest $ do

182196 fs <- liftIO $ readInput inputFiles

183197 ms <- P.parseModulesFromFiles id fs

198+ foreigns <- inferForeignModules ms

184199 liftIO (check (map snd ms))

185200 let actions = makeActions foreigns

186201 case ms of

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

190205assert

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

192207 -> [FilePath]

193− -> M.Map P.ModuleName FilePath

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

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

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

196210 -> Expectation

197−assert supportExterns inputFiles foreigns check f = do

198− e <- compile supportExterns inputFiles foreigns check

199− maybeErr <- f e

211+assert supportExterns inputFiles check f = do

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

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

200214 maybe (return ()) expectationFailure maybeErr

201215

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+

202228assertCompiles

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

204230 -> [FilePath]

205− -> M.Map P.ModuleName FilePath

206231 -> Expectation

207−assertCompiles supportExterns inputFiles foreigns =

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

232+assertCompiles supportExterns inputFiles =

233+ assert supportExterns inputFiles checkMain $ \e ->

209234 case e of

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

211236 Right _ -> do

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

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

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

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

223264 where

224− checkMain ms =

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

226− (fail "Main module missing")

265+ printAllWarnings warnings =

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

227267

228268assertDoesNotCompile

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

230270 -> [FilePath]

231− -> M.Map P.ModuleName FilePath

232271 -> [String]

233272 -> Expectation

234−assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith =

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

273+assertDoesNotCompile supportExterns inputFiles shouldFailWith =

274+ assert supportExterns inputFiles noPreCheck $ \e ->

236275 case e of

237276 Left errs ->

238277 return $ if null shouldFailWith

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

245284

246285 where

247286 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