bbd67e4 · rowtype-yoga/purescript-native

.gitmodulesnew file+3

compare with golang

unifiedsplit

@@ -0,0 +1,3 @@

1+[submodule "tests/support/prelude"]

2+ path = tests/support/prelude

3+ url = https://github.com/purescript/purescript-prelude

examples/failing/CaseBinderLengthsDiffer.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith CaseBinderLengthDiffers

2+module Main where

3+

4+test = case 1, 2 of

5+ 1, 2, 3 -> 42

6+ _, _ -> 43

examples/failing/ConflictingExports.pursnew file+16

@@ -0,0 +1,16 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+module B where

8+

9+ thing :: Int

10+ thing = 2

11+

12+-- Fails here because re-exporting forces any scope conflicts to be resolved

13+module Main (module A, module B) where

14+

15+ import A

16+ import B

examples/failing/ConflictingExports2.pursnew file+13

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

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+-- Fails here because re-exporting forces any scope conflicts to be resolved

8+module Main (thing, module A) where

9+

10+ import A

11+

12+ thing :: Int

13+ thing = 2

examples/failing/ConflictingImports.pursnew file+19

@@ -0,0 +1,19 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+module B where

8+

9+ thing :: Int

10+ thing = 2

11+

12+module Main where

13+

14+ import A

15+ import B

16+

17+ -- Error due to referencing `thing` which is in scope as A.thing and B.thing

18+ what :: Int

19+ what = thing

examples/failing/ConflictingImports2.pursnew file+16

@@ -0,0 +1,16 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+module Main where

8+

9+ import A

10+

11+ thing :: Int

12+ thing = 2

13+

14+ -- Error due to referencing `thing` which is in scope as A.thing and Main.thing

15+ what :: Int

16+ what = thing

examples/failing/ConflictingQualifiedImports.pursnew file+17

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

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+module B where

8+

9+ thing :: Int

10+ thing = 2

11+

12+module Main where

13+

14+ import A as X

15+ import B as X

16+

17+ foo = X.thing

examples/failing/ConflictingQualifiedImports2.pursnew file+15

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

1+-- @shouldFailWith ScopeConflict

2+module A where

3+

4+ thing :: Int

5+ thing = 1

6+

7+module B where

8+

9+ thing :: Int

10+ thing = 2

11+

12+module Main (module X) where

13+

14+ import A as X

15+ import B as X

examples/failing/OperatorAliasNoExport.pursnew file+7

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

1+-- @shouldFailWith TransitiveExportError

2+module Test ((?!)) where

3+

4+infixl 4 what as ?!

5+

6+what :: forall a b. a -> b -> a

7+what a _ = a

examples/passing/1697.pursnew file+24

@@ -0,0 +1,24 @@

1+module Main where

2+

3+import Prelude

4+

5+_2 :: forall a. a -> a

6+_2 a = a

7+

8+x :: forall m. (Monad m) => m Unit

9+x = do

10+ _ <- pure unit

11+ pure unit

12+

13+y :: forall m. (Monad m) => m Unit

14+y = do

15+ _ <- pure unit

16+ pure unit

17+

18+wtf :: forall m. (Monad m) => m Unit

19+wtf = do

20+ _ <- pure unit

21+ let tmp = _2 1

22+ pure unit

23+

24+main = Control.Monad.Eff.Console.log "Done"

examples/passing/CaseMultipleExpressions.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+import Control.Monad.Eff

6+

7+doIt :: forall eff. Eff eff Boolean

8+doIt = return true

9+

10+set = do

11+ log "Testing..."

12+ case 42, 10 of

13+ 42, 10 -> doIt

14+ _ , _ -> return false

15+

16+main = do

17+ b <- set

18+ case b of

19+ true -> log "Done"

examples/passing/EmptyTypeClass.purs+3−3

@@ -2,11 +2,11 @@ module Main where

2

3import Prelude

4

5−class Partial

5+class PartialP

6

7−head :: forall a. (Partial) => Array a -> a

7+head :: forall a. (PartialP) => Array a -> a

8head [x] = x

9

10−instance allowPartials :: Partial

10+instance allowPartials :: PartialP

11

12main = Control.Monad.Eff.Console.log $ head ["Done"]

examples/passing/NakedConstraint.purs−2

@@ -2,8 +2,6 @@ module Main where

2

3import Control.Monad.Eff.Console

4

5−class Partial

6−

7data List a = Nil | Cons a (List a)

5data List a = Nil | Cons a (List a)

8

6

9head :: (Partial) => List Int -> Int

7head :: (Partial) => List Int -> Int

examples/passing/NonConflictingExports.pursnew file+14

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

1+module A where

2+

3+ thing :: Int

4+ thing = 1

5+

6+-- No failure here as the export `thing` only refers to Main.thing

7+module Main (thing, main) where

8+

9+ import A

10+

11+ thing :: Int

12+ thing = 2

13+

14+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/OperatorAlias.pursnew file+11

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

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

6+infixl 4 what as ?!

7+

8+what :: forall a b. a -> b -> a

9+what a _ = a

10+

11+main = log $ "Done" ?! true

examples/passing/PendingConflictingImports.pursnew file+17

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

1+module A where

2+

3+ thing :: Int

4+ thing = 1

5+

6+module B where

7+

8+ thing :: Int

9+ thing = 2

10+

11+module Main where

12+

13+ -- No error as we never force `thing` to be resolved in `Main`

14+ import A

15+ import B

16+

17+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/PendingConflictingImports2.pursnew file+14

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

1+module A where

2+

3+ thing :: Int

4+ thing = 1

5+

6+module Main where

7+

8+ import A

9+

10+ -- No error as we never force `thing` to be resolved in `Main`

11+ thing :: Int

12+ thing = 2

13+

14+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/UnicodeOperators.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

2+

3+compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c

4+compose f g a = f (g a)

5+

6+infixr 9 compose as ∘

7+

8+test1 = (\x -> x) ∘ \y -> y

9+

10+elem :: forall a b. a -> (a -> Boolean) -> Boolean

11+elem x f = f x

12+

13+infixl 1 elem as ∈

14+

15+emptySet :: forall a. a -> Boolean

16+emptySet _ = true

17+

18+test2 = 1 ∈ emptySet

19+

20+main = Control.Monad.Eff.Console.log "Done"

examples/passing/UntupledConstraints.pursnew file+17

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

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

6+class Show a <= Nonsense a where

7+ method :: a -> a

8+

9+data Box a = Box a

10+

11+instance showBox :: Show a => Show (Box a) where

12+ show (Box a) = "Box " <> show a

13+

14+strangeThing :: forall m. Semigroup (m Unit) => m Unit -> m Unit -> m Unit

15+strangeThing x y = x <> y

16+

17+main = log "Done"

make_release_notesnew file+2

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

1+curl https://api.github.com/repos/purescript/purescript/pulls?state=closed\&per_page=100 \

2+ | jq -r '.[] | ("- " + .title + " (@" + .user.login + ")")'

psc/JSON.hsnew file+69

@@ -0,0 +1,69 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

5+-- License : MIT (http://opensource.org/licenses/MIT)

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE TemplateHaskell #-}

16+

17+module JSON where

18+

19+import Prelude ()

20+import Prelude.Compat

21+

22+import qualified Data.Aeson.TH as A

23+

24+import qualified Language.PureScript as P

25+

26+data ErrorPosition = ErrorPosition

27+ { startLine :: Int

28+ , startColumn :: Int

29+ , endLine :: Int

30+ , endColumn :: Int

31+ }

32+

33+data JSONError = JSONError

34+ { position :: Maybe ErrorPosition

35+ , message :: String

36+ , errorCode :: String

37+ , filename :: Maybe String

38+ , moduleName :: Maybe String

39+ }

40+

41+data JSONResult = JSONResult

42+ { warnings :: [JSONError]

43+ , errors :: [JSONError]

44+ }

45+

46+$(A.deriveJSON A.defaultOptions ''ErrorPosition)

47+$(A.deriveJSON A.defaultOptions ''JSONError)

48+$(A.deriveJSON A.defaultOptions ''JSONResult)

49+

50+toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]

51+toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors

52+

53+toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError

54+toJSONError verbose level e =

55+ JSONError (toErrorPosition <$> sspan)

56+ (P.renderBox (P.prettyPrintSingleError' verbose level (P.stripModuleAndSpan e)))

57+ (P.errorCode e)

58+ (P.spanName <$> sspan)

59+ (P.runModuleName <$> P.errorModule e)

60+ where

61+ sspan :: Maybe P.SourceSpan

62+ sspan = P.errorSpan e

63+

64+ toErrorPosition :: P.SourceSpan -> ErrorPosition

65+ toErrorPosition ss =

66+ ErrorPosition (P.sourcePosLine (P.spanStart ss))

67+ (P.sourcePosColumn (P.spanStart ss))

68+ (P.sourcePosLine (P.spanEnd ss))

69+ (P.sourcePosColumn (P.spanEnd ss))

psc/Main.hs+37−21

@@ -27,6 +27,9 @@ import Control.Monad.Writer.Strict

27import Data.List (isSuffixOf, partition)

28import Data.Version (showVersion)

29import qualified Data.Map as M

30+import qualified Data.Aeson as A

31+import qualified Data.ByteString.Lazy as B

32+import qualified Data.ByteString.UTF8 as BU8

30

33

31import Options.Applicative as Opts

34import Options.Applicative as Opts

32

35

@@ -40,45 +43,54 @@ import qualified Paths_purescript as Paths

40

43

41import Language.PureScript.Make

44import Language.PureScript.Make

42

45

46+import JSON

47+

43data PSCMakeOptions = PSCMakeOptions

48data PSCMakeOptions = PSCMakeOptions

44 { pscmInput :: [FilePath]

49 { pscmInput :: [FilePath]

45 , pscmForeignInput :: [FilePath]

50 , pscmForeignInput :: [FilePath]

46 , pscmOutputDir :: FilePath

51 , pscmOutputDir :: FilePath

47 , pscmOpts :: P.Options

52 , pscmOpts :: P.Options

48 , pscmUsePrefix :: Bool

53 , pscmUsePrefix :: Bool

54+ , pscmJSONErrors :: Bool

49 }

55 }

50

56

51data InputOptions = InputOptions

57data InputOptions = InputOptions

52 { ioInputFiles :: [FilePath]

58 { ioInputFiles :: [FilePath]

53 }

59 }

54

60

61+-- | Argumnets: verbose, use JSON, warnings, errors

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

63+printWarningsAndErrors verbose False warnings errors = do

64+ when (P.nonEmpty warnings) $

65+ hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)

66+ case errors of

67+ Left errs -> do

68+ hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)

69+ exitFailure

70+ Right _ -> return ()

71+printWarningsAndErrors verbose True warnings errors = do

72+ hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $

73+ JSONResult (toJSONErrors verbose P.Warning warnings)

74+ (either (toJSONErrors verbose P.Error) (const []) errors)

75+ either (const exitFailure) (const (return ())) errors

76+

55compile :: PSCMakeOptions -> IO ()

77compile :: PSCMakeOptions -> IO ()

56−compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do

78+compile PSCMakeOptions{..} = do

57− input <- globWarningOnMisses warnFileTypeNotFound inputGlob

79+ input <- globWarningOnMisses warnFileTypeNotFound pscmInput

58 when (null input) $ do

80 when (null input) $ do

59 hPutStrLn stderr "psc: No input files."

81 hPutStrLn stderr "psc: No input files."

60 exitFailure

82 exitFailure

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

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

62 moduleFiles <- readInput (InputOptions pursFiles)

84 moduleFiles <- readInput (InputOptions pursFiles)

63− inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob

85+ inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput

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

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

87+ (makeErrors, makeWarnings) <- runMake pscmOpts $ do

65− case runWriterT (parseInputs moduleFiles foreignFiles) of

88+ (ms, foreigns) <- parseInputs moduleFiles foreignFiles

66− Left errs -> do

67− hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

68− exitFailure

69− Right ((ms, foreigns), warnings) -> do

70− when (P.nonEmpty warnings) $

71− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

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

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

73− makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix

90+ makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix

74− (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)

91+ P.make makeActions (map snd ms)

75− when (P.nonEmpty warnings') $

92+ printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors

76− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')

77− case e of

78− Left errs -> do

79− hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

80− exitFailure

81− Right _ -> exitSuccess

93+ exitSuccess

82

94

83warnFileTypeNotFound :: String -> IO ()

95warnFileTypeNotFound :: String -> IO ()

84warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)

96warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)

@@ -161,6 +173,10 @@ noPrefix = switch $

161 <> long "no-prefix"

173 <> long "no-prefix"

162 <> help "Do not include comment header"

174 <> help "Do not include comment header"

163

175

176+jsonErrors :: Parser Bool

177+jsonErrors = switch $

178+ long "json-errors"

179+ <> help "Print errors to stderr as JSON"

164

180

165options :: Parser P.Options

181options :: Parser P.Options

166options = P.Options <$> noTco

182options = P.Options <$> noTco

@@ -177,7 +193,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile

177 <*> outputDirectory

193 <*> outputDirectory

178 <*> options

194 <*> options

179 <*> (not <$> noPrefix)

195 <*> (not <$> noPrefix)

180−

196+ <*> jsonErrors

181

197

182main :: IO ()

198main :: IO ()

183main = execParser opts >>= compile

199main = execParser opts >>= compile

psci/Completion.hs+1−1

@@ -171,7 +171,7 @@ getAllQualifications sho m (declName, decl) = do

171 qualificationsUsing (_, importType, asQ') =

172 let q = qualifyWith asQ'

173 in case importType of

174− P.Implicit -> [q]

174+ P.Implicit _ -> [q]

175 P.Explicit refs -> [q | referencedBy refs]

176 P.Hiding refs -> [q | not $ referencedBy refs]

177

psci/PSCi.hs+31−31

@@ -113,12 +113,12 @@ loadModule filename = do

113-- |

114-- Load all modules.

115--

116−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])

116+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

117loadAllModules files = do

118 filesAndContent <- forM files $ \filename -> do

119 content <- readFile filename

120− return (Right filename, content)

120+ return (filename, content)

121− return $ P.parseModulesFromFiles (either (const "") id) filesAndContent

121+ return $ P.parseModulesFromFiles id filesAndContent

122

123-- |

124-- Load all modules, updating the application state

@@ -129,7 +129,7 @@ loadAllImportedModules = do

129 modulesOrFirstError <- psciIO $ loadAllModules files

130 case modulesOrFirstError of

131 Left errs -> printErrors errs

132− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }

132+ Right modules -> PSCI . lift . modify $ updateModules modules

133

134-- |

135-- Expands tilde in path.

@@ -202,7 +202,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi

202 trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))

203 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

204 itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val

205− mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue

205+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue

206 decls = if exec then [itDecl, mainDecl] else [itDecl]

207 in

208 P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

@@ -248,26 +248,28 @@ makeIO f io = do

248 e <- liftIO $ tryIOError io

249 either (throwError . P.singleError . f) return e

250

251−make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment

251+make :: PSCiState -> [P.Module] -> P.Make P.Environment

252−make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))

252+make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)

253 where

254− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)

254+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules

255 actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False

256 actions' = actions { P.progress = const (return ()) }

257+ loadedModules = psciLoadedModules st

258+ allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

257

259

258-- |

260-- |

259−-- Takes a value declaration and evaluates it with the current state.

261+-- Takes a value expression and evaluates it with the current state.

260--

262--

261−handleDeclaration :: P.Expr -> PSCI ()

263+handleExpression :: P.Expr -> PSCI ()

262−handleDeclaration val = do

264+handleExpression val = do

263 st <- PSCI $ lift get

265 st <- PSCI $ lift get

264 let m = createTemporaryModule True st val

266 let m = createTemporaryModule True st val

265 let nodeArgs = psciNodeFlags st ++ [indexFile]

267 let nodeArgs = psciNodeFlags st ++ [indexFile]

266− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]

268+ e <- psciIO . runMake $ make st [supportModule, m]

267 case e of

269 case e of

268 Left errs -> printErrors errs

270 Left errs -> printErrors errs

269 Right _ -> do

271 Right _ -> do

270− psciIO $ writeFile indexFile "require('$PSCI').main();"

272+ psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

271 process <- psciIO findNodeProcess

273 process <- psciIO findNodeProcess

272 result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process

274 result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process

273 case result of

275 case result of

@@ -284,7 +286,7 @@ handleDecls ds = do

284 st <- PSCI $ lift get

286 st <- PSCI $ lift get

285 let st' = updateLets ds st

287 let st' = updateLets ds st

286 let m = createTemporaryModule False st' (P.ObjectLiteral [])

288 let m = createTemporaryModule False st' (P.ObjectLiteral [])

287− e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]

289+ e <- psciIO . runMake $ make st' [m]

288 case e of

290 case e of

289 Left err -> printErrors err

291 Left err -> printErrors err

