55b797d · rowtype-yoga/purescript-native

psc/Main.hs+21−44

compare with golang

unifiedsplit

@@ -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+1−2

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

1name: purescript

2−version: 0.8.5.0

2+version: 0.9.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -195,7 +195,6 @@ library

195 Language.PureScript.Parser.Lexer

196 Language.PureScript.Parser.Common

197 Language.PureScript.Parser.Declarations

198− Language.PureScript.Parser.JS

199 Language.PureScript.Parser.Kinds

198 Language.PureScript.Parser.Kinds

200 Language.PureScript.Parser.State

199 Language.PureScript.Parser.State

201 Language.PureScript.Parser.Types

200 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/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/Imports.hs+12−13

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

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

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

160 elaborateUsed scope mne used =

161+ foldr go used

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

162+ $ extractByQual mne (importedTypeClasses scope) TyClassName

162− types = extractByQual mne (importedTypes scope) TyName

163+ ++ extractByQual mne (importedTypes scope) TyName

163− dctors = extractByQual mne (importedDataConstructors scope) DctorName

164+ ++ extractByQual mne (importedDataConstructors scope) DctorName

164− values = extractByQual mne (importedValues scope) IdentName

165+ ++ extractByQual mne (importedValues scope) IdentName

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

166 where

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

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

169

170 extractByQual

171− :: (Eq a)

171+ :: Eq a

172 => ModuleName

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

174 -> (a -> Name)

@@ -257,21 +257,20 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

257

258 dtys

259 :: ModuleName

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

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

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

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

262

263 dctorsForType

264 :: ModuleName

265 -> ProperName 'TypeName

266 -> [ProperName 'ConstructorName]

267− dctorsForType mn tn =

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

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

269

268

270 typeForDCtor

269 typeForDCtor

271 :: ModuleName

270 :: ModuleName

272 -> ProperName 'ConstructorName

271 -> ProperName 'ConstructorName

273 -> Maybe (ProperName 'TypeName)

272 -> Maybe (ProperName 'TypeName)

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

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

275

274

276findUsedRefs

275findUsedRefs

277 :: Env

276 :: Env

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

310 findTypeForDctor mn dctor =

309 findTypeForDctor mn dctor =

311 case mn `M.lookup` env of

310 case mn `M.lookup` env of

312 Just (_, _, exps) ->

311 Just (_, _, exps) ->

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

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

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

313+ Just (ty, _) -> ty

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

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

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

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

317

316

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+27−21

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

@@ -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/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+33−35

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

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,7 +58,7 @@ main = hspec spec

57spec :: Spec

58spec :: Spec

58spec = do

59spec = do

59

60

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

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

61 cwd <- getCurrentDirectory

62 cwd <- getCurrentDirectory

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

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

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

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

@@ -66,49 +67,40 @@ spec = do

66 passingFiles <- getTestFiles passing <$> testGlob passing

67 passingFiles <- getTestFiles passing <$> testGlob passing

67 failingFiles <- getTestFiles failing <$> testGlob failing

68 failingFiles <- getTestFiles failing <$> testGlob failing

68 supportPurs <- supportFiles "purs"

69 supportPurs <- supportFiles "purs"

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

70 supportPursFiles <- readInput supportPurs

71 supportExterns <- runExceptT $ do

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

73+ foreigns <- inferForeignModules modules

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

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

74 return (zip (map snd modules) externs)

75 return (zip (map snd modules) externs)

75 case supportExterns of

76 case supportExterns of

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

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

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

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

78

79

79 context ("Passing examples") $ do

80 context ("Passing examples") $ do

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

81+ forM_ passingTestCases $ \testPurs ->

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

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

82− testForeigns <- loadForeigns testJS

83− assertCompiles supportExterns testPurs (supportForeigns <> testForeigns)

83+ assertCompiles supportExterns testPurs

84

85 context ("Failing examples") $ do

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

86+ forM_ failingTestCases $ \testPurs -> do

87 let mainPath = getTestMain testPurs

88 expectedFailures <- runIO $ getShouldFailWith mainPath

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

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

90− testForeigns <- loadForeigns testJS

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

90+ assertDoesNotCompile supportExterns testPurs expectedFailures

92

91

93 where

92 where

94

93

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

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

96 testGlob :: FilePath -> IO [FilePath]

95 testGlob :: FilePath -> IO [FilePath]

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

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

97

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

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

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

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

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

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

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

110 getTestFiles baseDir

102 getTestFiles baseDir

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

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

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

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

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

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

114 . sortBy (compare `on` extractPrefix)

106 . sortBy (compare `on` extractPrefix)

@@ -137,6 +129,15 @@ spec = do

137 where

129 where

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

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

139

131

132+inferForeignModules

133+ :: MonadIO m

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

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

136+inferForeignModules = P.inferForeignModules . fromList

137+ where

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

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

140+

140trim :: String -> String

141trim :: String -> String

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

142trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

142

143

@@ -175,12 +176,12 @@ runTest = fmap fst . P.runMake P.defaultOptions

175compile

176compile

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

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

177 -> [FilePath]

178 -> [FilePath]

178− -> M.Map P.ModuleName FilePath

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

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

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

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

182 fs <- liftIO $ readInput inputFiles

183 ms <- P.parseModulesFromFiles id fs

184+ foreigns <- inferForeignModules ms

184 liftIO (check (map snd ms))

185 liftIO (check (map snd ms))

185 let actions = makeActions foreigns

186 let actions = makeActions foreigns

186 case ms of

187 case ms of

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

190assert

191assert

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

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

192 -> [FilePath]

193 -> [FilePath]

193− -> M.Map P.ModuleName FilePath

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

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

196 -> Expectation

197−assert supportExterns inputFiles foreigns check f = do

197+assert supportExterns inputFiles check f = do

198− e <- compile supportExterns inputFiles foreigns check

198+ e <- compile supportExterns inputFiles check

199 maybeErr <- f e

200 maybe (return ()) expectationFailure maybeErr

201

202assertCompiles

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

204 -> [FilePath]

205− -> M.Map P.ModuleName FilePath

206 -> Expectation

205 -> Expectation

207−assertCompiles supportExterns inputFiles foreigns =

206+assertCompiles supportExterns inputFiles = do

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

207+ assert supportExterns inputFiles checkMain $ \e ->

209 case e of

208 case e of

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

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

211 Right _ -> do

210 Right _ -> do

@@ -228,11 +227,10 @@ assertCompiles supportExterns inputFiles foreigns =

228assertDoesNotCompile

227assertDoesNotCompile

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

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

230 -> [FilePath]

229 -> [FilePath]

231− -> M.Map P.ModuleName FilePath

232 -> [String]

230 -> [String]

233 -> Expectation

231 -> Expectation

234−assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith =

232+assertDoesNotCompile supportExterns inputFiles shouldFailWith = do

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

233+ assert supportExterns inputFiles noPreCheck $ \e ->

236 case e of

234 case e of

237 Left errs ->

235 Left errs ->

238 return $ if null shouldFailWith

236 return $ if null shouldFailWith