290 Right _ -> PSCI $ lift (put st')

292 Right _ -> PSCI $ lift (put st')

@@ -294,7 +296,7 @@ handleDecls ds = do

294--

296--

295handleShowLoadedModules :: PSCI ()

297handleShowLoadedModules :: PSCI ()

296handleShowLoadedModules = do

298handleShowLoadedModules = do

297− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get

299+ loadedModules <- PSCI $ lift $ gets psciLoadedModules

298 psciIO $ readModules loadedModules >>= putStrLn

300 psciIO $ readModules loadedModules >>= putStrLn

299 return ()

301 return ()

300 where readModules = return . unlines . sort . nub . map toModuleName

302 where readModules = return . unlines . sort . nub . map toModuleName

@@ -315,10 +317,11 @@ handleShowImportedModules = do

315 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'

317 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'

316 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType

318 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType

317

319

318− showDeclType P.Implicit = ""

320+ showDeclType (P.Implicit True) = " (..)"

321+ showDeclType (P.Implicit False) = ""

319 showDeclType (P.Explicit refs) = refsList refs

322 showDeclType (P.Explicit refs) = refsList refs

320− showDeclType (P.Hiding refs) = "hiding " ++ refsList refs

323+ showDeclType (P.Hiding refs) = " hiding " ++ refsList refs

321− refsList refs = "(" ++ commaList (map showRef refs) ++ ")"

324+ refsList refs = " (" ++ commaList (map showRef refs) ++ ")"

322

325

323 showRef :: P.DeclarationRef -> String

326 showRef :: P.DeclarationRef -> String

324 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

327 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

@@ -339,7 +342,7 @@ handleImport :: ImportedModule -> PSCI ()

339handleImport im = do

342handleImport im = do

340 st <- updateImportedModules im <$> PSCI (lift get)

343 st <- updateImportedModules im <$> PSCI (lift get)

341 let m = createTemporaryModuleForImports st

344 let m = createTemporaryModuleForImports st

342− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

345+ e <- psciIO . runMake $ make st [m]

343 case e of

346 case e of

344 Left errs -> printErrors errs

347 Left errs -> printErrors errs

345 Right _ -> do

348 Right _ -> do

@@ -353,7 +356,7 @@ handleTypeOf :: P.Expr -> PSCI ()

353handleTypeOf val = do

356handleTypeOf val = do

354 st <- PSCI $ lift get

357 st <- PSCI $ lift get

355 let m = createTemporaryModule False st val

358 let m = createTemporaryModule False st val

356− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

359+ e <- psciIO . runMake $ make st [m]

357 case e of

360 case e of

358 Left errs -> printErrors errs

361 Left errs -> printErrors errs

359 Right env' ->

362 Right env' ->

@@ -490,7 +493,7 @@ handleKindOf typ = do

490 st <- PSCI $ lift get

493 st <- PSCI $ lift get

491 let m = createTemporaryModuleForKind st typ

494 let m = createTemporaryModuleForKind st typ

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

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

493− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

496+ e <- psciIO . runMake $ make st [m]

494 case e of

497 case e of

495 Left errs -> printErrors errs

498 Left errs -> printErrors errs

496 Right env' ->

499 Right env' ->

@@ -527,16 +530,15 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

527-- Performs an action for each meta-command given, and also for expressions.

530-- Performs an action for each meta-command given, and also for expressions.

528--

531--

529handleCommand :: Command -> PSCI ()

532handleCommand :: Command -> PSCI ()

530−handleCommand (Expression val) = handleDeclaration val

533+handleCommand (Expression val) = handleExpression val

531handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

534handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

532handleCommand (Import im) = handleImport im

535handleCommand (Import im) = handleImport im

533handleCommand (Decls l) = handleDecls l

536handleCommand (Decls l) = handleDecls l

534handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do

537handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do

535− PSCI . lift $ modify (updateImportedFiles absPath)

536 m <- psciIO $ loadModule absPath

538 m <- psciIO $ loadModule absPath

537 case m of

539 case m of

538 Left err -> PSCI $ outputStrLn err

540 Left err -> PSCI $ outputStrLn err

539− Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))

541+ Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))

540handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

542handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

541 foreignsOrError <- psciIO . runMake $ do

543 foreignsOrError <- psciIO . runMake $ do

542 foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

544 foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

@@ -545,12 +547,10 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

545 Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err

547 Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err

546 Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)

548 Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)

547handleCommand ResetState = do

549handleCommand ResetState = do

548− files <- psciImportedFilenames <$> PSCI (lift get)

549− PSCI . lift . modify $ \st -> st

550+ PSCI . lift . modify $ \st ->

550− { psciImportedFilenames = files

551− , psciImportedModules = []

551+ st { psciImportedModules = []

552− , psciLetBindings = []

552+ , psciLetBindings = []

553− }

553+ }

554 loadAllImportedModules

555handleCommand (TypeOf val) = handleTypeOf val

556handleCommand (KindOf typ) = handleKindOf typ

@@ -613,7 +613,7 @@ loop PSCiOptions{..} = do

613 case foreignsOrError of

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

615 Right foreigns ->

616− flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

616+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

617 outputStrLn prologueMessage

618 traverse_ (traverse_ (runPSCI . handleCommand)) config

619 modules' <- lift $ gets psciLoadedModules

psci/Types.hs+50−16

@@ -15,7 +15,9 @@

15

16module Types where

17

18+import Control.Arrow (second)

19+import Data.Map (Map)

18−import qualified Data.Map as M

20+import qualified Data.Map as Map

19import qualified Language.PureScript as P

21import qualified Language.PureScript as P

20

22

21data PSCiOptions = PSCiOptions

23data PSCiOptions = PSCiOptions

@@ -32,14 +34,48 @@ data PSCiOptions = PSCiOptions

32-- because it makes more sense to apply the binding to the final evaluated expression.

34-- because it makes more sense to apply the binding to the final evaluated expression.

33--

35--

34data PSCiState = PSCiState

36data PSCiState = PSCiState

35− { psciImportedFilenames :: [FilePath]

36− , psciImportedModules :: [ImportedModule]

37+ { psciImportedModules :: [ImportedModule]

37− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]

38+ , _psciLoadedModules :: Map FilePath [P.Module]

38− , psciForeignFiles :: M.Map P.ModuleName FilePath

39+ , psciForeignFiles :: Map P.ModuleName FilePath

39 , psciLetBindings :: [P.Declaration]

40 , psciLetBindings :: [P.Declaration]

40 , psciNodeFlags :: [String]

41 , psciNodeFlags :: [String]

41 }

42 }

42

43

44+initialPSCiState :: PSCiState

45+initialPSCiState =

46+ PSCiState [] Map.empty Map.empty [] []

47+

48+mkPSCiState :: [ImportedModule]

49+ -> [(FilePath, P.Module)]

50+ -> Map P.ModuleName FilePath

51+ -> [P.Declaration]

52+ -> [String]

53+ -> PSCiState

54+mkPSCiState imported loaded foreign lets nodeFlags =

55+ (initialPSCiState

56+ |> each imported updateImportedModules

57+ |> updateModules loaded)

58+ { psciForeignFiles = foreign

59+ , psciLetBindings = lets

60+ , psciNodeFlags = nodeFlags

61+ }

62+ where

63+ x |> f = f x

64+ each xs f st = foldl (flip f) st xs

65+

66+-- Public psci state accessors

67+

68+-- | Get the imported filenames as a list.

69+psciImportedFilenames :: PSCiState -> [FilePath]

70+psciImportedFilenames = Map.keys . _psciLoadedModules

71+

72+-- | Get the loaded modules as a list.

73+psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]

74+psciLoadedModules = collect . Map.toList . _psciLoadedModules

75+ where

76+ collect :: [(k, [v])] -> [(k, v)]

77+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]

78+

43-- | All of the data that is contained by an ImportDeclaration in the AST.

79-- | All of the data that is contained by an ImportDeclaration in the AST.

44-- That is:

80-- That is:

45--

81--

@@ -64,12 +100,6 @@ allImportsOf m (PSCiState{psciImportedModules = is}) =

64

100

65-- State helpers

101-- State helpers

66

102

67−-- |

68−-- Updates the state to have more imported modules.

69−--

70−updateImportedFiles :: FilePath -> PSCiState -> PSCiState

71−updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }

72−

73-- |

103-- |

74-- Updates the state to have more imported modules.

104-- Updates the state to have more imported modules.

75--

105--

@@ -77,10 +107,14 @@ updateImportedModules :: ImportedModule -> PSCiState -> PSCiState

77updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }

107updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }

78

108

79-- |

109-- |

80−-- Updates the state to have more loaded files.

110+-- Updates the state to have more loaded modules (available for import, but

111+-- not necessarily imported).

81--

112--

82−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState

113+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState

83−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }

114+updateModules modules st =

115+ st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }

116+ where

117+ go = Map.fromListWith (++) . map (second (:[]))

84

118

85-- |

119-- |

86-- Updates the state to have more let bindings.

120-- Updates the state to have more let bindings.

@@ -91,8 +125,8 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }

91-- |

125-- |

92-- Updates the state to have more let bindings.

126-- Updates the state to have more let bindings.

93--

127--

94−updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState

128+updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState

95−updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }

129+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }

96

130

97-- |

131-- |

98-- Valid Meta-commands for PSCI

132-- Valid Meta-commands for PSCI

psci/tests/Main.hs+3−3

@@ -141,11 +141,11 @@ getPSCiState = do

141 Left err ->

142 print err >> exitFailure

143 Right modules ->

144− let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]

144+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)]

145− in return (PSCiState [] imports modules foreigns [] [])

145+ in return (mkPSCiState imports modules foreigns [] [])

146

147controlMonadSTasST :: ImportedModule

148−controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))

148+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST"))

149 where

150 s = P.moduleNameFromString

151

purescript.cabal+9−4

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

1name: purescript

2−version: 0.7.6.1

2+version: 0.8.0.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -201,12 +201,15 @@ library

201 ghc-options: -Wall -O2

202

203executable psc

204+ build-depends: base >=4 && <5, base-compat >=0.6.0,

204− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

205+ containers -any, directory -any, filepath -any,

205 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

206 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

206− time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8

207+ time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,

208+ aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2

207 main-is: Main.hs

209 main-is: Main.hs

208 buildable: True

210 buildable: True

209 hs-source-dirs: psc

211 hs-source-dirs: psc

212+ other-modules: JSON

210 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

213 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

211

214

212executable psci

215executable psci

@@ -289,10 +292,12 @@ test-suite tests

289 build-depends: base >=4 && <5, containers -any, directory -any,

292 build-depends: base >=4 && <5, containers -any, directory -any,

290 filepath -any, mtl -any, parsec -any, purescript -any,

293 filepath -any, mtl -any, parsec -any, purescript -any,

291 transformers -any, process -any, transformers-compat -any, time -any,

294 transformers -any, process -any, transformers-compat -any, time -any,

295+ Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,

292− Glob -any, base-compat >=0.6.0

296+ base-compat -any

293 type: exitcode-stdio-1.0

297 type: exitcode-stdio-1.0

294 main-is: Main.hs

298 main-is: Main.hs

295 other-modules: TestsSetup

299 other-modules: TestsSetup

300+ TestPscPublish

296 buildable: True

301 buildable: True

297 hs-source-dirs: tests tests/common

302 hs-source-dirs: tests tests/common

298

303

src/Control/Monad/Supply/Class.hs+5−17

@@ -1,20 +1,8 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE MultiParamTypeClasses #-}

2−--

2+

3−-- Module : Control.Monad.Supply.Class

4−-- Copyright : (c) PureScript 2015

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

3-- |

12-- A class for monads supporting a supply of fresh names

4-- A class for monads supporting a supply of fresh names

13--

5--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE MultiParamTypeClasses #-}

17−

18module Control.Monad.Supply.Class where

6module Control.Monad.Supply.Class where

19

7

20import Control.Monad.Supply

8import Control.Monad.Supply

@@ -22,15 +10,15 @@ import Control.Monad.State

22

10

23class (Monad m) => MonadSupply m where

11class (Monad m) => MonadSupply m where

24 fresh :: m Integer

12 fresh :: m Integer

25−

13+

26instance (Monad m) => MonadSupply (SupplyT m) where

14instance (Monad m) => MonadSupply (SupplyT m) where

27 fresh = SupplyT $ do

15 fresh = SupplyT $ do

28 n <- get

16 n <- get

29 put (n + 1)

17 put (n + 1)

30 return n

18 return n

31−

19+

32instance (MonadSupply m) => MonadSupply (StateT s m) where

20instance (MonadSupply m) => MonadSupply (StateT s m) where

33 fresh = lift fresh

21 fresh = lift fresh

34

22

35freshName :: (MonadSupply m) => m String

23freshName :: (MonadSupply m) => m String

36−freshName = liftM (('_' :) . show) fresh

24+freshName = liftM (('$' :) . show) fresh

src/Language/PureScript/AST/Declarations.hs+22−4

@@ -41,6 +41,18 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla

41getModuleName :: Module -> ModuleName

42getModuleName (Module _ _ name _ _) = name

43

44+-- |

45+-- Add an import declaration for a module if it does not already explicitly import it.

46+--

47+addDefaultImport :: ModuleName -> Module -> Module

48+addDefaultImport toImport m@(Module ss coms mn decls exps) =

49+ if isExistingImport `any` decls || mn == toImport then m

50+ else Module ss coms mn (ImportDeclaration toImport (Implicit True) Nothing False : decls) exps

51+ where

52+ isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True

53+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

54+ isExistingImport _ = False

55+

44-- |

56-- |

45-- An item in a list of explicit imports or exports

57-- An item in a list of explicit imports or exports

46--

58--

@@ -118,9 +130,11 @@ findDuplicateRefs refs =

118--

130--

119data ImportDeclarationType

131data ImportDeclarationType

120 -- |

132 -- |

121− -- An import with no explicit list: `import M`

133+ -- An import with no explicit list: `import M`. The boolean signifies whether

134+ -- the import was imported with `(..)` or not. Without `(..)` a warning is

135+ -- raised for each member implicitly imported.

122 --

136 --

123− = Implicit

137+ = Implicit Bool

124 -- |

138 -- |

125 -- An import with an explicit list of references to import: `import M (foo)`

139 -- An import with an explicit list of references to import: `import M (foo)`

126 --

140 --

@@ -131,6 +145,10 @@ data ImportDeclarationType

131 | Hiding [DeclarationRef]

145 | Hiding [DeclarationRef]

132 deriving (Eq, Show, Read, D.Data, D.Typeable)

146 deriving (Eq, Show, Read, D.Data, D.Typeable)

133

147

148+isImplicit :: ImportDeclarationType -> Bool

149+isImplicit (Implicit _) = True

150+isImplicit _ = False

151+

134-- |

152-- |

135-- The data type of declarations

153-- The data type of declarations

136--

154--

@@ -168,9 +186,9 @@ data Declaration

168 --

186 --

169 | ExternDataDeclaration ProperName Kind

187 | ExternDataDeclaration ProperName Kind

170 -- |

188 -- |

171− -- A fixity declaration (fixity data, operator name)

189+ -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

172 --

190 --

173− | FixityDeclaration Fixity String

191+ | FixityDeclaration Fixity String (Maybe Ident)

174 -- |

192 -- |

175 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

193 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

176 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

194 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

src/Language/PureScript/AST/Exported.hs+1−1

@@ -112,7 +112,7 @@ isExported (Just exps) decl = any (matches decl) exps

112 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

113 matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

114 matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

115− matches (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident'

115+ matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident'

116 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

117 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

118 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

src/Language/PureScript/CodeGen/JS.hs+4−15

@@ -1,23 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.JS

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module generates code in the simplified Javascript intermediate representation from Purescript code

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE GADTs #-}

1{-# LANGUAGE GADTs #-}

17{-# LANGUAGE ViewPatterns #-}

2{-# LANGUAGE ViewPatterns #-}

18{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

19{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

20

5

6+-- |

7+-- This module generates code in the simplified Javascript intermediate representation from Purescript code

8+--

21module Language.PureScript.CodeGen.JS

9module Language.PureScript.CodeGen.JS

22 ( module AST

10 ( module AST

23 , module Common

11 , module Common

@@ -180,6 +168,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

180 accessor :: Ident -> JS -> JS

168 accessor :: Ident -> JS -> JS

181 accessor (Ident prop) = accessorString prop

169 accessor (Ident prop) = accessorString prop

182 accessor (Op op) = JSIndexer (JSStringLiteral op)

170 accessor (Op op) = JSIndexer (JSStringLiteral op)

171+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"

183

172

184 accessorString :: String -> JS -> JS

173 accessorString :: String -> JS -> JS

185 accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

174 accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

src/Language/PureScript/CodeGen/JS/Common.hs+165−115

@@ -1,25 +1,19 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.Common

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- Common code generation utility functions

2-- Common code generation utility functions

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.CodeGen.JS.Common where

4module Language.PureScript.CodeGen.JS.Common where

17

5

18import Data.Char

6import Data.Char

19import Data.List (intercalate)

7import Data.List (intercalate)

20

8

9+import Language.PureScript.Crash

21import Language.PureScript.Names

10import Language.PureScript.Names

22

11

12+moduleNameToJs :: ModuleName -> String

13+moduleNameToJs (ModuleName pns) =

14+ let name = intercalate "_" (runProperName `map` pns)

15+ in if nameIsJsBuiltIn name then "$$" ++ name else name

16+

23-- |

17-- |

24-- Convert an Ident into a valid Javascript identifier:

18-- Convert an Ident into a valid Javascript identifier:

25--

19--

@@ -30,9 +24,11 @@ import Language.PureScript.Names

30-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

24-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

31--

25--

32identToJs :: Ident -> String

26identToJs :: Ident -> String

33−identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

27+identToJs (Ident name)

28+ | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name

34−identToJs (Ident name) = concatMap identCharToString name

29+ | otherwise = concatMap identCharToString name

35identToJs (Op op) = concatMap identCharToString op

30identToJs (Op op) = concatMap identCharToString op

31+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

36

32

37-- |

33-- |

38-- Test if a string is a valid JS identifier without escaping.

34-- Test if a string is a valid JS identifier without escaping.

@@ -75,107 +71,161 @@ identCharToString c = '$' : show (ord c)

75--

71--

76nameIsJsReserved :: String -> Bool

72nameIsJsReserved :: String -> Bool

77nameIsJsReserved name =

73nameIsJsReserved name =

78− name `elem` [ "abstract"

74+ name `elem` jsAnyReserved

79− , "arguments"

80− , "boolean"

81− , "break"

82− , "byte"

83− , "case"

84− , "catch"

85− , "char"

86− , "class"

87− , "const"

88− , "continue"

89− , "debugger"

90− , "default"

91− , "delete"

92− , "do"

93− , "double"

94− , "else"

95− , "enum"

96− , "eval"

97− , "export"

98− , "extends"

99− , "final"

100− , "finally"

101− , "float"

102− , "for"

103− , "function"

104− , "goto"

105− , "if"

106− , "implements"

107− , "import"

108− , "in"

109− , "instanceof"

110− , "int"

111− , "interface"

112− , "let"

113− , "long"

114− , "native"

115− , "new"

116− , "null"

117− , "package"

118− , "private"

119− , "protected"

120− , "public"

121− , "return"

122− , "short"

123− , "static"

124− , "super"

125− , "switch"

126− , "synchronized"

127− , "this"

128− , "throw"

129− , "throws"

130− , "transient"

131− , "try"

132− , "typeof"

133− , "var"

134− , "void"

135− , "volatile"

136− , "while"

137− , "with"

138− , "yield" ] || properNameIsJsReserved name

139−

140−moduleNameToJs :: ModuleName -> String

141−moduleNameToJs (ModuleName pns) =

142− let name = intercalate "_" (runProperName `map` pns)

143− in if properNameIsJsReserved name then "$$" ++ name else name

144

75

145-- |

76-- |

146−-- Checks whether a proper name is reserved in Javascript.

77+-- Checks whether a name matches a built-in value in Javascript.

147--

78--

148−properNameIsJsReserved :: String -> Bool

79+nameIsJsBuiltIn :: String -> Bool

149−properNameIsJsReserved name =

80+nameIsJsBuiltIn name =

150− name `elem` [ "Infinity"

81+ elem name

151− , "NaN"

82+ [ "arguments"

152− , "Object"

83+ , "Array"

153− , "Function"

84+ , "ArrayBuffer"

154− , "Boolean"

85+ , "Boolean"

86+ , "DataView"

87+ , "Date"

88+ , "decodeURI"

89+ , "decodeURIComponent"

90+ , "encodeURI"

91+ , "encodeURIComponent"

155− , "Error"

92+ , "Error"

93+ , "escape"

94+ , "eval"

156− , "EvalError"

95+ , "EvalError"

157− , "InternalError"

96+ , "Float32Array"

97+ , "Float64Array"

98+ , "Function"

99+ , "Infinity"

100+ , "Int16Array"

101+ , "Int32Array"

102+ , "Int8Array"

103+ , "Intl"

104+ , "isFinite"

105+ , "isNaN"

106+ , "JSON"

107+ , "Map"

108+ , "Math"

109+ , "NaN"

110+ , "Number"

111+ , "Object"

112+ , "parseFloat"

113+ , "parseInt"

114+ , "Promise"

115+ , "Proxy"

158− , "RangeError"

116+ , "RangeError"

159− , "ReferenceError"

117+ , "ReferenceError"

118+ , "Reflect"

119+ , "RegExp"

120+ , "Set"

121+ , "SIMD"

122+ , "String"

123+ , "Symbol"

160− , "SyntaxError"

124+ , "SyntaxError"

161− , "TypeError"

125+ , "TypeError"

162− , "URIError"

126+ , "Uint16Array"

163− , "Number"

127+ , "Uint32Array"

164− , "Math"

165− , "Date"

166− , "String"

167− , "RegExp"

168− , "Array"

169− , "Int8Array"

170− , "Uint8Array"

128+ , "Uint8Array"

171− , "Uint8ClampedArray"

129+ , "Uint8ClampedArray"

172− , "Int16Array"

130+ , "undefined"

173− , "Uint16Array"

131+ , "unescape"

174− , "Int32Array"

132+ , "URIError"

175− , "Uint32Array"

133+ , "WeakMap"

176− , "Float32Array"

134+ , "WeakSet"

177− , "Float64Array"

135+ ]

178− , "ArrayBuffer"

136+

179− , "DataView"

137+jsAnyReserved :: [String]

180− , "JSON"

138+jsAnyReserved =

181− , "Intl" ]

139+ concat

140+ [ jsKeywords

141+ , jsSometimesReserved

142+ , jsFutureReserved

143+ , jsFutureReservedStrict

144+ , jsOldReserved

145+ , jsLiterals

146+ ]

147+

148+jsKeywords :: [String]

149+jsKeywords =

150+ [ "break"

151+ , "case"

152+ , "catch"

153+ , "class"

154+ , "const"

155+ , "continue"

156+ , "debugger"

157+ , "default"

158+ , "delete"

159+ , "do"

160+ , "else"

161+ , "export"

162+ , "extends"

163+ , "finally"

164+ , "for"

165+ , "function"

166+ , "if"

167+ , "import"

168+ , "in"

169+ , "instanceof"

170+ , "new"

171+ , "return"

172+ , "super"

173+ , "switch"

174+ , "this"

175+ , "throw"

176+ , "try"

177+ , "typeof"

178+ , "var"

179+ , "void"

180+ , "while"

181+ , "with"

182+ ]

183+

184+jsSometimesReserved :: [String]

185+jsSometimesReserved =

186+ [ "await"

187+ , "let"

188+ , "static"

189+ , "yield"

190+ ]

191+

192+jsFutureReserved :: [String]

193+jsFutureReserved =

194+ [ "enum" ]

195+

196+jsFutureReservedStrict :: [String]

197+jsFutureReservedStrict =

198+ [ "implements"

199+ , "interface"

200+ , "package"

201+ , "private"

202+ , "protected"

203+ , "public"

204+ ]

205+

206+jsOldReserved :: [String]

207+jsOldReserved =

208+ [ "abstract"

209+ , "boolean"

210+ , "byte"

211+ , "char"

212+ , "double"

213+ , "final"

214+ , "float"

215+ , "goto"

216+ , "int"

217+ , "long"

218+ , "native"

219+ , "short"

220+ , "synchronized"

221+ , "throws"

222+ , "transient"

223+ , "volatile"

224+ ]

225+

226+jsLiterals :: [String]

227+jsLiterals =

228+ [ "null"

229+ , "true"

230+ , "false"

231+ ]

src/Language/PureScript/CoreFn/Desugar.hs+3−14

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CoreFn.Desugar

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The AST -> CoreFn desugaring step

12−--

13−-----------------------------------------------------------------------------

14−

15module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

1module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

16

2

17import Data.Function (on)

3import Data.Function (on)

@@ -68,6 +54,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

68 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

54 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

69 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

55 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

70 [NonRec name (exprToCoreFn ss com Nothing e)]

56 [NonRec name (exprToCoreFn ss com Nothing e)]

57+ declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58+ let qname = Qualified (Just mn) alias

59+ in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]

71 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

60 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

72 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

61 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

73 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

62 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

src/Language/PureScript/Docs/AsMarkdown.hs+5−3

@@ -45,7 +45,7 @@ declAsMarkdown decl@Declaration{..} = do

45 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

46 spacer

47

48− for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

48+ for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)

49

50 for_ declComments tell'

51

@@ -68,9 +68,11 @@ codeToString = outputWith elemAsMarkdown

68 elemAsMarkdown (Keyword x) = x

69 elemAsMarkdown Space = " "

70

71−fixityAsMarkdown :: P.Fixity -> Docs

71+fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) =

72+fixityAsMarkdown (P.Fixity associativity precedence) alias =

73+ -- TODO: link alias name to member

73 tell' $ concat [ "_"

74 tell' $ concat [ "_"

75+ , maybe "" (\i -> "alias for " ++ i ++ " - ") alias

74 , associativityStr

76 , associativityStr

75 , " / precedence "

77 , " / precedence "

76 , show precedence

78 , show precedence

src/Language/PureScript/Docs/Convert.hs+11−8

@@ -11,6 +11,9 @@ module Language.PureScript.Docs.Convert

11 , collectBookmarks

12 ) where

13

14+import Prelude ()

15+import Prelude.Compat

16+

14import Control.Monad

17import Control.Monad

15import Control.Category ((>>>))

18import Control.Category ((>>>))

16import Data.Either

19import Data.Either

@@ -68,7 +71,7 @@ type IntermediateDeclaration

68-- with their associativity and precedence.

71-- with their associativity and precedence.

69data DeclarationAugment

72data DeclarationAugment

70 = AugmentChild ChildDeclaration

73 = AugmentChild ChildDeclaration

71− | AugmentFixity P.Fixity

74+ | AugmentFixity P.Fixity (Maybe P.Ident)

72

75

73-- | Augment top-level declarations; the second pass. See the comments under

76-- | Augment top-level declarations; the second pass. See the comments under

74-- the type synonym IntermediateDeclaration for more information.

77-- the type synonym IntermediateDeclaration for more information.

@@ -86,18 +89,18 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

86 case a of

89 case a of

87 AugmentChild child ->

90 AugmentChild child ->

88 d { declChildren = declChildren d ++ [child] }

91 d { declChildren = declChildren d ++ [child] }

89− AugmentFixity fixity ->

92+ AugmentFixity fixity alias ->

90− d { declFixity = Just fixity }

93+ d { declFixity = Just (fixity, P.runIdent <$> alias) }

91

94

92-- | Add the default operator fixity for operators which do not have associated

95-- | Add the default operator fixity for operators which do not have associated

93-- fixity declarations.

96-- fixity declarations.

94--

97--

95-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

98-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

96−-- in 0.8.

99+-- in 0.9.

97addDefaultFixity :: Declaration -> Declaration

100addDefaultFixity :: Declaration -> Declaration

98addDefaultFixity decl@Declaration{..}

101addDefaultFixity decl@Declaration{..}

99 | isOp declTitle && isNothing declFixity =

102 | isOp declTitle && isNothing declFixity =

100− decl { declFixity = Just defaultFixity }

103+ decl { declFixity = Just (defaultFixity, Nothing) }

101 | otherwise =

104 | otherwise =

102 decl

105 decl

103 where

106 where

@@ -113,7 +116,7 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProper

113getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

116getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

114getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

117getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

115getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

118getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

116−getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")

119+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

117getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

120getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

118getDeclarationTitle _ = Nothing

121getDeclarationTitle _ = Nothing

119

122

@@ -170,8 +173,8 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

170

173

171 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

174 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

172 classApp = foldl P.TypeApp (P.TypeConstructor className) tys

175 classApp = foldl P.TypeApp (P.TypeConstructor className) tys

173−convertDeclaration (P.FixityDeclaration fixity _) title =

176+convertDeclaration (P.FixityDeclaration fixity _ alias) title =

174− Just (Left ([title], AugmentFixity fixity))

177+ Just (Left ([title], AugmentFixity fixity alias))

175convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

178convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

176 fmap (addComments . addSourceSpan) (convertDeclaration d' title)

179 fmap (addComments . addSourceSpan) (convertDeclaration d' title)

177 where

180 where

src/Language/PureScript/Docs/ParseAndDesugar.hs+1−10

@@ -105,17 +105,8 @@ fileInfoToString :: FileInfo -> FilePath

105fileInfoToString (Local fn) = fn

106fileInfoToString (FromDep _ fn) = fn

107

108−addDefaultImport :: P.ModuleName -> P.Module -> P.Module

109−addDefaultImport toImport m@(P.Module ss coms mn decls exps) =

110− if isExistingImport `any` decls || mn == toImport then m

111− else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing False : decls) exps

112− where

113− isExistingImport (P.ImportDeclaration mn' _ _ _) | mn' == toImport = True

114− isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d

115− isExistingImport _ = False

116−

117importPrim :: P.Module -> P.Module

108importPrim :: P.Module -> P.Module

118−importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])

109+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

119

110

120desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

111desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

121desugar = P.evalSupplyT 0 . desugar'

112desugar = P.evalSupplyT 0 . desugar'

src/Language/PureScript/Docs/Types.hs+7−4

@@ -84,7 +84,7 @@ data Declaration = Declaration

84 , declComments :: Maybe String

85 , declSourceSpan :: Maybe P.SourceSpan

86 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe P.Fixity

87+ , declFixity :: Maybe (P.Fixity, Maybe String)

88 , declInfo :: DeclarationInfo

89 }

90 deriving (Show, Eq, Ord)

@@ -307,9 +307,12 @@ asDeclaration =

307 <*> key "fixity" (perhaps asFixity)

308 <*> key "info" asDeclarationInfo

309

310−asFixity :: Parse PackageError P.Fixity

310+asFixity :: Parse PackageError (P.Fixity, Maybe String)

311+asFixity = do

311−asFixity = P.Fixity <$> key "associativity" asAssociativity

312+ fixity <- P.Fixity <$> key "associativity" asAssociativity

312− <*> key "precedence" asIntegral

313+ <*> key "precedence" asIntegral

314+ alias <- keyMay "alias" asString

315+ return (fixity, alias)

313

316

314parseAssociativity :: String -> Maybe P.Associativity

317parseAssociativity :: String -> Maybe P.Associativity

315parseAssociativity str = case str of

318parseAssociativity str = case str of

src/Language/PureScript/Environment.hs+25−10

@@ -66,7 +66,7 @@ data Environment = Environment {

66-- The initial environment with no values and only the default javascript types defined

67--

68initEnvironment :: Environment

69−initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty

69+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

70

71-- |

72-- The visibility of a name in scope

@@ -236,17 +236,32 @@ function :: Type -> Type -> Type

236function t1 = TypeApp (TypeApp tyFunction t1)

237

238-- |

239−-- The primitive types in the external javascript environment with their associated kinds.

239+-- The primitive types in the external javascript environment with their

240+-- associated kinds. There is also a pseudo `Partial` type that corresponds to

241+-- the class with the same name.

240--

242--

241primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

243primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

244+primTypes =

245+ M.fromList

242−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))

246+ [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

243− , (primName "Array" , (FunKind Star Star, ExternData))

247+ , (primName "Array", (FunKind Star Star, ExternData))

244− , (primName "Object" , (FunKind (Row Star) Star, ExternData))

248+ , (primName "Object", (FunKind (Row Star) Star, ExternData))

245− , (primName "String" , (Star, ExternData))

249+ , (primName "String", (Star, ExternData))

246− , (primName "Char" , (Star, ExternData))

250+ , (primName "Char", (Star, ExternData))

247− , (primName "Number" , (Star, ExternData))

251+ , (primName "Number", (Star, ExternData))

248− , (primName "Int" , (Star, ExternData))

252+ , (primName "Int", (Star, ExternData))

249− , (primName "Boolean" , (Star, ExternData)) ]

253+ , (primName "Boolean", (Star, ExternData))

254+ , (primName "Partial", (Star, ExternData))

255+ ]

256+

257+-- |

258+-- The primitive class map. This just contains to `Partial` class, used as a

259+-- kind of magic constraint for partial functions.

260+--

261+primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

262+primClasses =

263+ M.fromList

264+ [ (primName "Partial", ([], [], [])) ]

250

265

251-- |

266-- |

252-- Finds information about data constructors from the current environment.

267-- Finds information about data constructors from the current environment.

src/Language/PureScript/Errors.hs+69−19

@@ -67,8 +67,7 @@ data SimpleErrorMessage

67 | UnknownExportModule ModuleName

68 | UnknownImportDataConstructor ModuleName ProperName ProperName

69 | UnknownExportDataConstructor ProperName ProperName

70− | ConflictingImport String ModuleName

71− | ConflictingImports String ModuleName ModuleName

70+ | ScopeConflict String [ModuleName]

72 | ConflictingTypeDecls ProperName

71 | ConflictingTypeDecls ProperName

73 | ConflictingCtorDecls ProperName

72 | ConflictingCtorDecls ProperName

74 | TypeConflictsWithClass ProperName

73 | TypeConflictsWithClass ProperName

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

128 | UnusedExplicitImport ModuleName [String]

127 | UnusedExplicitImport ModuleName [String]

129 | UnusedDctorImport ProperName

128 | UnusedDctorImport ProperName

130 | UnusedDctorExplicitImport ProperName [ProperName]

129 | UnusedDctorExplicitImport ProperName [ProperName]

130+ | DeprecatedOperatorDecl String

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132 | DeprecatedClassImport ModuleName ProperName

133 | DeprecatedClassExport ProperName

@@ -138,6 +138,8 @@ data SimpleErrorMessage

138 | DuplicateExportRef String

139 | IntOutOfRange Integer String Integer Integer

140 | RedundantEmptyHidingImport ModuleName

141+ | ImplicitImport ModuleName [DeclarationRef]

142+ | CaseBinderLengthDiffers Int [Binder]

141 deriving (Show)

143 deriving (Show)

142

144

143-- | Error message hints, providing more detailed information about failure.

145-- | Error message hints, providing more detailed information about failure.

@@ -175,6 +177,31 @@ data HintCategory

175

177

176data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

178data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

177

179

180+-- | Get the source span for an error

181+errorSpan :: ErrorMessage -> Maybe SourceSpan

182+errorSpan = findHint matchSpan

183+ where

184+ matchSpan (PositionedError ss) = Just ss

185+ matchSpan _ = Nothing

186+

187+-- | Get the module name for an error

188+errorModule :: ErrorMessage -> Maybe ModuleName

189+errorModule = findHint matchModule

190+ where

191+ matchModule (ErrorInModule mn) = Just mn

192+ matchModule _ = Nothing

193+

194+findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a

195+findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints

196+

197+-- | Remove the module name and span hints from an error

198+stripModuleAndSpan :: ErrorMessage -> ErrorMessage

199+stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e

200+ where

201+ shouldStrip (ErrorInModule _) = True

202+ shouldStrip (PositionedError _) = True

203+ shouldStrip _ = False

204+

178-- |

205-- |

179-- Get the error code for a particular error type

206-- Get the error code for a particular error type

180--

207--

@@ -211,8 +238,7 @@ errorCode em = case unwrapErrorMessage em of

211 UnknownExportModule{} -> "UnknownExportModule"

238 UnknownExportModule{} -> "UnknownExportModule"

212 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

239 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

213 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

240 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

214− ConflictingImport{} -> "ConflictingImport"

241+ ScopeConflict{} -> "ScopeConflict"

215− ConflictingImports{} -> "ConflictingImports"

216 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

242 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

217 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

243 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

218 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

244 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

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

272 UnusedExplicitImport{} -> "UnusedExplicitImport"

298 UnusedExplicitImport{} -> "UnusedExplicitImport"

273 UnusedDctorImport{} -> "UnusedDctorImport"

299 UnusedDctorImport{} -> "UnusedDctorImport"

274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

300 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

301+ DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

275 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

302 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

276 DeprecatedClassImport{} -> "DeprecatedClassImport"

303 DeprecatedClassImport{} -> "DeprecatedClassImport"

277 DeprecatedClassExport{} -> "DeprecatedClassExport"

304 DeprecatedClassExport{} -> "DeprecatedClassExport"

@@ -282,7 +309,8 @@ errorCode em = case unwrapErrorMessage em of

282 DuplicateExportRef{} -> "DuplicateExportRef"

309 DuplicateExportRef{} -> "DuplicateExportRef"

283 IntOutOfRange{} -> "IntOutOfRange"

310 IntOutOfRange{} -> "IntOutOfRange"

284 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

311 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

285−

312+ ImplicitImport{} -> "ImplicitImport"

313+ CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

286

314

287-- |

315-- |

288-- A stack trace for an error

316-- A stack trace for an error

@@ -300,7 +328,6 @@ nonEmpty = not . null . runMultipleErrors

300errorMessage :: SimpleErrorMessage -> MultipleErrors

328errorMessage :: SimpleErrorMessage -> MultipleErrors

301errorMessage err = MultipleErrors [ErrorMessage [] err]

329errorMessage err = MultipleErrors [ErrorMessage [] err]

302

330

303−

304-- |

331-- |

305-- Create an error set from a single error message

332-- Create an error set from a single error message

306--

333--

@@ -385,6 +412,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

385 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

412 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

386 gHint other = pure other

413 gHint other = pure other

387

414

415+prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box

416+prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level

417+

388-- |

418-- |

389-- Pretty print a single error, simplifying if necessary

419-- Pretty print a single error, simplifying if necessary

390--

420--

@@ -522,13 +552,10 @@ prettyPrintSingleError full level e = do

522 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

552 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

523 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

553 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

524 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

554 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

525− renderSimpleErrorMessage (ConflictingImport nm mn) =

555+ renderSimpleErrorMessage (ScopeConflict nm ms) =

526− paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn

556+ paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"

527− , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"

528− , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"

557+ , indent $ paras $ map (line . runModuleName) ms

529 ]

558 ]

530− renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

531− line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

532 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

559 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

533 line $ "Conflicting type declarations for " ++ runProperName nm

560 line $ "Conflicting type declarations for " ++ runProperName nm

534 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

561 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

@@ -715,8 +742,9 @@ prettyPrintSingleError full level e = do

715 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

742 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

716 ]

743 ]

717 renderSimpleErrorMessage (TransitiveExportError x ys) =

744 renderSimpleErrorMessage (TransitiveExportError x ys) =

718− paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

745+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "

719− : map (line . prettyPrintExport) ys

746+ , indent $ paras $ map (line . prettyPrintExport) ys

747+ ]

720 renderSimpleErrorMessage (ShadowedName nm) =

748 renderSimpleErrorMessage (ShadowedName nm) =

721 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

749 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

722 renderSimpleErrorMessage (ShadowedTypeVar tv) =

750 renderSimpleErrorMessage (ShadowedTypeVar tv) =

@@ -747,9 +775,12 @@ prettyPrintSingleError full level e = do

747 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

775 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

748 paras $ [ line "A case expression could not be determined to cover all inputs."

776 paras $ [ line "A case expression could not be determined to cover all inputs."

749 , line "The following additional cases are required to cover all inputs:\n"

777 , line "The following additional cases are required to cover all inputs:\n"

778+ , indent $ paras $

750− , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

779+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

751− ] ++

752− [ line "..." | not b ]

780+ ++ [ line "..." | not b ]

781+ , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

782+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

783+ ]

753 renderSimpleErrorMessage (OverlappingPattern bs b) =

784 renderSimpleErrorMessage (OverlappingPattern bs b) =

754 paras $ [ line "A case expression contains unreachable cases:\n"

785 paras $ [ line "A case expression contains unreachable cases:\n"

755 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

786 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

@@ -773,6 +804,13 @@ prettyPrintSingleError full level e = do

773 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

804 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

774 , indent $ paras $ map (line .runProperName) names ]

805 , indent $ paras $ map (line .runProperName) names ]

775

806

807+ renderSimpleErrorMessage (DeprecatedOperatorDecl name) =

808+ paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

809+ , line "Operator aliases are declared by using a fixity declaration, for example:"

810+ , indent $ line $ "infixl 9 someFunction as " ++ name

811+ , line $ "Support for value-declared operators will be removed in PureScript 0.9."

812+ ]

813+

776 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

814 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

777 paras [ line $ "Import uses the deprecated 'qualified' syntax:"

815 paras [ line $ "Import uses the deprecated 'qualified' syntax:"

778 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

816 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

@@ -819,6 +857,16 @@ prettyPrintSingleError full level e = do

819 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

857 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

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

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

821

859

860+ renderSimpleErrorMessage (ImplicitImport mn refs) =

861+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "

862+ , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

863+ ]

864+

865+ renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

866+ paras $ [ line $ "Binder list length differs in case alternative:"

867+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

868+ , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]

869+

822 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

870 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

823 renderHint (ErrorUnifyingTypes t1 t2) detail =

871 renderHint (ErrorUnifyingTypes t1 t2) detail =

824 paras [ detail

872 paras [ detail

@@ -954,9 +1002,10 @@ prettyPrintSingleError full level e = do

954

1002

955 prettyPrintRef :: DeclarationRef -> String

1003 prettyPrintRef :: DeclarationRef -> String

956 prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1004 prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1005+ prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

957 prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1006 prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

958 prettyPrintRef (ValueRef ident) = showIdent ident

1007 prettyPrintRef (ValueRef ident) = showIdent ident

959− prettyPrintRef (TypeClassRef pn) = runProperName pn

1008+ prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

960 prettyPrintRef (ProperRef pn) = runProperName pn

1009 prettyPrintRef (ProperRef pn) = runProperName pn

961 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1010 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

962 prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

1011 prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

@@ -965,7 +1014,8 @@ prettyPrintSingleError full level e = do

965 prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1014 prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

966 prettyPrintImport mn idt qual =

1015 prettyPrintImport mn idt qual =

967 let i = case idt of

1016 let i = case idt of

1017+ Implicit True -> runModuleName mn ++ " (..)"

968− Implicit -> runModuleName mn

1018+ Implicit False -> runModuleName mn

969 Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

1019 Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

970 Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

1020 Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

971 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1021 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

src/Language/PureScript/Externs.hs+6−16

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Externs

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

17{-# LANGUAGE PatternGuards #-}

2{-# LANGUAGE PatternGuards #-}

18{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

19

4

5+-- |

6+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

7+--

20module Language.PureScript.Externs

8module Language.PureScript.Externs

21 ( ExternsFile(..)

9 ( ExternsFile(..)

22 , ExternsImport(..)

10 , ExternsImport(..)

@@ -84,6 +72,8 @@ data ExternsFixity = ExternsFixity

84 , efPrecedence :: Precedence

72 , efPrecedence :: Precedence

85 -- | The operator symbol

73 -- | The operator symbol

86 , efOperator :: String

74 , efOperator :: String

75+ -- | The value the operator is an alias for

76+ , efAlias :: Maybe Ident

87 } deriving (Show, Read)

77 } deriving (Show, Read)

88

78

89-- | A type or value declaration appearing in an externs file

79-- | A type or value declaration appearing in an externs file

@@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

163 efDeclarations = concatMap toExternsDeclaration efExports

153 efDeclarations = concatMap toExternsDeclaration efExports

164

154

165 fixityDecl :: Declaration -> Maybe ExternsFixity

155 fixityDecl :: Declaration -> Maybe ExternsFixity

166− fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)

156+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

167 where

157 where

168 exportsOp :: DeclarationRef -> Bool

158 exportsOp :: DeclarationRef -> Bool

169 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

159 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

src/Language/PureScript/Linter.hs+6−16

@@ -1,21 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Linter

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | This module implements a simple linting pass on the PureScript AST.

12−--

13−-----------------------------------------------------------------------------

14−

15{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE PatternGuards #-}

3{-# LANGUAGE PatternGuards #-}

18

4

5+-- |

6+-- This module implements a simple linting pass on the PureScript AST.

7+--

19module Language.PureScript.Linter (lint, module L) where

8module Language.PureScript.Linter (lint, module L) where

20

9

21import Prelude ()

10import Prelude ()

@@ -66,11 +55,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

66 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

55 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

67

56

68 stepD :: S.Set Ident -> Declaration -> MultipleErrors

57 stepD :: S.Set Ident -> Declaration -> MultipleErrors

58+ stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)

69− stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls

59+ stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls

70 where

60 where

71 go :: Declaration -> MultipleErrors

61 go :: Declaration -> MultipleErrors

72 go (PositionedDeclaration _ _ d') = go d'

62 go (PositionedDeclaration _ _ d') = go d'

73− go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op)

63+ go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)

74 go _ = mempty

64 go _ = mempty

75 stepD _ _ = mempty

65 stepD _ _ = mempty

76

66

src/Language/PureScript/Linter/Exhaustive.hs+41−30

@@ -19,10 +19,7 @@

19{-# LANGUAGE FlexibleContexts #-}

20{-# LANGUAGE ScopedTypeVariables #-}

21

22−module Language.PureScript.Linter.Exhaustive

22+module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

23− ( checkExhaustive

24− , checkExhaustiveModule

25− ) where

26

23

27import Prelude ()

24import Prelude ()

28import Prelude.Compat

25import Prelude.Compat

@@ -48,7 +45,7 @@ import Language.PureScript.Errors

48

45

49-- | There are two modes of failure for the redudancy check:

46-- | There are two modes of failure for the redudancy check:

50--

47--

51−-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.

48+-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.

52-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

49-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

53--

50--

54-- We want to warn the user in the first case.

51-- We want to warn the user in the first case.

@@ -239,8 +236,8 @@ missingAlternative env mn ca uncovered

239-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.

236-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.

240-- Then, returns the uncovered set of case alternatives.

237-- Then, returns the uncovered set of case alternatives.

241--

238--

242−checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

239+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

243−checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

240+checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

244 where

241 where

245 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

242 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

246 step (uncovered, (nec, redundant)) ca =

243 step (uncovered, (nec, redundant)) ca =

@@ -258,13 +255,13 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init

258

255

259 makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

256 makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

260 makeResult (bss, (rr, bss')) =

257 makeResult (bss, (rr, bss')) =

261− do unless (null bss) tellExhaustive

258+ do unless (hasConstraint || null bss) tellNonExhaustive

262 unless (null bss') tellRedundant

259 unless (null bss') tellRedundant

263 case rr of

260 case rr of

264− Left Incomplete -> tellIncomplete

261+ Left Incomplete -> unless hasConstraint tellIncomplete

265 _ -> return ()

262 _ -> return ()

266 where

263 where

267− tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

264+ tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

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

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

269 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

266 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

270

267

@@ -279,29 +276,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl

279 where

276 where

280 convert :: (Ident, NameKind, Expr) -> Declaration

277 convert :: (Ident, NameKind, Expr) -> Declaration

281 convert (name, nk, e) = ValueDeclaration name nk [] (Right e)

278 convert (name, nk, e) = ValueDeclaration name nk [] (Right e)

282− onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)

279+ onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)

283 onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)

280 onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)

284 onDecl _ = return ()

281 onDecl _ = return ()

285

282

286− onExpr :: Expr -> m ()

283+ onExpr :: Bool -> Expr -> m ()

287− onExpr (UnaryMinus e) = onExpr e

284+ onExpr isP (UnaryMinus e) = onExpr isP e

288− onExpr (ArrayLiteral es) = mapM_ onExpr es

285+ onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es

289− onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es

286+ onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es

290− onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e

287+ onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

291− onExpr (Accessor _ e) = onExpr e

288+ onExpr isP (Accessor _ e) = onExpr isP e

292− onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es

289+ onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

293− onExpr (Abs _ e) = onExpr e

290+ onExpr isP (Abs _ e) = onExpr isP e

294− onExpr (App e1 e2) = onExpr e1 >> onExpr e2

291+ onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2

295− onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3

292+ onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3

296− onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas

293+ onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas

297− onExpr (TypedValue _ e _) = onExpr e

294+ onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e

298− onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e

295+ onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e

299− onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)

296+ onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)

300− onExpr _ = return ()

297+ onExpr _ _ = return ()

301−

298+

302− onCaseAlternative :: CaseAlternative -> m ()

299+ onCaseAlternative :: Bool -> CaseAlternative -> m ()

303− onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es

300+ onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es

304− onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e

301+ onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e

302+

303+ hasPartialConstraint :: Type -> Bool

304+ hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

305+ where

306+ go :: Qualified ProperName -> Bool

307+ go qname

308+ | qname == partialClass = True

309+ | otherwise =

310+ case qname `M.lookup` typeClasses env of

311+ Just ([], _, cs') -> any (go . fst) cs'

312+ _ -> False

313+ partialClass :: Qualified ProperName

314+ partialClass = primName "Partial"

315+ hasPartialConstraint _ = False

305

316

306-- |

317-- |

307-- Exhaustivity checking over a single module

318-- Exhaustivity checking over a single module

src/Language/PureScript/Linter/Imports.hs+40−2

@@ -16,6 +16,7 @@ import Data.Foldable (forM_)

16

17import Language.PureScript.AST.Declarations

18import Language.PureScript.AST.SourcePos

19+import Language.PureScript.Crash

19import Language.PureScript.Names as P

20import Language.PureScript.Names as P

20

21

21import Language.PureScript.Errors

22import Language.PureScript.Errors

@@ -30,6 +31,19 @@ data Name

30 | TypeName (Qualified ProperName)

31 | TypeName (Qualified ProperName)

31 | DctorName (Qualified ProperName)

32 | DctorName (Qualified ProperName)

32 | ClassName (Qualified ProperName)

33 | ClassName (Qualified ProperName)

34+ deriving (Eq)

35+

36+getIdentName :: Name -> Maybe Ident

37+getIdentName (IdentName (Qualified _ name)) = Just name

38+getIdentName _ = Nothing

39+

40+getTypeName :: Name -> Maybe ProperName

41+getTypeName (TypeName (Qualified _ name)) = Just name

42+getTypeName _ = Nothing

43+

44+getClassName :: Name -> Maybe ProperName

45+getClassName (ClassName (Qualified _ name)) = Just name

46+getClassName _ = Nothing

33

47

34-- | Map of module name to list of imported names from that module which have been used.

48-- | Map of module name to list of imported names from that module which have been used.

35type UsedImports = M.Map ModuleName [Name]

49type UsedImports = M.Map ModuleName [Name]

@@ -44,11 +58,21 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

44 forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

58 forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

45 forM_ decls $ \(ss, declType, qualifierName) ->

59 forM_ decls $ \(ss, declType, qualifierName) ->

46 censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

60 censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

47− let names = sugarNames mni ++ M.findWithDefault [] mni usedImps

61+ let names = nub $ sugarNames mni ++ M.findWithDefault [] mni usedImps

48 usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

62 usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

49 usedDctors = mapMaybe (matchDctor qualifierName) names

63 usedDctors = mapMaybe (matchDctor qualifierName) names

50 in case declType of

64 in case declType of

51− Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni

65+ Implicit _ | null usedNames -> tell $ errorMessage $ UnusedImport mni

66+ Implicit False ->

67+ let classRefs = TypeClassRef <$> mapMaybe getClassName names

68+ valueRefs = ValueRef <$> mapMaybe getIdentName names

69+ types = mapMaybe getTypeName names

70+ typesWithDctors = reconstructTypeRefs mni usedDctors

71+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

72+ typesRefs

73+ = map (flip TypeRef (Just [])) typesWithoutDctors

74+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

75+ in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs)

52 Explicit declrefs -> do

76 Explicit declrefs -> do

53 let idents = nub (mapMaybe runDeclRef declrefs)

77 let idents = nub (mapMaybe runDeclRef declrefs)

54 let diff = idents \\ usedNames

78 let diff = idents \\ usedNames

@@ -76,6 +100,20 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

76 sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]

100 sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]

77 sugarNames _ = []

101 sugarNames _ = []

78

102

103+ reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]

104+ reconstructTypeRefs mni = foldr accumDctors M.empty

105+ where

106+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

107+

108+ findTypeForDctor :: ModuleName -> ProperName -> ProperName

109+ findTypeForDctor mn dctor =

110+ case mn `M.lookup` env of

111+ Just (_, _, exps) ->

112+ case find (elem dctor . snd . fst) (exportedTypes exps) of

113+ Just ((ty, _), _) -> ty

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

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

116+

79 -- rely on exports being elaborated by this point

117 -- rely on exports being elaborated by this point

80 alwaysUsedModules :: [ ModuleName ]

118 alwaysUsedModules :: [ ModuleName ]

81 alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

119 alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

src/Language/PureScript/Make.hs+3−28

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Make

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

15{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

16{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

@@ -225,8 +211,9 @@ make MakeActions{..} ms = do

225 progress $ CompilingModule moduleName

211 progress $ CompilingModule moduleName

226 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

212 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

227 lint m

213 lint m

228− ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]

214+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do

215+ [desugared] <- desugar externs [m]

229− (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared

216+ runCheck' env $ typeCheckModule desugared

230 checkExhaustiveModule env' checked

217 checkExhaustiveModule env' checked

231 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

218 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

232 let mod' = Module ss coms moduleName regrouped exps

219 let mod' = Module ss coms moduleName regrouped exps

@@ -266,18 +253,6 @@ make MakeActions{..} ms = do

266 guard $ efVersion externs == showVersion Paths.version

253 guard $ efVersion externs == showVersion Paths.version

267 return externs

254 return externs

268

255

269−-- |

270−-- Add an import declaration for a module if it does not already explicitly import it.

271−--

272−addDefaultImport :: ModuleName -> Module -> Module

273−addDefaultImport toImport m@(Module ss coms mn decls exps) =

274− if isExistingImport `any` decls || mn == toImport then m

275− else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps

276− where

277− isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True

278− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

279− isExistingImport _ = False

280−

281importPrim :: Module -> Module

256importPrim :: Module -> Module

282importPrim = addDefaultImport (ModuleName [ProperName C.prim])

257importPrim = addDefaultImport (ModuleName [ProperName C.prim])

283

258

src/Language/PureScript/Names.hs+20−17

@@ -1,25 +1,16 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Names

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Data types for names

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

17{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

18{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

19{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

20

5

6+-- |

7+-- Data types for names

8+--

21module Language.PureScript.Names where

9module Language.PureScript.Names where

22

10

11+import Control.Monad (liftM)

12+import Control.Monad.Supply.Class

13+

23import Data.List

14import Data.List

24import Data.Data

15import Data.Data

25import Data.List.Split (splitOn)

16import Data.List.Split (splitOn)

@@ -38,15 +29,27 @@ data Ident

38 -- |

29 -- |

39 -- A symbolic name for an infix operator

30 -- A symbolic name for an infix operator

40 --

31 --

32+ | Op String

33+ -- |

34+ -- A generated name for an identifier

35+ --

41− | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)

36+ | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)

42

37

43runIdent :: Ident -> String

38runIdent :: Ident -> String

44runIdent (Ident i) = i

39runIdent (Ident i) = i

45runIdent (Op op) = op

40runIdent (Op op) = op

41+runIdent (GenIdent Nothing n) = "$" ++ show n

42+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

46

43

47showIdent :: Ident -> String

44showIdent :: Ident -> String

48−showIdent (Ident i) = i

49showIdent (Op op) = '(' : op ++ ")"

45showIdent (Op op) = '(' : op ++ ")"

46+showIdent i = runIdent i

47+

48+freshIdent :: (MonadSupply m) => String -> m Ident

49+freshIdent name = liftM (GenIdent (Just name)) fresh

50+

51+freshIdent' :: (MonadSupply m) => m Ident

52+freshIdent' = liftM (GenIdent Nothing) fresh

50

53

51-- |

54-- |

52-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

55-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

src/Language/PureScript/Parser/Common.hs−5

@@ -27,11 +27,6 @@ import Language.PureScript.Names

27

28import qualified Text.Parsec as P

29

30−featureWasRemoved :: String -> TokenParser a

31−featureWasRemoved err = do

32− pos <- P.getPosition

33− error $ "It looks like you are trying to use a feature from a previous version of the compiler:\n" ++ err ++ "\nat " ++ show pos

34−

35properName :: TokenParser ProperName

30properName :: TokenParser ProperName

36properName = ProperName <$> uname

31properName = ProperName <$> uname

37

32

src/Language/PureScript/Parser/Declarations.hs+77−69

@@ -33,6 +33,7 @@ import Language.PureScript.Environment

33import Language.PureScript.Errors

34import Language.PureScript.Kinds

35import Language.PureScript.Names

36+import Language.PureScript.Types

36import Language.PureScript.Parser.Common

37import Language.PureScript.Parser.Common

37import Language.PureScript.Parser.Kinds

38import Language.PureScript.Parser.Kinds

38import Language.PureScript.Parser.Lexer

39import Language.PureScript.Parser.Lexer

@@ -75,7 +76,7 @@ parseTypeDeclaration =

75

76

76parseTypeSynonymDeclaration :: TokenParser Declaration

77parseTypeSynonymDeclaration :: TokenParser Declaration

77parseTypeSynonymDeclaration =

78parseTypeSynonymDeclaration =

78− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

79+ TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)

79 <*> many (indented *> kindedIdent)

80 <*> many (indented *> kindedIdent)

80 <*> (indented *> equals *> noWildcards parsePolyType)

81 <*> (indented *> equals *> noWildcards parsePolyType)

81

82

@@ -101,21 +102,18 @@ parseValueDeclaration = do

101 return $ maybe value (`Let` value) whereClause

102 return $ maybe value (`Let` value) whereClause

102

103

103parseExternDeclaration :: TokenParser Declaration

104parseExternDeclaration :: TokenParser Declaration

104−parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

105+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>

105− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

106+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)

106 <*> (indented *> doubleColon *> parseKind)

107 <*> (indented *> doubleColon *> parseKind)

107 <|> (do ident <- parseIdent

108 <|> (do ident <- parseIdent

108− -- TODO: add a wiki page link with migration info

109− -- TODO: remove this deprecation warning in 0.8

110− _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported."

111 ty <- indented *> doubleColon *> noWildcards parsePolyType

109 ty <- indented *> doubleColon *> noWildcards parsePolyType

112 return $ ExternDeclaration ident ty))

110 return $ ExternDeclaration ident ty))

113

111

114parseAssociativity :: TokenParser Associativity

112parseAssociativity :: TokenParser Associativity

115parseAssociativity =

113parseAssociativity =

116− (P.try (reserved "infixl") >> return Infixl) <|>

114+ (reserved "infixl" *> return Infixl) <|>

117− (P.try (reserved "infixr") >> return Infixr) <|>

115+ (reserved "infixr" *> return Infixr) <|>

118− (P.try (reserved "infix") >> return Infix)

116+ (reserved "infix" *> return Infix)

119

117

120parseFixity :: TokenParser Fixity

118parseFixity :: TokenParser Fixity

121parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

119parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

@@ -124,8 +122,9 @@ parseFixityDeclaration :: TokenParser Declaration

124parseFixityDeclaration = do

122parseFixityDeclaration = do

125 fixity <- parseFixity

123 fixity <- parseFixity

126 indented

124 indented

125+ alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"

127 name <- symbol

126 name <- symbol

128− return $ FixityDeclaration fixity name

127+ return $ FixityDeclaration fixity name alias

129

128

130parseImportDeclaration :: TokenParser Declaration

129parseImportDeclaration :: TokenParser Declaration

131parseImportDeclaration = do

130parseImportDeclaration = do

@@ -152,9 +151,10 @@ parseImportDeclaration' = do

152 qName <- qualifiedName

151 qName <- qualifiedName

153 return (moduleName', declType, Just qName, True)

152 return (moduleName', declType, Just qName, True)

154 qualifyingList expectedType = do

153 qualifyingList expectedType = do

154+ declType <- P.optionMaybe

155− idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)

155+ $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))

156− return $ fromMaybe Implicit (expectedType <$> idents)

156+ <|> (const (Implicit True) <$> (indented *> parens (symbol' "..")))

157−

157+ return $ fromMaybe (Implicit False) declType

158

159parseDeclarationRef :: TokenParser DeclarationRef

160parseDeclarationRef =

@@ -172,9 +172,9 @@ parseDeclarationRef =

172parseTypeClassDeclaration :: TokenParser Declaration

173parseTypeClassDeclaration = do

174 reserved "class"

175− implies <- P.option [] $ do

175+ implies <- P.option [] . P.try $ do

176 indented

177− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

177+ implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)

178 lfatArrow

179 return implies

180 className <- indented *> properName

@@ -183,13 +183,17 @@ parseTypeClassDeclaration = do

183 indented *> reserved "where"

184 indented *> mark (P.many (same *> positioned parseTypeDeclaration))

185 return $ TypeClassDeclaration className idents implies members

186+ where

187+

188+parseConstraint :: TokenParser Constraint

189+parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)

186

190

187parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

191parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

188parseInstanceDeclaration = do

192parseInstanceDeclaration = do

189 reserved "instance"

193 reserved "instance"

190 name <- parseIdent <* indented <* doubleColon

194 name <- parseIdent <* indented <* doubleColon

191− deps <- P.optionMaybe $ do

195+ deps <- P.optionMaybe $ P.try $ do

192− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

196+ deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)

193 indented

197 indented

194 rfatArrow

198 rfatArrow

195 return deps

199 return deps

@@ -321,11 +325,12 @@ parseIdentifierAndValue =

321 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

325 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

322 where

326 where

323 rest = C.indented *> colon *> C.indented *> val

327 rest = C.indented *> colon *> C.indented *> val

324− val = (Just <$> parseValue) <|> (underscore *> pure Nothing)

328+ val = (underscore *> pure Nothing) <|> (Just <$> parseValue)

325

329

326parseAbs :: TokenParser Expr

330parseAbs :: TokenParser Expr

327parseAbs = do

331parseAbs = do

328 symbol' "\\"

332 symbol' "\\"

333+ -- TODO: remove this 'try' after operator aliases are finished (0.9)

329 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

334 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

330 C.indented *> rarrow

335 C.indented *> rarrow

331 value <- parseValue

336 value <- parseValue

@@ -341,11 +346,11 @@ parseConstructor :: TokenParser Expr

341parseConstructor = Constructor <$> C.parseQualified C.properName

346parseConstructor = Constructor <$> C.parseQualified C.properName

342

347

343parseCase :: TokenParser Expr

348parseCase :: TokenParser Expr

344−parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)

349+parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

345 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

350 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

346

351

347parseCaseAlternative :: TokenParser CaseAlternative

352parseCaseAlternative :: TokenParser CaseAlternative

348−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

353+parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)

349 <*> (Left <$> (C.indented *>

354 <*> (Left <$> (C.indented *>

350 P.many1 ((,) <$> parseGuard

355 P.many1 ((,) <$> parseGuard

351 <*> (indented *> rarrow *> parseValue)

356 <*> (indented *> rarrow *> parseValue)

@@ -370,23 +375,25 @@ parseLet = do

370

375

371parseValueAtom :: TokenParser Expr

376parseValueAtom :: TokenParser Expr

372parseValueAtom = P.choice

377parseValueAtom = P.choice

373− [ P.try parseNumericLiteral

378+ [ parseNumericLiteral

374− , P.try parseCharLiteral

379+ , parseCharLiteral

375− , P.try parseStringLiteral

380+ , parseStringLiteral

376− , P.try parseBooleanLiteral

381+ , parseBooleanLiteral

377− , parseArrayLiteral

382+ , parseArrayLiteral

378− , P.try parseObjectLiteral

383+ , P.try parseObjectLiteral

379− , P.try parseObjectGetter

384+ , P.try parseObjectGetter

380− , parseAbs

385+ , parseAbs

381− , P.try parseConstructor

386+ , P.try parseConstructor

382− , P.try parseVar

387+ , P.try parseVar

383− , parseCase

388+ , parseCase

384− , parseIfThenElse

389+ , parseIfThenElse

385− , parseDo

390+ , parseDo

386− , parseLet

391+ , parseLet

387− , P.try $ Parens <$> parens parseValue

392+ , P.try $ Parens <$> parens parseValue

388− , parseOperatorSection

393+ , parseOperatorSection

394+ -- TODO: combine this with parseObjectGetter

389− , P.try parseObjectUpdaterWildcard ]

395+ , parseObjectUpdaterWildcard

396+ ]

390

397

391-- |

398-- |

392-- Parse an expression in backticks or an operator

399-- Parse an expression in backticks or an operator

@@ -422,13 +429,14 @@ parseDoNotationLet :: TokenParser DoNotationElement

422parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))

429parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))

423

430

424parseDoNotationBind :: TokenParser DoNotationElement

431parseDoNotationBind :: TokenParser DoNotationElement

425−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)

432+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue

426

433

427parseDoNotationElement :: TokenParser DoNotationElement

434parseDoNotationElement :: TokenParser DoNotationElement

428parseDoNotationElement = P.choice

435parseDoNotationElement = P.choice

429− [ P.try parseDoNotationBind

436+ [ parseDoNotationBind

430 , parseDoNotationLet

437 , parseDoNotationLet

431− , P.try (DoNotationValue <$> parseValue) ]

438+ , DoNotationValue <$> parseValue

439+ ]

432

440

433parseObjectGetter :: TokenParser Expr

441parseObjectGetter :: TokenParser Expr

434parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

442parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

@@ -438,7 +446,8 @@ indexersAndAccessors :: TokenParser Expr

438indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

446indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

439 where

447 where

440 postfixTable = [ parseAccessor

448 postfixTable = [ parseAccessor

441− , P.try . parseUpdaterBody . Just ]

449+ , P.try . parseUpdaterBody . Just

450+ ]

442

451

443-- |

452-- |

444-- Parse a value

453-- Parse a value

@@ -450,9 +459,9 @@ parseValue = withSourceSpan PositionedValue

450 $ indexersAndAccessors) P.<?> "expression"

459 $ indexersAndAccessors) P.<?> "expression"

451 where

460 where

452 postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

461 postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

453− , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v

462+ , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v

454 ]

463 ]

455− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

464+ operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)

456 ]

465 ]

457 , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

466 , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

458 return (BinaryNoParens ident)) P.AssocRight

467 return (BinaryNoParens ident)) P.AssocRight

@@ -482,9 +491,6 @@ parseNumberBinder = NumberBinder <$> (sign <*> number)

482 <|> (symbol' "+" >> return id)

491 <|> (symbol' "+" >> return id)

483 <|> return id

492 <|> return id

484

493

485−parseVarBinder :: TokenParser Binder

486−parseVarBinder = VarBinder <$> C.parseIdent

487−

488parseNullaryConstructorBinder :: TokenParser Binder

494parseNullaryConstructorBinder :: TokenParser Binder

489parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []

495parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []

490

496

@@ -497,9 +503,13 @@ parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdenti

497parseArrayBinder :: TokenParser Binder

503parseArrayBinder :: TokenParser Binder

498parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

504parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

499

505

500−parseNamedBinder :: TokenParser Binder

506+parseVarOrNamedBinder :: TokenParser Binder

507+parseVarOrNamedBinder = do

508+ -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed

509+ -- any more since identifiers in binders won't be 'Op's.

510+ name <- P.try C.parseIdent

501−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)

511+ let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder)

502− <*> (C.indented *> parseBinder)

512+ parseNamedBinder <|> return (VarBinder name)

503

513

504parseNullBinder :: TokenParser Binder

514parseNullBinder :: TokenParser Binder

505parseNullBinder = underscore *> return NullBinder

515parseNullBinder = underscore *> return NullBinder

@@ -517,43 +527,41 @@ parseIdentifierAndBinder =

517-- Parse a binder

527-- Parse a binder

518--

528--

519parseBinder :: TokenParser Binder

529parseBinder :: TokenParser Binder

520−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))

530+parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)

521 where

531 where

522− -- TODO: remove this deprecation warning in 0.8

523− operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]

524 -- TODO: parsePolyType when adding support for polymorphic types

532 -- TODO: parsePolyType when adding support for polymorphic types

525− postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType)

533+ postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)

526 ]

534 ]

527 parseBinderAtom :: TokenParser Binder

535 parseBinderAtom :: TokenParser Binder

528− parseBinderAtom = P.choice (map P.try

536+ parseBinderAtom = P.choice

529 [ parseNullBinder

537 [ parseNullBinder

530 , parseCharBinder

538 , parseCharBinder

531 , parseStringBinder

539 , parseStringBinder

532 , parseBooleanBinder

540 , parseBooleanBinder

533 , parseNumberBinder

541 , parseNumberBinder

534− , parseNamedBinder

542+ , parseVarOrNamedBinder

535− , parseVarBinder

536 , parseConstructorBinder

543 , parseConstructorBinder

537 , parseObjectBinder

544 , parseObjectBinder

538 , parseArrayBinder

545 , parseArrayBinder

539− , parens parseBinder ]) P.<?> "binder"

546+ , parens parseBinder

547+ ] P.<?> "binder"

540

548

541-- |

549-- |

542-- Parse a binder as it would appear in a top level declaration

550-- Parse a binder as it would appear in a top level declaration

543--

551--

544parseBinderNoParens :: TokenParser Binder

552parseBinderNoParens :: TokenParser Binder

545−parseBinderNoParens = P.choice (map P.try

553+parseBinderNoParens = P.choice

546− [ parseNullBinder

554+ [ parseNullBinder

547− , parseCharBinder

555+ , parseCharBinder

548− , parseStringBinder

556+ , parseStringBinder

549− , parseBooleanBinder

557+ , parseBooleanBinder

550− , parseNumberBinder

558+ , parseNumberBinder

551− , parseNamedBinder

559+ , parseVarOrNamedBinder

552− , parseVarBinder

553− , parseNullaryConstructorBinder

560+ , parseNullaryConstructorBinder

554− , parseObjectBinder

561+ , parseObjectBinder

555− , parseArrayBinder

562+ , parseArrayBinder

556− , parens parseBinder ]) P.<?> "binder"

563+ , parens parseBinder

564+ ] P.<?> "binder"

557

565

558-- |

566-- |

559-- Parse a guard

567-- Parse a guard

src/Language/PureScript/Parser/Kinds.hs+4−3

@@ -33,10 +33,11 @@ parseBang :: TokenParser Kind

33parseBang = const Bang <$> symbol' "!"

34

35parseTypeAtom :: TokenParser Kind

36−parseTypeAtom = indented *> P.choice (map P.try

36+parseTypeAtom = indented *> P.choice

37 [ parseStar

38 , parseBang

39− , parens parseKind ])

39+ , parens parseKind

40+ ]

40-- |

41-- |

41-- Parse a kind

42-- Parse a kind

42--

43--

@@ -44,4 +45,4 @@ parseKind :: TokenParser Kind

44parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

45parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

45 where

46 where

46 operators = [ [ P.Prefix (symbol' "#" >> return Row) ]

47 operators = [ [ P.Prefix (symbol' "#" >> return Row) ]

47− , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ]

48+ , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ]

src/Language/PureScript/Parser/Lexer.hs+5−5

@@ -67,13 +67,13 @@ module Language.PureScript.Parser.Lexer

67 , natural

68 , reservedPsNames

69 , reservedTypeNames

70− , opChars

70+ , isSymbolChar

71 )

72 where

73

74import Prelude hiding (lex)

75

76−import Data.Char (isSpace)

76+import Data.Char (isSpace, isAscii, isSymbol)

77

78import Control.Monad (void, guard)

79import Data.Functor.Identity

@@ -233,7 +233,7 @@ parseToken = P.choice

233 uidentLetter = P.alphaNum <|> P.char '_'

234

235 symbolChar :: P.Parsec String u Char

236− symbolChar = P.oneOf opChars

236+ symbolChar = P.satisfy isSymbolChar

237

238 parseCharLiteral :: P.Parsec String u Char

239 parseCharLiteral = PT.charLiteral tokenParser

@@ -516,5 +516,5 @@ reservedTypeNames = [ "forall", "where" ]

516-- |

517-- The characters allowed for use in operators

518--

519−opChars :: [Char]

519+isSymbolChar :: Char -> Bool

520−opChars = ":!#$%&*+./<=>?@\\^|-~"

520+isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)

src/Language/PureScript/Parser/Types.hs+20−43

@@ -1,18 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Parser.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Parsers for types

13−--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Parser.Types (

1module Language.PureScript.Parser.Types (

17 parseType,

2 parseType,

18 parsePolyType,

3 parsePolyType,

@@ -32,19 +17,8 @@ import Language.PureScript.Environment

32import qualified Text.Parsec as P

17import qualified Text.Parsec as P

33import qualified Text.Parsec.Expr as P

18import qualified Text.Parsec.Expr as P

34

19

35−-- TODO: remove these deprecation warnings in 0.8

36−parseArray :: TokenParser Type

37−parseArray = do

38− _ <- squares $ return tyArray

39− featureWasRemoved "Array notation is no longer supported. Use Array instead of []."

40−

41−parseArrayOf :: TokenParser Type

42−parseArrayOf = do

43− _ <- squares $ TypeApp tyArray <$> parseType

44− featureWasRemoved "Array notation is no longer supported. Use Array _ instead of [_]."

45−

46parseFunction :: TokenParser Type

20parseFunction :: TokenParser Type

47−parseFunction = parens $ rarrow >> return tyFunction

21+parseFunction = parens rarrow >> return tyFunction

48

22

49parseObject :: TokenParser Type

23parseObject :: TokenParser Type

50parseObject = braces $ TypeApp tyObject <$> parseRow

24parseObject = braces $ TypeApp tyObject <$> parseRow

@@ -62,45 +36,48 @@ parseTypeConstructor :: TokenParser Type

62parseTypeConstructor = TypeConstructor <$> parseQualified properName

36parseTypeConstructor = TypeConstructor <$> parseQualified properName

63

37

64parseForAll :: TokenParser Type

38parseForAll :: TokenParser Type

65−parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

39+parseForAll = mkForAll <$> (reserved "forall" *> P.many1 (indented *> identifier) <* indented <* dot)

66 <*> parseType

40 <*> parseType

67

41

68-- |

42-- |

69-- Parse a type as it appears in e.g. a data constructor

43-- Parse a type as it appears in e.g. a data constructor

70--

44--

71parseTypeAtom :: TokenParser Type

45parseTypeAtom :: TokenParser Type

72−parseTypeAtom = indented *> P.choice (map P.try

46+parseTypeAtom = indented *> P.choice

73− [ parseArray

47+ [ P.try parseConstrainedType

74− , parseArrayOf

75− , parseFunction

48+ , P.try parseFunction

76 , parseObject

49 , parseObject

77 , parseTypeWildcard

50 , parseTypeWildcard

51+ , parseForAll

78 , parseTypeVariable

52 , parseTypeVariable

79 , parseTypeConstructor

53 , parseTypeConstructor

80− , parseForAll

54+ -- This try is needed due to some unfortunate ambiguities between rows and kinded types

81− , parens parseRow

55+ , P.try (parens parseRow)

82− , parseConstrainedType

83 , parens parsePolyType

56 , parens parsePolyType

84− ])

57+ ]

85

58

86parseConstrainedType :: TokenParser Type

59parseConstrainedType :: TokenParser Type

87parseConstrainedType = do

60parseConstrainedType = do

88− constraints <- parens . commaSep1 $ do

61+ constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)

89− className <- parseQualified properName

90− indented

91− ty <- P.many parseTypeAtom

92− return (className, ty)

93 _ <- rfatArrow

62 _ <- rfatArrow

94 indented

63 indented

95 ty <- parseType

64 ty <- parseType

96 return $ ConstrainedType constraints ty

65 return $ ConstrainedType constraints ty

66+ where

67+ parseConstraint = do

68+ className <- parseQualified properName

69+ indented

70+ ty <- P.many parseTypeAtom

71+ return (className, ty)

72+

97

73

98parseAnyType :: TokenParser Type

74parseAnyType :: TokenParser Type

99parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

75parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

100 where

76 where

101 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

77 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

102− , [ P.Infix (rarrow >> return function) P.AssocRight ] ]

78+ , [ P.Infix (rarrow >> return function) P.AssocRight ]

79+ ]

103− postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)

80+ postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

104 ]

81 ]

105

82

106-- |

83-- |

src/Language/PureScript/Pretty/Common.hs+2−2

@@ -18,7 +18,7 @@ module Language.PureScript.Pretty.Common where

18import Control.Monad.State

19import Data.List (intercalate)

20

21−import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)

21+import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

22

23import Text.PrettyPrint.Boxes

24

@@ -68,7 +68,7 @@ prettyPrintMany f xs = do

68--

69prettyPrintObjectKey :: String -> String

70prettyPrintObjectKey s | s `elem` reservedPsNames = show s

71− | any (`elem` opChars) s = show s

71+ | any isSymbolChar s = show s

72 | otherwise = s

73

74-- | Place a box before another, vertically when the first box takes up multiple lines.

src/Language/PureScript/Pretty/Types.hs+12−6

@@ -121,21 +121,27 @@ constrained = mkPattern match

121 match _ = Nothing

122

123matchTypeAtom :: Pattern () Type Box

124−matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

124+matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType

125

126matchType :: Pattern () Type Box

127matchType = buildPrettyPrinter operators matchTypeAtom

128 where

129 operators :: OperatorTable () Type Box

130 operators =

131− OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

131+ OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]

132− , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

132+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]

133− ]

134 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

133 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

135− , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

134+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]

136− , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ]

135+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]

137 ]

136 ]

138

137

138+ -- If both boxes span a single line, keep them on the same line, or else

139+ -- use the specified function to modify the second box, then combine vertically.

140+ keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box

141+ keepSingleLinesOr f b1 b2

142+ | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ]

143+ | otherwise = hcat top [ b1, text " ", b2]

144+

139forall_ :: Pattern () Type ([String], Type)

145forall_ :: Pattern () Type ([String], Type)

140forall_ = mkPattern match

146forall_ = mkPattern match

141 where

147 where

src/Language/PureScript/Pretty/Values.hs+1

@@ -160,6 +160,7 @@ prettyPrintBinderAtom (ArrayBinder bs) =

160 ++ " ]"

161prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

162prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

163+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

163prettyPrintBinderAtom b = parens (prettyPrintBinder b)

164prettyPrintBinderAtom b = parens (prettyPrintBinder b)

164

165

165-- |

166-- |

src/Language/PureScript/Renamer.hs+27−29

@@ -1,22 +1,9 @@

1−-----------------------------------------------------------------------------

2−-----------------------------------------------------------------------------

3−--

4−-- Module : Language.PureScript.Renamer

6−-- License : MIT

7−--

8−-- Maintainer : Phil Freeman <paf31@cantab.net>

9−-- Stability : experimental

10−-- Portability :

11−--

12−-- |

13−-- Renaming pass that prevents shadowing of local identifiers.

14−--

15−-----------------------------------------------------------------------------

16−

17{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

18{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

19

3

4+-- |

5+-- Renaming pass that prevents shadowing of local identifiers.

6+--

20module Language.PureScript.Renamer (renameInModules) where

7module Language.PureScript.Renamer (renameInModules) where

21

8

22import Prelude ()

9import Prelude ()

@@ -25,6 +12,7 @@ import Prelude.Compat

25import Control.Monad.State

12import Control.Monad.State

26

13

27import Data.List (find)

14import Data.List (find)

15+import Data.Maybe (fromJust, fromMaybe)

28

16

29import qualified Data.Map as M

17import qualified Data.Map as M

30import qualified Data.Set as S

18import qualified Data.Set as S

@@ -76,19 +64,29 @@ newScope x = do

76-- unique name is generated and stored.

64-- unique name is generated and stored.

77--

65--

78updateScope :: Ident -> Rename Ident

66updateScope :: Ident -> Rename Ident

67+updateScope ident =

68+ case ident of

79−updateScope i@(Ident name) | name == C.__unused = return i

69+ Ident name | name == C.__unused -> return ident

80−updateScope name = do

70+ GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)

71+ _ -> go ident ident

72+ where

73+ go :: Ident -> Ident -> Rename Ident

74+ go keyName baseName = do

81− scope <- get

75+ scope <- get

82− name' <- if name `S.member` rsUsedNames scope

76+ let usedNames = rsUsedNames scope

83− then do

77+ name' =

84− let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

78+ if baseName `S.member` usedNames

85− Just newName = find (`S.notMember` rsUsedNames scope) newNames

79+ then getNewName usedNames baseName

86− return newName

80+ else baseName

87− else return name

88− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

81+ modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)

89− , rsUsedNames = S.insert name' (rsUsedNames s)

82+ , rsUsedNames = S.insert name' (rsUsedNames s)

90− }

83+ }

91− return name'

84+ return name'

85+ getNewName :: S.Set Ident -> Ident -> Ident

86+ getNewName usedNames name =

87+ fromJust $ find

88+ (`S.notMember` usedNames)

89+ [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]

92

90

93-- |

91-- |

94-- Finds the new name to use for an ident.

92-- Finds the new name to use for an ident.

src/Language/PureScript/Sugar/CaseDeclarations.hs+42−28

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE ScopedTypeVariables #-}

3−-- Module : Language.PureScript.CaseDeclarations

3+

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

4-- |

12-- This module implements the desugaring pass which replaces top-level binders with

5-- This module implements the desugaring pass which replaces top-level binders with

13-- case expressions.

6-- case expressions.

14--

7--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20module Language.PureScript.Sugar.CaseDeclarations (

8module Language.PureScript.Sugar.CaseDeclarations (

21 desugarCases,

9 desugarCases,

22 desugarCasesModule

10 desugarCasesModule

@@ -26,8 +14,8 @@ import Prelude ()

26import Prelude.Compat

14import Prelude.Compat

27

15

28import Language.PureScript.Crash

16import Language.PureScript.Crash

29−import Data.Maybe (catMaybes)

17+import Data.Maybe (catMaybes, mapMaybe)

30−import Data.List (nub, groupBy)

18+import Data.List (nub, groupBy, foldl1')

31

19

32import Control.Monad ((<=<), forM, replicateM, join, unless)

20import Control.Monad ((<=<), forM, replicateM, join, unless)

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

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

@@ -51,26 +39,54 @@ isLeft (Right _) = False

51desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

39desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

52desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

40desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

53 rethrow (addHint (ErrorInModule name)) $

41 rethrow (addHint (ErrorInModule name)) $

54− Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

42+ Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps

43+

44+-- |

45+-- Validates that case head and binder lengths match.

46+--

47+validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

48+validateCases = flip parU f

49+ where

50+ (f, _, _) = everywhereOnValuesM return validate return

51+

52+ validate :: Expr -> m Expr

53+ validate c@(Case vs alts) = do

54+ let l = length vs

55+ alts' = filter ((l /=) . length . caseAlternativeBinders) alts

56+ unless (null alts') $

57+ throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts')

58+ return c

59+ validate other = return other

60+

61+ altError :: Int -> [Binder] -> ErrorMessage

62+ altError l bs = withPosition pos $ ErrorMessage [] $ CaseBinderLengthDiffers l bs

63+ where

64+ pos = foldl1' widenSpan (mapMaybe positionedBinder bs)

65+

66+ widenSpan (SourceSpan n start end) (SourceSpan _ start' end') =

67+ SourceSpan n (min start start') (max end end')

68+

69+ positionedBinder (PositionedBinder p _ _) = Just p

70+ positionedBinder _ = Nothing

55

71

56−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

72+desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

57desugarAbs = flip parU f

73desugarAbs = flip parU f

58 where

74 where

59 (f, _, _) = everywhereOnValuesM return replace return

75 (f, _, _) = everywhereOnValuesM return replace return

60

76

61− replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr

77+ replace :: Expr -> m Expr

62 replace (Abs (Right binder) val) = do

78 replace (Abs (Right binder) val) = do

63− ident <- Ident <$> freshName

79+ ident <- freshIdent'

64 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

80 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

65 replace other = return other

81 replace other = return other

66

82

67-- |

83-- |

68-- Replace all top-level binders with case expressions.

84-- Replace all top-level binders with case expressions.

69--

85--

70−desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

86+desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

71desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

87desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

72 where

88 where

73− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

89+ desugarRest :: [Declaration] -> m [Declaration]

74 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

90 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

75 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest

91 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest

76 desugarRest (ValueDeclaration name nameKind bs result : rest) =

92 desugarRest (ValueDeclaration name nameKind bs result : rest) =

@@ -108,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

108 isVarBinder _ = False

124 isVarBinder _ = False

109

125

110 fromVarBinder :: Binder -> m Ident

126 fromVarBinder :: Binder -> m Ident

111− fromVarBinder NullBinder = Ident <$> freshName

127+ fromVarBinder NullBinder = freshIdent'

112 fromVarBinder (VarBinder name) = return name

128 fromVarBinder (VarBinder name) = return name

113 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

129 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114 fromVarBinder (TypedBinder _ b) = fromVarBinder b

130 fromVarBinder (TypedBinder _ b) = fromVarBinder b

@@ -137,7 +153,7 @@ makeCaseDeclaration ident alternatives = do

137 argNames = map join $ foldl1 resolveNames namedArgs

153 argNames = map join $ foldl1 resolveNames namedArgs

138 args <- if allUnique (catMaybes argNames)

154 args <- if allUnique (catMaybes argNames)

139 then mapM argName argNames

155 then mapM argName argNames

140− else replicateM (length argNames) (Ident <$> freshName)

156+ else replicateM (length argNames) freshIdent'

141 let vars = map (Var . Qualified Nothing) args

157 let vars = map (Var . Qualified Nothing) args

142 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]

158 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]

143 value = foldr (Abs . Left) (Case vars binders) args

159 value = foldr (Abs . Left) (Case vars binders) args

@@ -162,9 +178,7 @@ makeCaseDeclaration ident alternatives = do

162

178

163 argName :: Maybe Ident -> m Ident

179 argName :: Maybe Ident -> m Ident

164 argName (Just name) = return name

180 argName (Just name) = return name

165− argName _ = do

181+ argName _ = freshIdent'

166− name <- freshName

167− return (Ident name)

168

182

169 -- Combine two lists of potential names from two case alternatives

183 -- Combine two lists of potential names from two case alternatives

170 -- by zipping correspoding columns.

184 -- by zipping correspoding columns.

src/Language/PureScript/Sugar/DoNotation.hs+4−16

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE ScopedTypeVariables #-}

3−-- Module : Language.PureScript.Sugar.DoNotation

3+

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

4-- |

12-- This module implements the desugaring pass which replaces do-notation statements with

5-- This module implements the desugaring pass which replaces do-notation statements with

13-- appropriate calls to bind from the Prelude.Monad type class.

6-- appropriate calls to bind from the Prelude.Monad type class.

14--

7--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20module Language.PureScript.Sugar.DoNotation (

8module Language.PureScript.Sugar.DoNotation (

21 desugarDoModule

9 desugarDoModule

22) where

10) where

@@ -68,7 +56,7 @@ desugarDo d =

68 return $ App (App bind val) (Abs (Left ident) rest')

56 return $ App (App bind val) (Abs (Left ident) rest')

69 go (DoNotationBind binder val : rest) = do

57 go (DoNotationBind binder val : rest) = do

70 rest' <- go rest

58 rest' <- go rest

71− ident <- Ident <$> freshName

59+ ident <- freshIdent'

72 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

60 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

73 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

61 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

74 go (DoNotationLet ds : rest) = do

62 go (DoNotationLet ds : rest) = do

src/Language/PureScript/Sugar/Names.hs+26−19

@@ -50,7 +50,7 @@ desugarImports externs modules = do

50 ss = internalModuleSourceSpan "<Externs>"

51 env' = M.insert efModuleName (ss, nullImports, members) env

52 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])

53− imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)

53+ imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

54 exps <- resolveExports env' efModuleName imps members efExports

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

56 where

@@ -197,16 +197,16 @@ renameInModule env imports (Module ss coms mn decls exps) =

197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

198

199 updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName

200+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

201

202 updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

203− updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName

203+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

204

205 updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName

206+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

207

208 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

209− updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName

209+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

210

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

212 -- module of original definition.

@@ -226,25 +226,30 @@ renameInModule env imports (Module ss coms mn decls exps) =

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

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

228 -- (e.g. M.Map -> Data.Map.Map).

229+ update

230+ :: (Ord a, Show a)

229− update :: (Ord a) => (Qualified a -> SimpleErrorMessage)

231+ => (Qualified a -> SimpleErrorMessage)

230− -> M.Map (Qualified a) (Qualified a, ModuleName)

232+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

231− -> (Exports -> a -> Maybe (Qualified a))

233+ -> (Exports -> a -> Maybe (Qualified a))

232− -> (Qualified a -> Name)

234+ -> (Qualified a -> Name)

235+ -> (a -> String)

233− -> Qualified a

236+ -> Qualified a

234− -> Maybe SourceSpan

237+ -> Maybe SourceSpan

235− -> m (Qualified a)

238+ -> m (Qualified a)

236− update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $

239+ update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $

237 case (M.lookup qname imps, mn') of

240 case (M.lookup qname imps, mn') of

241+

238 -- We found the name in our imports, so we return the name for it,

242 -- We found the name in our imports, so we return the name for it,

239 -- qualifying with the name of the module it was originally defined in

243 -- qualifying with the name of the module it was originally defined in

240 -- rather than the module we're importing from, to handle the case of

244 -- rather than the module we're importing from, to handle the case of

241− -- re-exports.

245+ -- re-exports. If there are multiple options for the name to resolve to

246+ -- in scope, we throw an error.

242− (Just (qn, mnOrig), _) -> do

247+ (Just options, _) -> do

243− case qn of

248+ checkImportConflicts render options

244− Qualified (Just mnNew) _ ->

249+ let (Qualified (Just mnNew) _, mnOrig) = head options

245− modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

250+ modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

246− _ -> return ()

247 return $ Qualified (Just mnOrig) name

251 return $ Qualified (Just mnOrig) name

252+

248 -- If the name wasn't found in our imports but was qualified then we need

253 -- If the name wasn't found in our imports but was qualified then we need

249 -- to check whether it's a failed import from a "pseudo" module (created

254 -- to check whether it's a failed import from a "pseudo" module (created

250 -- by qualified importing). If that's not the case, then we just need to

255 -- by qualified importing). If that's not the case, then we just need to

@@ -252,9 +257,11 @@ renameInModule env imports (Module ss coms mn decls exps) =

252 (Nothing, Just mn'') -> do

257 (Nothing, Just mn'') -> do

253 modExports <- getExports env mn''

258 modExports <- getExports env mn''

254 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

259 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

260+

255 -- If neither of the above cases are true then it's an undefined or

261 -- If neither of the above cases are true then it's an undefined or

256 -- unimported symbol.

262 -- unimported symbol.

257 _ -> throwError . errorMessage $ unknown qname

263 _ -> throwError . errorMessage $ unknown qname

264+

258 where

265 where

259 positioned err = case pos of

266 positioned err = case pos of

260 Nothing -> err

267 Nothing -> err

src/Language/PureScript/Sugar/Names/Env.hs+44−12

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

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

2

3

3module Language.PureScript.Sugar.Names.Env

4module Language.PureScript.Sugar.Names.Env

4 ( Imports(..)

5 ( Imports(..)

@@ -14,14 +15,19 @@ module Language.PureScript.Sugar.Names.Env

14 , exportTypeClass

15 , exportTypeClass

15 , exportValue

16 , exportValue

16 , getExports

17 , getExports

18+ , checkImportConflicts

17 ) where

19 ) where

18

20

21+import Data.Function (on)

22+import Data.List (groupBy, sortBy, nub)

23+import Data.Maybe (fromJust)

19import qualified Data.Map as M

24import qualified Data.Map as M

20

25

21import Control.Monad

26import Control.Monad

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

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

23

28

24import Language.PureScript.AST

29import Language.PureScript.AST

30+import Language.PureScript.Crash

25import Language.PureScript.Names

31import Language.PureScript.Names

26import Language.PureScript.Environment

32import Language.PureScript.Environment

27import Language.PureScript.Errors

33import Language.PureScript.Errors

@@ -34,19 +40,19 @@ data Imports = Imports

34 -- |

40 -- |

35 -- Local names for types within a module mapped to to their qualified names

41 -- Local names for types within a module mapped to to their qualified names

36 --

42 --

37− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

43+ importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

38 -- |

44 -- |

39 -- Local names for data constructors within a module mapped to to their qualified names

45 -- Local names for data constructors within a module mapped to to their qualified names

40 --

46 --

41− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

47+ , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

42 -- |

48 -- |

43 -- Local names for classes within a module mapped to to their qualified names

49 -- Local names for classes within a module mapped to to their qualified names

44 --

50 --

45− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

51+ , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

46 -- |

52 -- |

47 -- Local names for values within a module mapped to to their qualified names

53 -- Local names for values within a module mapped to to their qualified names

48 --

54 --

49− , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)

55+ , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]

50 -- |

56 -- |

51 -- The list of modules that have been imported into the current scope.

57 -- The list of modules that have been imported into the current scope.

52 --

58 --

@@ -116,9 +122,10 @@ envModuleExports (_, _, exps) = exps

116-- The exported types from the @Prim@ module

122-- The exported types from the @Prim@ module

117--

123--

118primExports :: Exports

124primExports :: Exports

119−primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

125+primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []

120 where

126 where

121− mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])

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

128+ mkClassEntry (Qualified mn name) = (name, fromJust mn)

122

129

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

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

124primEnv :: Env

131primEnv :: Env

@@ -132,15 +139,17 @@ primEnv = M.singleton

132--

139--

133exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

140exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

134exportType exps name dctors mn = do

141exportType exps name dctors mn = do

135− let exTypes = exportedTypes exps

142+ let exTypes' = exportedTypes exps

143+ let exTypes = filter ((/= mn) . snd) exTypes'

136 let exDctors = (snd . fst) `concatMap` exTypes

144 let exDctors = (snd . fst) `concatMap` exTypes

137 let exClasses = exportedTypeClasses exps

145 let exClasses = exportedTypeClasses exps

146+

138− when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name

147+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

139 when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

148 when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

140 forM_ dctors $ \dctor -> do

149 forM_ dctors $ \dctor -> do

141 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

150 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

142 when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

151 when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

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

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

144

153

145-- |

154-- |

146-- Safely adds a class to some exports, returning an error if a conflict occurs.

155-- Safely adds a class to some exports, returning an error if a conflict occurs.

@@ -149,7 +158,7 @@ exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> Mod

149exportTypeClass exps name mn = do

158exportTypeClass exps name mn = do

150 let exTypes = exportedTypes exps

159 let exTypes = exportedTypes exps

151 let exDctors = (snd . fst) `concatMap` exTypes

160 let exDctors = (snd . fst) `concatMap` exTypes

152− when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name

161+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

153 when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

162 when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

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

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

155 return $ exps { exportedTypeClasses = classes }

164 return $ exps { exportedTypeClasses = classes }

@@ -168,9 +177,9 @@ exportValue exps name mn = do

168--

177--

169addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

178addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

170addExport what name mn exports =

179addExport what name mn exports =

171− if any ((== name) . fst) exports

180+ if any (\(name', mn') -> name == name' && mn /= mn') exports

172 then throwConflictError what name

181 then throwConflictError what name

173− else return $ (name, mn) : exports

182+ else return $ nub $ (name, mn) : exports

174

183

175-- |

184-- |

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

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

@@ -181,3 +190,26 @@ throwConflictError conflict = throwError . errorMessage . conflict

181-- Gets the exports for a module, or an error message if the module doesn't exist

190-- Gets the exports for a module, or an error message if the module doesn't exist

182getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

191getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

183getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

192getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

193+

194+-- |

195+-- When reading a value from the imports, check that there are no conflicts in

196+-- scope.

197+--

198+checkImportConflicts

199+ :: forall m a

200+ . (MonadError MultipleErrors m, Ord a)

201+ => (a -> String)

202+ -> [(Qualified a, ModuleName)]

203+ -> m ()

204+checkImportConflicts render xs =

205+ let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs

206+ in

207+ if length byOrig > 1

208+ then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)

209+ else return ()

210+ where

211+ getQual :: Qualified a -> ModuleName

212+ getQual (Qualified (Just mn) _) = mn

213+ getQual _ = internalError "unexpected unqualified name in checkImportConflicts"

214+ render' :: Qualified a -> String

215+ render' (Qualified _ a) = render a

src/Language/PureScript/Sugar/Names/Exports.hs+20−22

@@ -1,16 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Names.Exports

4−-- License : MIT (http://opensource.org/licenses/MIT)

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

14{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

15{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

@@ -60,6 +47,7 @@ findExportable (Module _ _ mn ds _) =

60 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

47 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

61 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

48 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

62 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

49 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

50+ updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

63 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

51 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

64 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

52 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

65 updateExports exps _ = return exps

53 updateExports exps _ = return exps

@@ -110,20 +98,30 @@ resolveExports env mn imps exps refs =

110 let isPseudo = isPseudoModule name

98 let isPseudo = isPseudoModule name

111 when (not isPseudo && not (isImportedModule name)) $

99 when (not isPseudo && not (isImportedModule name)) $

112 throwError . errorMessage . UnknownExportModule $ name

100 throwError . errorMessage . UnknownExportModule $ name

113− let reTypes = extract isPseudo name (importedTypes imps)

101+ reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

114− let reDctors = extract isPseudo name (importedDataConstructors imps)

102+ reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

115− let reClasses = extract isPseudo name (importedTypeClasses imps)

103+ reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

116− let reValues = extract isPseudo name (importedValues imps)

104+ reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

117 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

105 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

118 result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

106 result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

119 foldM (uncurry . exportValue) result'' (map resolveValue reValues)

107 foldM (uncurry . exportValue) result'' (map resolveValue reValues)

120 elaborateModuleExports result _ = return result

108 elaborateModuleExports result _ = return result

121

109

122 -- Extracts a list of values for a module based on a lookup table. If the

110 -- Extracts a list of values for a module based on a lookup table. If the

123− -- boolean is true the values are filtered by the qualification of the

111+ -- boolean is true the values are filtered by the qualification

112+ extract

113+ :: (Ord a)

114+ => Bool

115+ -> ModuleName

116+ -> (a -> String)

124− extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]

117+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

125− extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)

118+ -> m [Qualified a]

126− extract False name = map fst . M.elems . M.filter (eqQual name . fst)

119+ extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList

120+ where

121+ go = filterM $ \(name', options) -> do

122+ let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options

123+ when (isMatch && length options > 1) $ checkImportConflicts render options

124+ return isMatch

127

125

128 -- Check whether a module name refers to a "pseudo module" that came into

126 -- Check whether a module name refers to a "pseudo module" that came into

129 -- existence in an import scope due to importing one or more modules as

127 -- existence in an import scope due to importing one or more modules as

@@ -135,7 +133,7 @@ resolveExports env mn imps exps refs =

135 -- function to either extract the keys or values. We test the keys to see if a

133 -- function to either extract the keys or values. We test the keys to see if a

136 -- value being re-exported belongs to a qualified module, and we test the

134 -- value being re-exported belongs to a qualified module, and we test the

137 -- values if that fails to see whether the value has been imported at all.

135 -- values if that fails to see whether the value has been imported at all.

138− testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool

136+ testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool

139 testQuals f mn' = any (eqQual mn') (f (importedTypes imps))

137 testQuals f mn' = any (eqQual mn') (f (importedTypes imps))

140 || any (eqQual mn') (f (importedDataConstructors imps))

138 || any (eqQual mn') (f (importedDataConstructors imps))

141 || any (eqQual mn') (f (importedTypeClasses imps))

139 || any (eqQual mn') (f (importedTypeClasses imps))

src/Language/PureScript/Sugar/Names/Imports.hs+20−41

@@ -79,7 +79,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

79 warned' <- (warned ++) <$>

80 if (length unqual < 2)

81 then return []

82− else case find (\(_, typ, _) -> typ == Implicit) unqual of

82+ else case find (\(_, typ, _) -> isImplicit typ) unqual of

83 Just i ->

84 for (delete i unqual) $ \i'@(pos, typ, _) -> do

85 warn pos $ RedundantUnqualifiedImport mn typ

@@ -98,8 +98,8 @@ resolveImports env (Module ss coms currentModule decls exps) =

98

99 return ()

100

101− let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports

101+ let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports

102− resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

102+ resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

103 return (Module ss coms currentModule decls' exps, resolved)

104

105 where

@@ -138,7 +138,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

138 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139 modExports <- getExports env mn

140 typ' <- case typ of

141− Implicit -> return Implicit

141+ Implicit b -> return $ Implicit b

142 Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs

143 Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs

144 return $ ImportDeclaration mn typ' qual isOldSyntax

@@ -159,18 +159,17 @@ resolveImports env (Module ss coms currentModule decls exps) =

159resolveModuleImport

160 :: forall m

161 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162− => ModuleName

163− -> Env

162+ => Env

164 -> Imports

163 -> Imports

165 -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

164 -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

166 -> m Imports

165 -> m Imports

167−resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

166+resolveModuleImport env ie (mn, imps) = foldM go ie imps

168 where

167 where

169 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

168 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

170 go ie' (pos, typ, impQual) = do

169 go ie' (pos, typ, impQual) = do

171 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

170 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

172 let ie'' = ie' { importedModules = mn : importedModules ie' }

171 let ie'' = ie' { importedModules = mn : importedModules ie' }

173− positioned $ resolveImport currentModule mn modExports ie'' impQual typ

172+ positioned $ resolveImport mn modExports ie'' impQual typ

174 where

173 where

175 positioned err = case pos of

174 positioned err = case pos of

176 Nothing -> err

175 Nothing -> err

@@ -183,17 +182,16 @@ resolveImport

183 :: forall m

182 :: forall m

184 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

183 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185 => ModuleName

184 => ModuleName

186− -> ModuleName

187 -> Exports

185 -> Exports

188 -> Imports

186 -> Imports

189 -> Maybe ModuleName

187 -> Maybe ModuleName

190 -> ImportDeclarationType

188 -> ImportDeclarationType

191 -> m Imports

189 -> m Imports

192−resolveImport currentModule importModule exps imps impQual = resolveByType

190+resolveImport importModule exps imps impQual = resolveByType

193 where

191 where

194

192

195 resolveByType :: ImportDeclarationType -> m Imports

193 resolveByType :: ImportDeclarationType -> m Imports

196− resolveByType Implicit = importAll importExplicit

194+ resolveByType (Implicit _) = importAll importExplicit

197 resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs

195 resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs

198 resolveByType (Hiding refs) = do

196 resolveByType (Hiding refs) = do

199 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

197 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

@@ -262,20 +260,20 @@ resolveImport currentModule importModule exps imps impQual = resolveByType

262 importExplicit imp (PositionedDeclarationRef pos _ r) =

260 importExplicit imp (PositionedDeclarationRef pos _ r) =

263 warnAndRethrowWithPosition pos $ importExplicit imp r

261 warnAndRethrowWithPosition pos $ importExplicit imp r

264 importExplicit imp (ValueRef name) = do

262 importExplicit imp (ValueRef name) = do

265− values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name

263+ let values' = updateImports (importedValues imp) (exportedValues exps) name

266 return $ imp { importedValues = values' }

264 return $ imp { importedValues = values' }

267 importExplicit imp (TypeRef name dctors) = do

265 importExplicit imp (TypeRef name dctors) = do

268− types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name

266+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

269 let exportedDctors :: [(ProperName, ModuleName)]

267 let exportedDctors :: [(ProperName, ModuleName)]

270 exportedDctors = allExportedDataConstructors name

268 exportedDctors = allExportedDataConstructors name

271 dctorNames :: [ProperName]

269 dctorNames :: [ProperName]

272 dctorNames = fst `map` exportedDctors

270 dctorNames = fst `map` exportedDctors

273 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

271 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

274 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

272 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

275− dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

273+ let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

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

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

277 importExplicit imp (TypeClassRef name) = do

275 importExplicit imp (TypeClassRef name) = do

278− typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

276+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name

279 return $ imp { importedTypeClasses = typeClasses' }

277 return $ imp { importedTypeClasses = typeClasses' }

280 importExplicit _ _ = internalError "Invalid argument to importExplicit"

278 importExplicit _ _ = internalError "Invalid argument to importExplicit"

281

279

@@ -286,33 +284,14 @@ resolveImport currentModule importModule exps imps impQual = resolveByType

286 Nothing -> internalError "Invalid state in allExportedDataConstructors"

284 Nothing -> internalError "Invalid state in allExportedDataConstructors"

287 Just ((_, dctors), mn) -> map (, mn) dctors

285 Just ((_, dctors), mn) -> map (, mn) dctors

288

286

289− -- Add something to the Imports if it does not already exist there

287+ -- Add something to an import resolution list

290 updateImports

288 updateImports

291 :: (Ord a)

289 :: (Ord a)

292− => M.Map (Qualified a) (Qualified a, ModuleName)

290+ => M.Map (Qualified a) [(Qualified a, ModuleName)]

293− -> (a -> String)

294 -> [(a, ModuleName)]

291 -> [(a, ModuleName)]

295 -> a

292 -> a

296− -> m (M.Map (Qualified a) (Qualified a, ModuleName))

293+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

297− updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of

294+ updateImports imps' exps' name =

298−

299− -- If the name is not already present add it to the list, after looking up

300− -- where it was originally defined

301− Nothing ->

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

295+ let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

296+ currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')

303− in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

297+ in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'

304−

305− -- If the name already is present check whether it's a duplicate import

306− -- before rejecting it. For example, if module A defines X, and module B

307− -- re-exports A, importing A and B in C should not result in a "conflicting

308− -- import for `x`" error

309− Just (Qualified (Just mn) _, mnOrig)

310− | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'

311− | otherwise -> throwError . errorMessage $ err

312− where

313− err = if currentModule `elem` [mn, importModule]

314− then ConflictingImport (render name) importModule

315− else ConflictingImports (render name) mn importModule

316−

317− Just (Qualified Nothing _, _) ->

318− internalError "Invalid state in updateImports"

src/Language/PureScript/Sugar/ObjectWildcards.hs+3−17

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.ObjectWildcards

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

15{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

17

3

@@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

44 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

30 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

45 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

31 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

46 desugarExpr (ObjectUpdater Nothing ps) = do

32 desugarExpr (ObjectUpdater Nothing ps) = do

47− obj <- Ident <$> freshName

33+ obj <- freshIdent'

48 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

34 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

49 desugarExpr (ObjectGetter prop) = do

35 desugarExpr (ObjectGetter prop) = do

50− arg <- Ident <$> freshName

36+ arg <- freshIdent'

51 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

37 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

52 desugarExpr e = return e

38 desugarExpr e = return e

53

39

@@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

63 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

49 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

64 mkProp (name, Just e) = return (Nothing, (name, e))

50 mkProp (name, Just e) = return (Nothing, (name, e))

65 mkProp (name, Nothing) = do

51 mkProp (name, Nothing) = do

66− arg <- Ident <$> freshName

52+ arg <- freshIdent'

67 return (Just arg, (name, Var (Qualified Nothing arg)))

53 return (Just arg, (name, Var (Qualified Nothing arg)))

src/Language/PureScript/Sugar/Operators.hs+33−27

@@ -1,13 +1,8 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE Rank2Types #-}

2−--

2+{-# LANGUAGE FlexibleContexts #-}

3−-- Module : Language.PureScript.Sugar.Operators

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

5−-- License : MIT (http://opensource.org/licenses/MIT)

5+

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

6-- |

12-- This module implements the desugaring pass which reapplies binary operators based

7-- This module implements the desugaring pass which reapplies binary operators based

13-- on their fixity data and removes explicit parentheses.

8-- on their fixity data and removes explicit parentheses.

@@ -15,13 +10,6 @@

15-- The value parser ignores fixity data when parsing binary operator applications, so

10-- The value parser ignores fixity data when parsing binary operator applications, so

16-- it is necessary to reorder them here.

11-- it is necessary to reorder them here.

17--

12--

18−-----------------------------------------------------------------------------

19−

20−{-# LANGUAGE Rank2Types #-}

21−{-# LANGUAGE FlexibleContexts #-}

22−{-# LANGUAGE ScopedTypeVariables #-}

23−{-# LANGUAGE RecordWildCards #-}

24−

25module Language.PureScript.Sugar.Operators (

13module Language.PureScript.Sugar.Operators (

26 rebracket,

14 rebracket,

27 removeSignedLiterals,

15 removeSignedLiterals,

@@ -44,6 +32,8 @@ import Control.Monad.Supply.Class

44import Data.Function (on)

32import Data.Function (on)

45import Data.Functor.Identity

33import Data.Functor.Identity

46import Data.List (groupBy, sortBy)

34import Data.List (groupBy, sortBy)

35+import Data.Maybe (mapMaybe, fromMaybe)

36+import qualified Data.Map as M

47

37

48import qualified Text.Parsec as P

38import qualified Text.Parsec as P

49import qualified Text.Parsec.Pos as P

39import qualified Text.Parsec.Pos as P

@@ -57,9 +47,24 @@ import qualified Language.PureScript.Constants as C

57rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

47rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

58rebracket externs ms = do

48rebracket externs ms = do

59 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

49 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

60− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

50+ ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities

61− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities

51+ let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities

62− traverse (rebracketModule opTable) ms

52+ ms' <- traverse (rebracketModule opTable) ms

53+ let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

54+ return $ renameAliasedOperators aliased `map` ms'

55+

56+ where

57+

58+ makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)

59+ makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)

60+ makeLookupEntry _ = Nothing

61+

62+ renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module

63+ renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

64+ where

65+ (f', _, _) = everywhereOnValues id go id

66+ go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)

67+ go other = other

63

68

64removeSignedLiterals :: Module -> Module

69removeSignedLiterals :: Module -> Module

65removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

70removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

@@ -82,17 +87,18 @@ removeParens =

82 go (Parens val) = val

87 go (Parens val) = val

83 go val = val

88 go val = val

84

89

85−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]

90+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

86externsFixities ExternsFile{..} =

91externsFixities ExternsFile{..} =

87− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)

92+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

88− | ExternsFixity assoc prec op <- efFixities

93+ | ExternsFixity assoc prec op alias <- efFixities

89 ]

94 ]

90

95

91−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]

96+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

92collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

97collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

93 where

98 where

94− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

99+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

95− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

100+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

101+ [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

96 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

97 collect _ = []

103 collect _ = []

98

104

@@ -172,6 +178,6 @@ desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> trav

172 goExpr :: Expr -> m Expr

178 goExpr :: Expr -> m Expr

173 goExpr (OperatorSection op (Left val)) = return $ App op val

179 goExpr (OperatorSection op (Left val)) = return $ App op val

174 goExpr (OperatorSection op (Right val)) = do

180 goExpr (OperatorSection op (Right val)) = do

175− arg <- Ident <$> freshName

181+ arg <- freshIdent'

176 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

182 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

177 goExpr other = return other

183 goExpr other = return other

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+6−18

@@ -1,18 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.TypeClasses.Deriving

4−-- Copyright : (c) Gershom Bazerman 2015

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the generic deriving elaboration that takes place during desugaring.

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE MultiParamTypeClasses #-}

2{-# LANGUAGE MultiParamTypeClasses #-}

18{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

@@ -20,6 +5,9 @@

20{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

21{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

22

7

8+-- |

9+-- This module implements the generic deriving elaboration that takes place during desugaring.

10+--

23module Language.PureScript.Sugar.TypeClasses.Deriving (

11module Language.PureScript.Sugar.TypeClasses.Deriving (

24 deriveInstances

12 deriveInstances

25) where

13) where

@@ -32,7 +20,7 @@ import Data.Maybe (fromMaybe)

32import Data.Ord (comparing)

20import Data.Ord (comparing)

33

21

34import Control.Monad (replicateM)

22import Control.Monad (replicateM)

35−import Control.Monad.Supply.Class (MonadSupply, freshName)

23+import Control.Monad.Supply.Class (MonadSupply)

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

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

37

25

38import Language.PureScript.Crash

26import Language.PureScript.Crash

@@ -106,7 +94,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

106

94

107 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

95 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

108 mkCtorClause (ctorName, tys) = do

96 mkCtorClause (ctorName, tys) = do

109− idents <- replicateM (length tys) (fmap Ident freshName)

97+ idents <- replicateM (length tys) freshIdent'

110 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

98 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

111 where

99 where

112 caseResult idents =

100 caseResult idents =

@@ -172,7 +160,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

172

160

173 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

161 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

174 mkAlternative (ctorName, tys) = do

162 mkAlternative (ctorName, tys) = do

175− idents <- replicateM (length tys) (fmap Ident freshName)

163+ idents <- replicateM (length tys) freshIdent'

176 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

177 . Right

165 . Right

178 $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

166 $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

src/Language/PureScript/TypeChecker.hs+30−23

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- The top-level type checker, which checks all declarations in a module.

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

19

4

5+-- |

6+-- The top-level type checker, which checks all declarations in a module.

7+--

20module Language.PureScript.TypeChecker (

8module Language.PureScript.TypeChecker (

21 module T,

9 module T,

22 typeCheckModule

10 typeCheckModule

@@ -37,6 +25,7 @@ import Data.Foldable (for_, traverse_)

37import qualified Data.Map as M

25import qualified Data.Map as M

38

26

39import Control.Monad (when, unless, void, forM, forM_)

27import Control.Monad (when, unless, void, forM, forM_)

28+import Control.Monad.Supply.Class (MonadSupply)

40import Control.Monad.State.Class (MonadState(..), modify)

29import Control.Monad.State.Class (MonadState(..), modify)

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

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

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

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

@@ -191,12 +180,12 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

191-- * Process module imports

180-- * Process module imports

192--

181--

193typeCheckAll :: forall m.

182typeCheckAll :: forall m.

194− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

183+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

195 ModuleName ->

184 ModuleName ->

196 [DeclarationRef] ->

185 [DeclarationRef] ->

197 [Declaration] ->

186 [Declaration] ->

198 m [Declaration]

187 m [Declaration]

199−typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds

188+typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

200 where

189 where

201 go :: Declaration -> m Declaration

190 go :: Declaration -> m Declaration

202 go (DataDeclaration dtype name args dctors) = do

191 go (DataDeclaration dtype name args dctors) = do

@@ -290,13 +279,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d

290 go (PositionedDeclaration pos com d) =

279 go (PositionedDeclaration pos com d) =

291 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

280 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

292

281

293− checkOrphanFixities :: Declaration -> m ()

282+ checkFixities :: Declaration -> m ()

294− checkOrphanFixities (FixityDeclaration _ name) = do

283+ checkFixities (FixityDeclaration _ name (Just alias)) = do

284+ ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)

285+ addValue moduleName (Op name) ty Public

286+ checkFixities (FixityDeclaration _ name _) = do

295 env <- getEnv

287 env <- getEnv

296 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

288 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

297− checkOrphanFixities (PositionedDeclaration pos _ d) =

289+ checkFixities (PositionedDeclaration pos _ d) =

298− warnAndRethrowWithPosition pos $ checkOrphanFixities d

290+ warnAndRethrowWithPosition pos $ checkFixities d

299− checkOrphanFixities _ = return ()

291+ checkFixities _ = return ()

300

292

301 checkInstanceMembers :: [Declaration] -> m [Declaration]

293 checkInstanceMembers :: [Declaration] -> m [Declaration]

302 checkInstanceMembers instDecls = do

294 checkInstanceMembers instDecls = do

@@ -344,7 +336,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d

344-- required by exported members are also exported.

336-- required by exported members are also exported.

345--

337--

346typeCheckModule :: forall m.

338typeCheckModule :: forall m.

347− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

339+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

348 Module ->

340 Module ->

349 m Module

341 m Module

350typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

@@ -355,6 +347,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

355 checkTypesAreExported e

347 checkTypesAreExported e

356 checkClassMembersAreExported e

348 checkClassMembersAreExported e

357 checkClassesAreExported e

349 checkClassesAreExported e

350+ checkNonAliasesAreExported e

358 return $ Module ss coms mn decls' (Just exps)

351 return $ Module ss coms mn decls' (Just exps)

359 where

352 where

360

353

@@ -429,3 +422,17 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

429 extractMemberName (TypeDeclaration memberName _) = memberName

422 extractMemberName (TypeDeclaration memberName _) = memberName

430 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

423 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

431 checkClassMembersAreExported _ = return ()

424 checkClassMembersAreExported _ = return ()

425+

426+ checkNonAliasesAreExported :: DeclarationRef -> m ()

427+ checkNonAliasesAreExported dr@(ValueRef (Op name)) =

428+ case listToMaybe (mapMaybe getAlias decls) of

429+ Just alias ->

430+ when (not $ any (== ValueRef alias) exps) $

431+ throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]

432+ _ -> return ()

433+ where

434+ getAlias :: Declaration -> Maybe Ident

435+ getAlias (PositionedDeclaration _ _ d) = getAlias d

436+ getAlias (FixityDeclaration _ name' alias) | name == name' = alias

437+ getAlias _ = Nothing

438+ checkNonAliasesAreExported _ = return ()

src/Language/PureScript/TypeChecker/Monad.hs+1−9

@@ -57,14 +57,13 @@ data CheckState = CheckState

57 , checkNextKind :: Int -- ^ The next kind unification variable

58 , checkNextSkolem :: Int -- ^ The next skolem variable

59 , checkNextSkolemScope :: Int -- ^ The next skolem scope constant

60− , checkNextDictName :: Int -- ^ The next type class dictionary name

61 , checkCurrentModule :: Maybe ModuleName -- ^ The current module

60 , checkCurrentModule :: Maybe ModuleName -- ^ The current module

62 , checkSubstitution :: Substitution -- ^ The current substitution

61 , checkSubstitution :: Substitution -- ^ The current substitution

63 }

62 }

64

63

65-- | Create an empty @CheckState@

64-- | Create an empty @CheckState@

66emptyCheckState :: Environment -> CheckState

65emptyCheckState :: Environment -> CheckState

67−emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution

66+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

68

67

69-- | Unification variables

68-- | Unification variables

70type Unknown = Int

69type Unknown = Int

@@ -202,13 +201,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()

202guardWith _ True = return ()

201guardWith _ True = return ()

203guardWith e False = throwError e

202guardWith e False = throwError e

204

203

205−-- | Generate new type class dictionary name

206−freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int

207−freshDictionaryName = do

208− n <- checkNextDictName <$> get

209− modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }

210− return n

211−

212-- | Run a computation in the substitution monad, generating a return value and the final substitution.

204-- | Run a computation in the substitution monad, generating a return value and the final substitution.

213liftUnify ::

205liftUnify ::

214 (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

206 (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

src/Language/PureScript/TypeChecker/Types.hs+19−31

@@ -1,23 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the type checker

13−--

14−-----------------------------------------------------------------------------

15−

16{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

18{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

19{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

20

5

6+-- |

7+-- This module implements the type checker

8+--

21module Language.PureScript.TypeChecker.Types (

9module Language.PureScript.TypeChecker.Types (

22 typesOf

10 typesOf

23) where

11) where

@@ -48,6 +36,7 @@ import qualified Data.Map as M

48

36

49import Control.Monad

37import Control.Monad

50import Control.Monad.State.Class (MonadState(..), gets)

38import Control.Monad.State.Class (MonadState(..), gets)

39+import Control.Monad.Supply.Class (MonadSupply)

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

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

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

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

53

42

@@ -72,7 +61,7 @@ import Language.PureScript.Types

72-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

61-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

73-- type class dictionaries and type annotations.

62-- type class dictionaries and type annotations.

74typesOf ::

63typesOf ::

75− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

64+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

76 ModuleName ->

65 ModuleName ->

77 [(Ident, Expr)] ->

66 [(Ident, Expr)] ->

78 m [(Ident, (Expr, Type))]

67 m [(Ident, (Expr, Type))]

@@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do

129 return (untyped, typed, dict, untypedDict)

118 return (untyped, typed, dict, untypedDict)

130

119

131checkTypedBindingGroupElement ::

120checkTypedBindingGroupElement ::

132− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

121+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

133 ModuleName ->

122 ModuleName ->

134 (Ident, (Expr, Type, Bool)) ->

123 (Ident, (Expr, Type, Bool)) ->

135 TypeData ->

124 TypeData ->

@@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

148 return (ident, (val'', ty''))

137 return (ident, (val'', ty''))

149

138

150typeForBindingGroupElement ::

139typeForBindingGroupElement ::

151− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

140+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

152 Bool ->

141 Bool ->

153 (Ident, Expr) ->

142 (Ident, Expr) ->

154 TypeData ->

143 TypeData ->

@@ -218,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

218

207

219-- | Infer a type for a value, rethrowing any error to provide a more useful error message

208-- | Infer a type for a value, rethrowing any error to provide a more useful error message

220infer ::

209infer ::

221− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

210+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

222 Expr ->

211 Expr ->

223 m Expr

212 m Expr

224infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

225

214

226-- | Infer a type for a value

215-- | Infer a type for a value

227infer' ::

216infer' ::

228− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

217+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

229 Expr ->

218 Expr ->

230 m Expr

219 m Expr

231infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

220infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

@@ -312,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

312infer' _ = internalError "Invalid argument to infer"

301infer' _ = internalError "Invalid argument to infer"

313

302

314inferLetBinding ::

303inferLetBinding ::

315− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

304+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

316 [Declaration] ->

305 [Declaration] ->

317 [Declaration] ->

306 [Declaration] ->

318 Expr ->

307 Expr ->

@@ -423,7 +412,7 @@ binderRequiresMonotype _ = True

423

412

424-- | Instantiate polytypes only when necessitated by a binder.

413-- | Instantiate polytypes only when necessitated by a binder.

425instantiateForBinders ::

414instantiateForBinders ::

426− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

415+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

427 [Expr] ->

416 [Expr] ->

428 [CaseAlternative] ->

417 [CaseAlternative] ->

429 m ([Expr], [Type])

418 m ([Expr], [Type])

@@ -440,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do

440-- Check the types of the return values in a set of binders in a case statement

429-- Check the types of the return values in a set of binders in a case statement

441--

430--

442checkBinders ::

431checkBinders ::

443− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

432+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

444 [Type] ->

433 [Type] ->

445 Type ->

434 Type ->

446 [CaseAlternative] ->

435 [CaseAlternative] ->

@@ -470,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

470-- Check the type of a value, rethrowing errors to provide a better error message

459-- Check the type of a value, rethrowing errors to provide a better error message

471--

460--

472check ::

461check ::

473− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

462+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

474 Expr ->

463 Expr ->

475 Type ->

464 Type ->

476 m Expr

465 m Expr

@@ -480,7 +469,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

480-- Check the type of a value

469-- Check the type of a value

481--

470--

482check' :: forall m.

471check' :: forall m.

483− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

472+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

484 Expr ->

473 Expr ->

485 Type ->

474 Type ->

486 m Expr

475 m Expr

@@ -495,9 +484,8 @@ check' val (ForAll ident ty _) = do

495 val' <- check skVal sk

484 val' <- check skVal sk

496 return $ TypedValue True val' (ForAll ident ty (Just scope))

485 return $ TypedValue True val' (ForAll ident ty (Just scope))

497check' val t@(ConstrainedType constraints ty) = do

486check' val t@(ConstrainedType constraints ty) = do

498− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

487+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->

499− n <- freshDictionaryName

488+ freshIdent ("dict" ++ className)

500− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

501 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

489 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

502 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

490 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

503 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

491 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

@@ -639,7 +627,7 @@ check' val ty = do

639-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

627-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

640--

628--

641checkProperties ::

629checkProperties ::

642− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

630+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

643 Expr ->

631 Expr ->

644 [(String, Expr)] ->

632 [(String, Expr)] ->

645 Type ->

633 Type ->

@@ -671,7 +659,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh

671

659

672-- | Check the type of a function application, rethrowing errors to provide a better error message

660-- | Check the type of a function application, rethrowing errors to provide a better error message

673checkFunctionApplication ::

661checkFunctionApplication ::

674− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

662+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

675 Expr ->

663 Expr ->

676 Type ->

664 Type ->

677 Expr ->

665 Expr ->

@@ -683,7 +671,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication

683

671

684-- | Check the type of a function application

672-- | Check the type of a function application

685checkFunctionApplication' ::

673checkFunctionApplication' ::

686− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

674+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

687 Expr ->

675 Expr ->

688 Type ->

676 Type ->

689 Expr ->

677 Expr ->

tests/Main.hs+10

@@ -68,6 +68,7 @@ import qualified System.FilePath.Glob as Glob

68import Text.Parsec (ParseError)

69

70import TestsSetup

71+import TestPscPublish

71

72

72modulesDir :: FilePath

73modulesDir :: FilePath

73modulesDir = ".test_modules" </> "node_modules"

74modulesDir = ".test_modules" </> "node_modules"

@@ -171,6 +172,11 @@ assertDoesNotCompile inputFiles foreigns = do

171

172

172main :: IO ()

173main :: IO ()

173main = do

174main = do

175+ testCompiler

176+ testPscPublish

177+

178+testCompiler :: IO ()

179+testCompiler = do

174 fetchSupportCode

180 fetchSupportCode

175 cwd <- getCurrentDirectory

181 cwd <- getCurrentDirectory

176

182

@@ -203,6 +209,10 @@ main = do

203 in putStrLn $ fp' ++ ": " ++ err

209 in putStrLn $ fp' ++ ": " ++ err

204 exitFailure

210 exitFailure

205

211

212+testPscPublish :: IO ()

213+testPscPublish = do

214+ testPackage "tests/support/prelude"

215+

206supportModules :: [String]

216supportModules :: [String]

207supportModules =

217supportModules =

208 [ "Control.Monad.Eff.Class"

218 [ "Control.Monad.Eff.Class"

psc-publish/tests/Test.hs → tests/TestPscPublish.hsrenamed+24−38

@@ -2,30 +2,23 @@

2{-# OPTIONS_GHC -fno-warn-unused-imports #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4

5−-- | To run these tests:

6−--

7−-- * `cabal repl psc-publish`

8−-- * `:l psc-publish/tests/Test.hs`

9−-- * `test`

10−

11−module Test where

5+module TestPscPublish where

12

6

13import Control.Monad

7import Control.Monad

14import Control.Applicative

8import Control.Applicative

15import Control.Exception

9import Control.Exception

16import System.Process

10import System.Process

17import System.Directory

11import System.Directory

12+import System.IO

13+import System.Exit

18import qualified Data.ByteString.Lazy as BL

14import qualified Data.ByteString.Lazy as BL

19import Data.ByteString.Lazy (ByteString)

15import Data.ByteString.Lazy (ByteString)

20import qualified Data.Aeson as A

16import qualified Data.Aeson as A

21import Data.Aeson.BetterErrors

17import Data.Aeson.BetterErrors

18+import Data.Version

22

19

23−import Main

24import Language.PureScript.Docs

20import Language.PureScript.Docs

25−

21+import Language.PureScript.Publish

26−pkgName = "purescript-prelude"

27−packageUrl = "https://github.com/purescript/" ++ pkgName

28−packageDir = "tmp/" ++ pkgName

29

22

30pushd :: forall a. FilePath -> IO a -> IO a

23pushd :: forall a. FilePath -> IO a -> IO a

31pushd dir act = do

24pushd dir act = do

@@ -35,38 +28,12 @@ pushd dir act = do

35 setCurrentDirectory original

28 setCurrentDirectory original

36 either throwIO return result

29 either throwIO return result

37

30

38−clonePackage :: IO ()

39−clonePackage = do

40− createDirectoryIfMissing True packageDir

41− pushd packageDir $ do

42− exists <- doesDirectoryExist ".git"

43− unless exists $ do

44− putStrLn ("Cloning " ++ pkgName ++ " into " ++ packageDir ++ "...")

45− readProcess "git" ["clone", packageUrl, "."] "" >>= putStr

46− readProcess "git" ["tag", "v999.0.0"] "" >>= putStr

47−

48−bowerInstall :: IO ()

49−bowerInstall =

50− pushd packageDir $

51− readProcess "bower" ["install"] "" >>= putStr

52−

53−getPackage :: IO UploadedPackage

54−getPackage = do

55− clonePackage

56− bowerInstall

57− pushd packageDir preparePackage

58−

59data TestResult

31data TestResult

60 = ParseFailed String

32 = ParseFailed String

61 | Mismatch ByteString ByteString -- ^ encoding before, encoding after

33 | Mismatch ByteString ByteString -- ^ encoding before, encoding after

62 | Pass ByteString

34 | Pass ByteString

63 deriving (Show, Read)

35 deriving (Show, Read)

64

36

65−-- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON,

66−-- and check we get the same string.

67−test :: IO TestResult

68−test = roundTrip <$> getPackage

69−

70roundTrip :: UploadedPackage -> TestResult

37roundTrip :: UploadedPackage -> TestResult

71roundTrip pkg =

38roundTrip pkg =

72 let before = A.encode pkg

39 let before = A.encode pkg

@@ -77,3 +44,22 @@ roundTrip pkg =

77 if before == after

44 if before == after

78 then Pass before

45 then Pass before

79 else Mismatch before after

46 else Mismatch before after

47+

48+testRunOptions :: PublishOptions

49+testRunOptions = defaultPublishOptions

50+ { publishGetVersion = return testVersion

51+ }

52+ where testVersion = ("v999.0.0", Version [999,0,0] [])

53+

54+-- | Given a directory which contains a package, produce JSON from it, and then

55+-- | attempt to parse it again, and ensure that it doesn't change.

56+testPackage :: String -> IO ()

57+testPackage dir = do

58+ pushd dir $ do

59+ r <- roundTrip <$> preparePackage testRunOptions

60+ case r of

61+ Pass _ -> pure ()

62+ other -> do

63+ hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")

64+ hPutStrLn stderr (show other)

65+ exitFailure

tests/support/preludenew file+1

Submodule changed.