git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'master' into pure11
commitbbd67e405698f14fbc83b2fe6d9700655310368c authorAndy Arvanitis <andyarvanitis@gmail.com> dateSat 19 Dec 2015, 17:03 (11 years ago) parent24f73ba1e8f4aa
69 files changed+1318−873
compare with golang
unifiedsplit
.gitmodules+3 examples/failing/CaseBinderLengthsDiffer.purs+6 examples/failing/ConflictingExports.purs+16 examples/failing/ConflictingExports2.purs+13 examples/failing/ConflictingImports.purs+19 examples/failing/ConflictingImports2.purs+16 examples/failing/ConflictingQualifiedImports.purs+17 examples/failing/ConflictingQualifiedImports2.purs+15 examples/failing/OperatorAliasNoExport.purs+7 examples/passing/1697.purs+24 examples/passing/CaseMultipleExpressions.purs+19 examples/passing/EmptyTypeClass.purs+3−3 examples/passing/NakedConstraint.purs−2 examples/passing/NonConflictingExports.purs+14 examples/passing/OperatorAlias.purs+11 examples/passing/PendingConflictingImports.purs+17 examples/passing/PendingConflictingImports2.purs+14 examples/passing/UnicodeOperators.purs+20 examples/passing/UntupledConstraints.purs+17 make_release_notes+2 psc/JSON.hs+69 psc/Main.hs+37−21 psci/Completion.hs+1−1 psci/PSCi.hs+31−31 psci/Types.hs+50−16 psci/tests/Main.hs+3−3 purescript.cabal+9−4 src/Control/Monad/Supply/Class.hs+5−17 src/Language/PureScript/AST/Declarations.hs+22−4 src/Language/PureScript/AST/Exported.hs+1−1 src/Language/PureScript/CodeGen/JS.hs+4−15 src/Language/PureScript/CodeGen/JS/Common.hs+165−115 src/Language/PureScript/CoreFn/Desugar.hs+3−14 src/Language/PureScript/Docs/AsMarkdown.hs+5−3 src/Language/PureScript/Docs/Convert.hs+11−8 src/Language/PureScript/Docs/ParseAndDesugar.hs+1−10 src/Language/PureScript/Docs/Types.hs+7−4 src/Language/PureScript/Environment.hs+25−10 src/Language/PureScript/Errors.hs+69−19 src/Language/PureScript/Externs.hs+6−16 src/Language/PureScript/Linter.hs+6−16 src/Language/PureScript/Linter/Exhaustive.hs+41−30 src/Language/PureScript/Linter/Imports.hs+40−2 src/Language/PureScript/Make.hs+3−28 src/Language/PureScript/Names.hs+20−17 src/Language/PureScript/Parser/Common.hs−5 src/Language/PureScript/Parser/Declarations.hs+77−69 src/Language/PureScript/Parser/Kinds.hs+4−3 src/Language/PureScript/Parser/Lexer.hs+5−5 src/Language/PureScript/Parser/Types.hs+20−43 src/Language/PureScript/Pretty/Common.hs+2−2 src/Language/PureScript/Pretty/Types.hs+12−6 src/Language/PureScript/Pretty/Values.hs+1 src/Language/PureScript/Renamer.hs+27−29 src/Language/PureScript/Sugar/CaseDeclarations.hs+42−28 src/Language/PureScript/Sugar/DoNotation.hs+4−16 src/Language/PureScript/Sugar/Names.hs+26−19 src/Language/PureScript/Sugar/Names/Env.hs+44−12 src/Language/PureScript/Sugar/Names/Exports.hs+20−22 src/Language/PureScript/Sugar/Names/Imports.hs+20−41 src/Language/PureScript/Sugar/ObjectWildcards.hs+3−17 src/Language/PureScript/Sugar/Operators.hs+33−27 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+6−18 src/Language/PureScript/TypeChecker.hs+30−23 src/Language/PureScript/TypeChecker/Monad.hs+1−9 src/Language/PureScript/TypeChecker/Types.hs+19−31 tests/Main.hs+10 psc-publish/tests/Test.hs → tests/TestPscPublish.hs+24−38 tests/support/prelude+1
.gitmodulesnew file+3
@@ -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
22
33import Prelude
44
5−class Partial
5+class PartialP
66
7−head :: forall a. (Partial) => Array a -> a
7+head :: forall a. (PartialP) => Array a -> a
88head [x] = x
99
10−instance allowPartials :: Partial
10+instance allowPartials :: PartialP
1111
1212main = Control.Monad.Eff.Console.log $ head ["Done"]
examples/passing/NakedConstraint.purs−2
@@ -2,8 +2,6 @@ module Main where
22
33import Control.Monad.Eff.Console
44
5−class Partial
6−
75data List a = Nil | Cons a (List a)
86
97head :: (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
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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
2727import Data.List (isSuffixOf, partition)
2828import Data.Version (showVersion)
2929import 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
3033
3134import Options.Applicative as Opts
3235
@@ -40,45 +43,54 @@ import qualified Paths_purescript as Paths
4043
4144import Language.PureScript.Make
4245
46+import JSON
47+
4348data PSCMakeOptions = PSCMakeOptions
4449 { pscmInput :: [FilePath]
4550 , pscmForeignInput :: [FilePath]
4651 , pscmOutputDir :: FilePath
4752 , pscmOpts :: P.Options
4853 , pscmUsePrefix :: Bool
54+ , pscmJSONErrors :: Bool
4955 }
5056
5157data InputOptions = InputOptions
5258 { ioInputFiles :: [FilePath]
5359 }
5460
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+
5577compile :: PSCMakeOptions -> IO ()
56−compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do
57− input <- globWarningOnMisses warnFileTypeNotFound inputGlob
78+compile PSCMakeOptions{..} = do
79+ input <- globWarningOnMisses warnFileTypeNotFound pscmInput
5880 when (null input) $ do
5981 hPutStrLn stderr "psc: No input files."
6082 exitFailure
6183 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
6284 moduleFiles <- readInput (InputOptions pursFiles)
63− inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob
85+ inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput
6486 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
65− case runWriterT (parseInputs moduleFiles foreignFiles) of
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
73− makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
74− (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)
75− when (P.nonEmpty warnings') $
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
87+ (makeErrors, makeWarnings) <- runMake pscmOpts $ do
88+ (ms, foreigns) <- parseInputs moduleFiles foreignFiles
89+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
90+ makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
91+ P.make makeActions (map snd ms)
92+ printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
93+ exitSuccess
8294
8395warnFileTypeNotFound :: String -> IO ()
8496warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
@@ -161,6 +173,10 @@ noPrefix = switch $
161173 <> long "no-prefix"
162174 <> help "Do not include comment header"
163175
176+jsonErrors :: Parser Bool
177+jsonErrors = switch $
178+ long "json-errors"
179+ <> help "Print errors to stderr as JSON"
164180
165181options :: Parser P.Options
166182options = P.Options <$> noTco
@@ -177,7 +193,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile
177193 <*> outputDirectory
178194 <*> options
179195 <*> (not <$> noPrefix)
180−
196+ <*> jsonErrors
181197
182198main :: IO ()
183199main = execParser opts >>= compile
psci/Completion.hs+1−1
@@ -171,7 +171,7 @@ getAllQualifications sho m (declName, decl) = do
171171 qualificationsUsing (_, importType, asQ') =
172172 let q = qualifyWith asQ'
173173 in case importType of
174− P.Implicit -> [q]
174+ P.Implicit _ -> [q]
175175 P.Explicit refs -> [q | referencedBy refs]
176176 P.Hiding refs -> [q | not $ referencedBy refs]
177177
psci/PSCi.hs+31−31
@@ -113,12 +113,12 @@ loadModule filename = do
113113-- |
114114-- Load all modules.
115115--
116−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])
116+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
117117loadAllModules files = do
118118 filesAndContent <- forM files $ \filename -> do
119119 content <- readFile filename
120− return (Right filename, content)
121− return $ P.parseModulesFromFiles (either (const "") id) filesAndContent
120+ return (filename, content)
121+ return $ P.parseModulesFromFiles id filesAndContent
122122
123123-- |
124124-- Load all modules, updating the application state
@@ -129,7 +129,7 @@ loadAllImportedModules = do
129129 modulesOrFirstError <- psciIO $ loadAllModules files
130130 case modulesOrFirstError of
131131 Left errs -> printErrors errs
132− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
132+ Right modules -> PSCI . lift . modify $ updateModules modules
133133
134134-- |
135135-- Expands tilde in path.
@@ -202,7 +202,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
202202 trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
203203 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
204204 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
206206 decls = if exec then [itDecl, mainDecl] else [itDecl]
207207 in
208208 P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
@@ -248,26 +248,28 @@ makeIO f io = do
248248 e <- liftIO $ tryIOError io
249249 either (throwError . P.singleError . f) return e
250250
251−make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
252−make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
251+make :: PSCiState -> [P.Module] -> P.Make P.Environment
252+make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)
253253 where
254− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
254+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules
255255 actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
256256 actions' = actions { P.progress = const (return ()) }
257+ loadedModules = psciLoadedModules st
258+ allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
257259
258260-- |
259−-- Takes a value declaration and evaluates it with the current state.
261+-- Takes a value expression and evaluates it with the current state.
260262--
261−handleDeclaration :: P.Expr -> PSCI ()
262−handleDeclaration val = do
263+handleExpression :: P.Expr -> PSCI ()
264+handleExpression val = do
263265 st <- PSCI $ lift get
264266 let m = createTemporaryModule True st val
265267 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]
267269 case e of
268270 Left errs -> printErrors errs
269271 Right _ -> do
270− psciIO $ writeFile indexFile "require('$PSCI').main();"
272+ psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
271273 process <- psciIO findNodeProcess
272274 result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
273275 case result of
@@ -284,7 +286,7 @@ handleDecls ds = do
284286 st <- PSCI $ lift get
285287 let st' = updateLets ds st
286288 let m = createTemporaryModule False st' (P.ObjectLiteral [])
287− e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]
289+ e <- psciIO . runMake $ make st' [m]
288290 case e of
289291 Left err -> printErrors err
290292 Right _ -> PSCI $ lift (put st')
@@ -294,7 +296,7 @@ handleDecls ds = do
294296--
295297handleShowLoadedModules :: PSCI ()
296298handleShowLoadedModules = do
297− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
299+ loadedModules <- PSCI $ lift $ gets psciLoadedModules
298300 psciIO $ readModules loadedModules >>= putStrLn
299301 return ()
300302 where readModules = return . unlines . sort . nub . map toModuleName
@@ -315,10 +317,11 @@ handleShowImportedModules = do
315317 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
316318 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
317319
318− showDeclType P.Implicit = ""
320+ showDeclType (P.Implicit True) = " (..)"
321+ showDeclType (P.Implicit False) = ""
319322 showDeclType (P.Explicit refs) = refsList refs
320− showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
321− refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
323+ showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
324+ refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
322325
323326 showRef :: P.DeclarationRef -> String
324327 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
@@ -339,7 +342,7 @@ handleImport :: ImportedModule -> PSCI ()
339342handleImport im = do
340343 st <- updateImportedModules im <$> PSCI (lift get)
341344 let m = createTemporaryModuleForImports st
342− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
345+ e <- psciIO . runMake $ make st [m]
343346 case e of
344347 Left errs -> printErrors errs
345348 Right _ -> do
@@ -353,7 +356,7 @@ handleTypeOf :: P.Expr -> PSCI ()
353356handleTypeOf val = do
354357 st <- PSCI $ lift get
355358 let m = createTemporaryModule False st val
356− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
359+ e <- psciIO . runMake $ make st [m]
357360 case e of
358361 Left errs -> printErrors errs
359362 Right env' ->
@@ -490,7 +493,7 @@ handleKindOf typ = do
490493 st <- PSCI $ lift get
491494 let m = createTemporaryModuleForKind st typ
492495 mName = P.ModuleName [P.ProperName "$PSCI"]
493− e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
496+ e <- psciIO . runMake $ make st [m]
494497 case e of
495498 Left errs -> printErrors errs
496499 Right env' ->
@@ -527,16 +530,15 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
527530-- Performs an action for each meta-command given, and also for expressions.
528531--
529532handleCommand :: Command -> PSCI ()
530−handleCommand (Expression val) = handleDeclaration val
533+handleCommand (Expression val) = handleExpression val
531534handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
532535handleCommand (Import im) = handleImport im
533536handleCommand (Decls l) = handleDecls l
534537handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
535− PSCI . lift $ modify (updateImportedFiles absPath)
536538 m <- psciIO $ loadModule absPath
537539 case m of
538540 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))
540542handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
541543 foreignsOrError <- psciIO . runMake $ do
542544 foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
@@ -545,12 +547,10 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
545547 Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
546548 Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
547549handleCommand ResetState = do
548− files <- psciImportedFilenames <$> PSCI (lift get)
549− PSCI . lift . modify $ \st -> st
550− { psciImportedFilenames = files
551− , psciImportedModules = []
552− , psciLetBindings = []
553− }
550+ PSCI . lift . modify $ \st ->
551+ st { psciImportedModules = []
552+ , psciLetBindings = []
553+ }
554554 loadAllImportedModules
555555handleCommand (TypeOf val) = handleTypeOf val
556556handleCommand (KindOf typ) = handleKindOf typ
@@ -613,7 +613,7 @@ loop PSCiOptions{..} = do
613613 case foreignsOrError of
614614 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
615615 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
617617 outputStrLn prologueMessage
618618 traverse_ (traverse_ (runPSCI . handleCommand)) config
619619 modules' <- lift $ gets psciLoadedModules
psci/Types.hs+50−16
@@ -15,7 +15,9 @@
1515
1616module Types where
1717
18−import qualified Data.Map as M
18+import Control.Arrow (second)
19+import Data.Map (Map)
20+import qualified Data.Map as Map
1921import qualified Language.PureScript as P
2022
2123data PSCiOptions = PSCiOptions
@@ -32,14 +34,48 @@ data PSCiOptions = PSCiOptions
3234-- because it makes more sense to apply the binding to the final evaluated expression.
3335--
3436data PSCiState = PSCiState
35− { psciImportedFilenames :: [FilePath]
36− , psciImportedModules :: [ImportedModule]
37− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
38− , psciForeignFiles :: M.Map P.ModuleName FilePath
37+ { psciImportedModules :: [ImportedModule]
38+ , _psciLoadedModules :: Map FilePath [P.Module]
39+ , psciForeignFiles :: Map P.ModuleName FilePath
3940 , psciLetBindings :: [P.Declaration]
4041 , psciNodeFlags :: [String]
4142 }
4243
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+
4379-- | All of the data that is contained by an ImportDeclaration in the AST.
4480-- That is:
4581--
@@ -64,12 +100,6 @@ allImportsOf m (PSCiState{psciImportedModules = is}) =
64100
65101-- State helpers
66102
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−
73103-- |
74104-- Updates the state to have more imported modules.
75105--
@@ -77,10 +107,14 @@ updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
77107updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
78108
79109-- |
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).
81112--
82−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
83−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
113+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
114+updateModules modules st =
115+ st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }
116+ where
117+ go = Map.fromListWith (++) . map (second (:[]))
84118
85119-- |
86120-- Updates the state to have more let bindings.
@@ -91,8 +125,8 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
91125-- |
92126-- Updates the state to have more let bindings.
93127--
94−updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState
95−updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }
128+updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState
129+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }
96130
97131-- |
98132-- Valid Meta-commands for PSCI
psci/tests/Main.hs+3−3
@@ -141,11 +141,11 @@ getPSCiState = do
141141 Left err ->
142142 print err >> exitFailure
143143 Right modules ->
144− let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
145− in return (PSCiState [] imports modules foreigns [] [])
144+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)]
145+ in return (mkPSCiState imports modules foreigns [] [])
146146
147147controlMonadSTasST :: ImportedModule
148−controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
148+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST"))
149149 where
150150 s = P.moduleNameFromString
151151
purescript.cabal+9−4
@@ -1,5 +1,5 @@
11name: purescript
2−version: 0.7.6.1
2+version: 0.8.0.0
33cabal-version: >=1.8
44build-type: Simple
55license: MIT
@@ -201,12 +201,15 @@ library
201201 ghc-options: -Wall -O2
202202
203203executable psc
204− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
204+ build-depends: base >=4 && <5, base-compat >=0.6.0,
205+ containers -any, directory -any, filepath -any,
205206 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
207209 main-is: Main.hs
208210 buildable: True
209211 hs-source-dirs: psc
212+ other-modules: JSON
210213 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
211214
212215executable psci
@@ -289,10 +292,12 @@ test-suite tests
289292 build-depends: base >=4 && <5, containers -any, directory -any,
290293 filepath -any, mtl -any, parsec -any, purescript -any,
291294 transformers -any, process -any, transformers-compat -any, time -any,
292− Glob -any, base-compat >=0.6.0
295+ Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
296+ base-compat -any
293297 type: exitcode-stdio-1.0
294298 main-is: Main.hs
295299 other-modules: TestsSetup
300+ TestPscPublish
296301 buildable: True
297302 hs-source-dirs: tests tests/common
298303
src/Control/Monad/Supply/Class.hs+5−17
@@ -1,20 +1,8 @@
1−-----------------------------------------------------------------------------
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−--
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+
113-- |
124-- A class for monads supporting a supply of fresh names
135--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE MultiParamTypeClasses #-}
17−
186module Control.Monad.Supply.Class where
197
208import Control.Monad.Supply
@@ -22,15 +10,15 @@ import Control.Monad.State
2210
2311class (Monad m) => MonadSupply m where
2412 fresh :: m Integer
25−
13+
2614instance (Monad m) => MonadSupply (SupplyT m) where
2715 fresh = SupplyT $ do
2816 n <- get
2917 put (n + 1)
3018 return n
31−
19+
3220instance (MonadSupply m) => MonadSupply (StateT s m) where
3321 fresh = lift fresh
3422
3523freshName :: (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
4141getModuleName :: Module -> ModuleName
4242getModuleName (Module _ _ name _ _) = name
4343
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+
4456-- |
4557-- An item in a list of explicit imports or exports
4658--
@@ -118,9 +130,11 @@ findDuplicateRefs refs =
118130--
119131data ImportDeclarationType
120132 -- |
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.
122136 --
123− = Implicit
137+ = Implicit Bool
124138 -- |
125139 -- An import with an explicit list of references to import: `import M (foo)`
126140 --
@@ -131,6 +145,10 @@ data ImportDeclarationType
131145 | Hiding [DeclarationRef]
132146 deriving (Eq, Show, Read, D.Data, D.Typeable)
133147
148+isImplicit :: ImportDeclarationType -> Bool
149+isImplicit (Implicit _) = True
150+isImplicit _ = False
151+
134152-- |
135153-- The data type of declarations
136154--
@@ -168,9 +186,9 @@ data Declaration
168186 --
169187 | ExternDataDeclaration ProperName Kind
170188 -- |
171− -- A fixity declaration (fixity data, operator name)
189+ -- A fixity declaration (fixity data, operator name, value the operator is an alias for)
172190 --
173− | FixityDeclaration Fixity String
191+ | FixityDeclaration Fixity String (Maybe Ident)
174192 -- |
175193 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
176194 -- 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
112112 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
113113 matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
114114 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'
116116 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
117117 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
118118 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−
161{-# LANGUAGE GADTs #-}
172{-# LANGUAGE ViewPatterns #-}
183{-# LANGUAGE FlexibleContexts #-}
194{-# LANGUAGE ScopedTypeVariables #-}
205
6+-- |
7+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
8+--
219module Language.PureScript.CodeGen.JS
2210 ( module AST
2311 , module Common
@@ -180,6 +168,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
180168 accessor :: Ident -> JS -> JS
181169 accessor (Ident prop) = accessorString prop
182170 accessor (Op op) = JSIndexer (JSStringLiteral op)
171+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"
183172
184173 accessorString :: String -> JS -> JS
185174 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−--
111-- |
122-- Common code generation utility functions
133--
14−-----------------------------------------------------------------------------
15−
164module Language.PureScript.CodeGen.JS.Common where
175
186import Data.Char
197import Data.List (intercalate)
208
9+import Language.PureScript.Crash
2110import Language.PureScript.Names
2211
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+
2317-- |
2418-- Convert an Ident into a valid Javascript identifier:
2519--
@@ -30,9 +24,11 @@ import Language.PureScript.Names
3024-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
3125--
3226identToJs :: Ident -> String
33−identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
34−identToJs (Ident name) = concatMap identCharToString name
27+identToJs (Ident name)
28+ | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name
29+ | otherwise = concatMap identCharToString name
3530identToJs (Op op) = concatMap identCharToString op
31+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
3632
3733-- |
3834-- Test if a string is a valid JS identifier without escaping.
@@ -75,107 +71,161 @@ identCharToString c = '$' : show (ord c)
7571--
7672nameIsJsReserved :: String -> Bool
7773nameIsJsReserved name =
78− name `elem` [ "abstract"
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
74+ name `elem` jsAnyReserved
14475
14576-- |
146−-- Checks whether a proper name is reserved in Javascript.
77+-- Checks whether a name matches a built-in value in Javascript.
14778--
148−properNameIsJsReserved :: String -> Bool
149−properNameIsJsReserved name =
150− name `elem` [ "Infinity"
151− , "NaN"
152− , "Object"
153− , "Function"
154− , "Boolean"
155− , "Error"
156− , "EvalError"
157− , "InternalError"
158− , "RangeError"
159− , "ReferenceError"
160− , "SyntaxError"
161− , "TypeError"
162− , "URIError"
163− , "Number"
164− , "Math"
165− , "Date"
166− , "String"
167− , "RegExp"
168− , "Array"
169− , "Int8Array"
170− , "Uint8Array"
171− , "Uint8ClampedArray"
172− , "Int16Array"
173− , "Uint16Array"
174− , "Int32Array"
175− , "Uint32Array"
176− , "Float32Array"
177− , "Float64Array"
178− , "ArrayBuffer"
179− , "DataView"
180− , "JSON"
181− , "Intl" ]
79+nameIsJsBuiltIn :: String -> Bool
80+nameIsJsBuiltIn name =
81+ elem name
82+ [ "arguments"
83+ , "Array"
84+ , "ArrayBuffer"
85+ , "Boolean"
86+ , "DataView"
87+ , "Date"
88+ , "decodeURI"
89+ , "decodeURIComponent"
90+ , "encodeURI"
91+ , "encodeURIComponent"
92+ , "Error"
93+ , "escape"
94+ , "eval"
95+ , "EvalError"
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"
116+ , "RangeError"
117+ , "ReferenceError"
118+ , "Reflect"
119+ , "RegExp"
120+ , "Set"
121+ , "SIMD"
122+ , "String"
123+ , "Symbol"
124+ , "SyntaxError"
125+ , "TypeError"
126+ , "Uint16Array"
127+ , "Uint32Array"
128+ , "Uint8Array"
129+ , "Uint8ClampedArray"
130+ , "undefined"
131+ , "unescape"
132+ , "URIError"
133+ , "WeakMap"
134+ , "WeakSet"
135+ ]
136+
137+jsAnyReserved :: [String]
138+jsAnyReserved =
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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
151module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
162
173import Data.Function (on)
@@ -68,6 +54,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
6854 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
6955 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
7056 [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))]
7160 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
7261 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
7362 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
src/Language/PureScript/Docs/AsMarkdown.hs+5−3
@@ -45,7 +45,7 @@ declAsMarkdown decl@Declaration{..} = do
4545 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
4646 spacer
4747
48− for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
48+ for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)
4949
5050 for_ declComments tell'
5151
@@ -68,9 +68,11 @@ codeToString = outputWith elemAsMarkdown
6868 elemAsMarkdown (Keyword x) = x
6969 elemAsMarkdown Space = " "
7070
71−fixityAsMarkdown :: P.Fixity -> Docs
72−fixityAsMarkdown (P.Fixity associativity precedence) =
71+fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs
72+fixityAsMarkdown (P.Fixity associativity precedence) alias =
73+ -- TODO: link alias name to member
7374 tell' $ concat [ "_"
75+ , maybe "" (\i -> "alias for " ++ i ++ " - ") alias
7476 , associativityStr
7577 , " / precedence "
7678 , show precedence
src/Language/PureScript/Docs/Convert.hs+11−8
@@ -11,6 +11,9 @@ module Language.PureScript.Docs.Convert
1111 , collectBookmarks
1212 ) where
1313
14+import Prelude ()
15+import Prelude.Compat
16+
1417import Control.Monad
1518import Control.Category ((>>>))
1619import Data.Either
@@ -68,7 +71,7 @@ type IntermediateDeclaration
6871-- with their associativity and precedence.
6972data DeclarationAugment
7073 = AugmentChild ChildDeclaration
71− | AugmentFixity P.Fixity
74+ | AugmentFixity P.Fixity (Maybe P.Ident)
7275
7376-- | Augment top-level declarations; the second pass. See the comments under
7477-- the type synonym IntermediateDeclaration for more information.
@@ -86,18 +89,18 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
8689 case a of
8790 AugmentChild child ->
8891 d { declChildren = declChildren d ++ [child] }
89− AugmentFixity fixity ->
90− d { declFixity = Just fixity }
92+ AugmentFixity fixity alias ->
93+ d { declFixity = Just (fixity, P.runIdent <$> alias) }
9194
9295-- | Add the default operator fixity for operators which do not have associated
9396-- fixity declarations.
9497--
9598-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
96−-- in 0.8.
99+-- in 0.9.
97100addDefaultFixity :: Declaration -> Declaration
98101addDefaultFixity decl@Declaration{..}
99102 | isOp declTitle && isNothing declFixity =
100− decl { declFixity = Just defaultFixity }
103+ decl { declFixity = Just (defaultFixity, Nothing) }
101104 | otherwise =
102105 decl
103106 where
@@ -113,7 +116,7 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProper
113116getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
114117getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
115118getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
116−getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
119+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
117120getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
118121getDeclarationTitle _ = Nothing
119122
@@ -170,8 +173,8 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
170173
171174 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
172175 classApp = foldl P.TypeApp (P.TypeConstructor className) tys
173−convertDeclaration (P.FixityDeclaration fixity _) title =
174− Just (Left ([title], AugmentFixity fixity))
176+convertDeclaration (P.FixityDeclaration fixity _ alias) title =
177+ Just (Left ([title], AugmentFixity fixity alias))
175178convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
176179 fmap (addComments . addSourceSpan) (convertDeclaration d' title)
177180 where
src/Language/PureScript/Docs/ParseAndDesugar.hs+1−10
@@ -105,17 +105,8 @@ fileInfoToString :: FileInfo -> FilePath
105105fileInfoToString (Local fn) = fn
106106fileInfoToString (FromDep _ fn) = fn
107107
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−
117108importPrim :: P.Module -> P.Module
118−importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
109+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
119110
120111desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
121112desugar = P.evalSupplyT 0 . desugar'
src/Language/PureScript/Docs/Types.hs+7−4
@@ -84,7 +84,7 @@ data Declaration = Declaration
8484 , declComments :: Maybe String
8585 , declSourceSpan :: Maybe P.SourceSpan
8686 , declChildren :: [ChildDeclaration]
87− , declFixity :: Maybe P.Fixity
87+ , declFixity :: Maybe (P.Fixity, Maybe String)
8888 , declInfo :: DeclarationInfo
8989 }
9090 deriving (Show, Eq, Ord)
@@ -307,9 +307,12 @@ asDeclaration =
307307 <*> key "fixity" (perhaps asFixity)
308308 <*> key "info" asDeclarationInfo
309309
310−asFixity :: Parse PackageError P.Fixity
311−asFixity = P.Fixity <$> key "associativity" asAssociativity
312− <*> key "precedence" asIntegral
310+asFixity :: Parse PackageError (P.Fixity, Maybe String)
311+asFixity = do
312+ fixity <- P.Fixity <$> key "associativity" asAssociativity
313+ <*> key "precedence" asIntegral
314+ alias <- keyMay "alias" asString
315+ return (fixity, alias)
313316
314317parseAssociativity :: String -> Maybe P.Associativity
315318parseAssociativity str = case str of
src/Language/PureScript/Environment.hs+25−10
@@ -66,7 +66,7 @@ data Environment = Environment {
6666-- The initial environment with no values and only the default javascript types defined
6767--
6868initEnvironment :: 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
7070
7171-- |
7272-- The visibility of a name in scope
@@ -236,17 +236,32 @@ function :: Type -> Type -> Type
236236function t1 = TypeApp (TypeApp tyFunction t1)
237237
238238-- |
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.
240242--
241243primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
242−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
243− , (primName "Array" , (FunKind Star Star, ExternData))
244− , (primName "Object" , (FunKind (Row Star) Star, ExternData))
245− , (primName "String" , (Star, ExternData))
246− , (primName "Char" , (Star, ExternData))
247− , (primName "Number" , (Star, ExternData))
248− , (primName "Int" , (Star, ExternData))
249− , (primName "Boolean" , (Star, ExternData)) ]
244+primTypes =
245+ M.fromList
246+ [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
247+ , (primName "Array", (FunKind Star Star, ExternData))
248+ , (primName "Object", (FunKind (Row Star) Star, ExternData))
249+ , (primName "String", (Star, ExternData))
250+ , (primName "Char", (Star, ExternData))
251+ , (primName "Number", (Star, ExternData))
252+ , (primName "Int", (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", ([], [], [])) ]
250265
251266-- |
252267-- Finds information about data constructors from the current environment.
src/Language/PureScript/Errors.hs+69−19
@@ -67,8 +67,7 @@ data SimpleErrorMessage
6767 | UnknownExportModule ModuleName
6868 | UnknownImportDataConstructor ModuleName ProperName ProperName
6969 | UnknownExportDataConstructor ProperName ProperName
70− | ConflictingImport String ModuleName
71− | ConflictingImports String ModuleName ModuleName
70+ | ScopeConflict String [ModuleName]
7271 | ConflictingTypeDecls ProperName
7372 | ConflictingCtorDecls ProperName
7473 | TypeConflictsWithClass ProperName
@@ -128,6 +127,7 @@ data SimpleErrorMessage
128127 | UnusedExplicitImport ModuleName [String]
129128 | UnusedDctorImport ProperName
130129 | UnusedDctorExplicitImport ProperName [ProperName]
130+ | DeprecatedOperatorDecl String
131131 | DeprecatedQualifiedSyntax ModuleName ModuleName
132132 | DeprecatedClassImport ModuleName ProperName
133133 | DeprecatedClassExport ProperName
@@ -138,6 +138,8 @@ data SimpleErrorMessage
138138 | DuplicateExportRef String
139139 | IntOutOfRange Integer String Integer Integer
140140 | RedundantEmptyHidingImport ModuleName
141+ | ImplicitImport ModuleName [DeclarationRef]
142+ | CaseBinderLengthDiffers Int [Binder]
141143 deriving (Show)
142144
143145-- | Error message hints, providing more detailed information about failure.
@@ -175,6 +177,31 @@ data HintCategory
175177
176178data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
177179
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+
178205-- |
179206-- Get the error code for a particular error type
180207--
@@ -211,8 +238,7 @@ errorCode em = case unwrapErrorMessage em of
211238 UnknownExportModule{} -> "UnknownExportModule"
212239 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
213240 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
214− ConflictingImport{} -> "ConflictingImport"
215− ConflictingImports{} -> "ConflictingImports"
241+ ScopeConflict{} -> "ScopeConflict"
216242 ConflictingTypeDecls{} -> "ConflictingTypeDecls"
217243 ConflictingCtorDecls{} -> "ConflictingCtorDecls"
218244 TypeConflictsWithClass{} -> "TypeConflictsWithClass"
@@ -272,6 +298,7 @@ errorCode em = case unwrapErrorMessage em of
272298 UnusedExplicitImport{} -> "UnusedExplicitImport"
273299 UnusedDctorImport{} -> "UnusedDctorImport"
274300 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
301+ DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
275302 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
276303 DeprecatedClassImport{} -> "DeprecatedClassImport"
277304 DeprecatedClassExport{} -> "DeprecatedClassExport"
@@ -282,7 +309,8 @@ errorCode em = case unwrapErrorMessage em of
282309 DuplicateExportRef{} -> "DuplicateExportRef"
283310 IntOutOfRange{} -> "IntOutOfRange"
284311 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"
285−
312+ ImplicitImport{} -> "ImplicitImport"
313+ CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
286314
287315-- |
288316-- A stack trace for an error
@@ -300,7 +328,6 @@ nonEmpty = not . null . runMultipleErrors
300328errorMessage :: SimpleErrorMessage -> MultipleErrors
301329errorMessage err = MultipleErrors [ErrorMessage [] err]
302330
303−
304331-- |
305332-- Create an error set from a single error message
306333--
@@ -385,6 +412,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
385412 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
386413 gHint other = pure other
387414
415+prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box
416+prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level
417+
388418-- |
389419-- Pretty print a single error, simplifying if necessary
390420--
@@ -522,13 +552,10 @@ prettyPrintSingleError full level e = do
522552 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
523553 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
524554 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."
525− renderSimpleErrorMessage (ConflictingImport nm mn) =
526− paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn
527− , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"
528− , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"
555+ renderSimpleErrorMessage (ScopeConflict nm ms) =
556+ paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"
557+ , indent $ paras $ map (line . runModuleName) ms
529558 ]
530− renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
531− line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
532559 renderSimpleErrorMessage (ConflictingTypeDecls nm) =
533560 line $ "Conflicting type declarations for " ++ runProperName nm
534561 renderSimpleErrorMessage (ConflictingCtorDecls nm) =
@@ -715,8 +742,9 @@ prettyPrintSingleError full level e = do
715742 , 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."
716743 ]
717744 renderSimpleErrorMessage (TransitiveExportError x ys) =
718− paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
719− : map (line . prettyPrintExport) ys
745+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
746+ , indent $ paras $ map (line . prettyPrintExport) ys
747+ ]
720748 renderSimpleErrorMessage (ShadowedName nm) =
721749 line $ "Name '" ++ showIdent nm ++ "' was shadowed."
722750 renderSimpleErrorMessage (ShadowedTypeVar tv) =
@@ -747,9 +775,12 @@ prettyPrintSingleError full level e = do
747775 renderSimpleErrorMessage (NotExhaustivePattern bs b) =
748776 paras $ [ line "A case expression could not be determined to cover all inputs."
749777 , line "The following additional cases are required to cover all inputs:\n"
750− , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
751− ] ++
752− [ line "..." | not b ]
778+ , indent $ paras $
779+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
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+ ]
753784 renderSimpleErrorMessage (OverlappingPattern bs b) =
754785 paras $ [ line "A case expression contains unreachable cases:\n"
755786 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
@@ -773,6 +804,13 @@ prettyPrintSingleError full level e = do
773804 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
774805 , indent $ paras $ map (line .runProperName) names ]
775806
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+
776814 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
777815 paras [ line $ "Import uses the deprecated 'qualified' syntax:"
778816 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName
@@ -819,6 +857,16 @@ prettyPrintSingleError full level e = do
819857 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =
820858 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."
821859
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+
822870 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
823871 renderHint (ErrorUnifyingTypes t1 t2) detail =
824872 paras [ detail
@@ -954,9 +1002,10 @@ prettyPrintSingleError full level e = do
9541002
9551003 prettyPrintRef :: DeclarationRef -> String
9561004 prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1005+ prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
9571006 prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
9581007 prettyPrintRef (ValueRef ident) = showIdent ident
959− prettyPrintRef (TypeClassRef pn) = runProperName pn
1008+ prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
9601009 prettyPrintRef (ProperRef pn) = runProperName pn
9611010 prettyPrintRef (TypeInstanceRef ident) = showIdent ident
9621011 prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
@@ -965,7 +1014,8 @@ prettyPrintSingleError full level e = do
9651014 prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
9661015 prettyPrintImport mn idt qual =
9671016 let i = case idt of
968− Implicit -> runModuleName mn
1017+ Implicit True -> runModuleName mn ++ " (..)"
1018+ Implicit False -> runModuleName mn
9691019 Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
9701020 Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
9711021 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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
161{-# LANGUAGE RecordWildCards #-}
172{-# LANGUAGE PatternGuards #-}
183{-# LANGUAGE TemplateHaskell #-}
194
5+-- |
6+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
7+--
208module Language.PureScript.Externs
219 ( ExternsFile(..)
2210 , ExternsImport(..)
@@ -84,6 +72,8 @@ data ExternsFixity = ExternsFixity
8472 , efPrecedence :: Precedence
8573 -- | The operator symbol
8674 , efOperator :: String
75+ -- | The value the operator is an alias for
76+ , efAlias :: Maybe Ident
8777 } deriving (Show, Read)
8878
8979-- | A type or value declaration appearing in an externs file
@@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
163153 efDeclarations = concatMap toExternsDeclaration efExports
164154
165155 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)
167157 where
168158 exportsOp :: DeclarationRef -> Bool
169159 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
src/Language/PureScript/Linter.hs+6−16
@@ -1,21 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Linter
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
151{-# LANGUAGE FlexibleContexts #-}
162{-# LANGUAGE ScopedTypeVariables #-}
173{-# LANGUAGE PatternGuards #-}
184
5+-- |
6+-- This module implements a simple linting pass on the PureScript AST.
7+--
198module Language.PureScript.Linter (lint, module L) where
209
2110import Prelude ()
@@ -66,11 +55,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
6655 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec
6756
6857 stepD :: S.Set Ident -> Declaration -> MultipleErrors
69− stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls
58+ stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)
59+ stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls
7060 where
7161 go :: Declaration -> MultipleErrors
7262 go (PositionedDeclaration _ _ d') = go d'
73− go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op)
63+ go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)
7464 go _ = mempty
7565 stepD _ _ = mempty
7666
src/Language/PureScript/Linter/Exhaustive.hs+41−30
@@ -19,10 +19,7 @@
1919{-# LANGUAGE FlexibleContexts #-}
2020{-# LANGUAGE ScopedTypeVariables #-}
2121
22−module Language.PureScript.Linter.Exhaustive
23− ( checkExhaustive
24− , checkExhaustiveModule
25− ) where
22+module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
2623
2724import Prelude ()
2825import Prelude.Compat
@@ -48,7 +45,7 @@ import Language.PureScript.Errors
4845
4946-- | There are two modes of failure for the redudancy check:
5047--
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.
5249-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
5350--
5451-- We want to warn the user in the first case.
@@ -239,8 +236,8 @@ missingAlternative env mn ca uncovered
239236-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
240237-- Then, returns the uncovered set of case alternatives.
241238--
242−checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
243−checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
239+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
240+checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
244241 where
245242 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
246243 step (uncovered, (nec, redundant)) ca =
@@ -258,13 +255,13 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
258255
259256 makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
260257 makeResult (bss, (rr, bss')) =
261− do unless (null bss) tellExhaustive
258+ do unless (hasConstraint || null bss) tellNonExhaustive
262259 unless (null bss') tellRedundant
263260 case rr of
264− Left Incomplete -> tellIncomplete
261+ Left Incomplete -> unless hasConstraint tellIncomplete
265262 _ -> return ()
266263 where
267− tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
264+ tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
268265 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
269266 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
270267
@@ -279,29 +276,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl
279276 where
280277 convert :: (Ident, NameKind, Expr) -> Declaration
281278 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)
283280 onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
284281 onDecl _ = return ()
285282
286− onExpr :: Expr -> m ()
287− onExpr (UnaryMinus e) = onExpr e
288− onExpr (ArrayLiteral es) = mapM_ onExpr es
289− onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
290− onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
291− onExpr (Accessor _ e) = onExpr e
292− onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
293− onExpr (Abs _ e) = onExpr e
294− onExpr (App e1 e2) = onExpr e1 >> onExpr e2
295− onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
296− onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
297− onExpr (TypedValue _ e _) = onExpr e
298− onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
299− onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
300− onExpr _ = return ()
301−
302− onCaseAlternative :: CaseAlternative -> m ()
303− onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
304− onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
283+ onExpr :: Bool -> Expr -> m ()
284+ onExpr isP (UnaryMinus e) = onExpr isP e
285+ onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
286+ onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
287+ onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
288+ onExpr isP (Accessor _ e) = onExpr isP e
289+ onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
290+ onExpr isP (Abs _ e) = onExpr isP e
291+ onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2
292+ onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3
293+ onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas
294+ onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e
295+ onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e
296+ onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)
297+ onExpr _ _ = return ()
298+
299+ onCaseAlternative :: Bool -> CaseAlternative -> m ()
300+ onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es
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
305316
306317-- |
307318-- Exhaustivity checking over a single module
src/Language/PureScript/Linter/Imports.hs+40−2
@@ -16,6 +16,7 @@ import Data.Foldable (forM_)
1616
1717import Language.PureScript.AST.Declarations
1818import Language.PureScript.AST.SourcePos
19+import Language.PureScript.Crash
1920import Language.PureScript.Names as P
2021
2122import Language.PureScript.Errors
@@ -30,6 +31,19 @@ data Name
3031 | TypeName (Qualified ProperName)
3132 | DctorName (Qualified ProperName)
3233 | 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
3347
3448-- | Map of module name to list of imported names from that module which have been used.
3549type UsedImports = M.Map ModuleName [Name]
@@ -44,11 +58,21 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
4458 forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $
4559 forM_ decls $ \(ss, declType, qualifierName) ->
4660 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
4862 usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
4963 usedDctors = mapMaybe (matchDctor qualifierName) names
5064 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)
5276 Explicit declrefs -> do
5377 let idents = nub (mapMaybe runDeclRef declrefs)
5478 let diff = idents \\ usedNames
@@ -76,6 +100,20 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
76100 sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]
77101 sugarNames _ = []
78102
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+
79117 -- rely on exports being elaborated by this point
80118 alwaysUsedModules :: [ ModuleName ]
81119 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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
151{-# LANGUAGE DataKinds #-}
162{-# LANGUAGE FlexibleContexts #-}
173{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -225,8 +211,9 @@ make MakeActions{..} ms = do
225211 progress $ CompilingModule moduleName
226212 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
227213 lint m
228− ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
229− (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
214+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
215+ [desugared] <- desugar externs [m]
216+ runCheck' env $ typeCheckModule desugared
230217 checkExhaustiveModule env' checked
231218 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
232219 let mod' = Module ss coms moduleName regrouped exps
@@ -266,18 +253,6 @@ make MakeActions{..} ms = do
266253 guard $ efVersion externs == showVersion Paths.version
267254 return externs
268255
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−
281256importPrim :: Module -> Module
282257importPrim = addDefaultImport (ModuleName [ProperName C.prim])
283258
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−
161{-# LANGUAGE DeriveDataTypeable #-}
172{-# LANGUAGE DeriveFunctor #-}
183{-# LANGUAGE TemplateHaskell #-}
194{-# LANGUAGE GADTs #-}
205
6+-- |
7+-- Data types for names
8+--
219module Language.PureScript.Names where
2210
11+import Control.Monad (liftM)
12+import Control.Monad.Supply.Class
13+
2314import Data.List
2415import Data.Data
2516import Data.List.Split (splitOn)
@@ -38,15 +29,27 @@ data Ident
3829 -- |
3930 -- A symbolic name for an infix operator
4031 --
41− | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)
32+ | Op String
33+ -- |
34+ -- A generated name for an identifier
35+ --
36+ | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)
4237
4338runIdent :: Ident -> String
4439runIdent (Ident i) = i
4540runIdent (Op op) = op
41+runIdent (GenIdent Nothing n) = "$" ++ show n
42+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
4643
4744showIdent :: Ident -> String
48−showIdent (Ident i) = i
4945showIdent (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
5053
5154-- |
5255-- 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
2727
2828import qualified Text.Parsec as P
2929
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−
3530properName :: TokenParser ProperName
3631properName = ProperName <$> uname
3732
src/Language/PureScript/Parser/Declarations.hs+77−69
@@ -33,6 +33,7 @@ import Language.PureScript.Environment
3333import Language.PureScript.Errors
3434import Language.PureScript.Kinds
3535import Language.PureScript.Names
36+import Language.PureScript.Types
3637import Language.PureScript.Parser.Common
3738import Language.PureScript.Parser.Kinds
3839import Language.PureScript.Parser.Lexer
@@ -75,7 +76,7 @@ parseTypeDeclaration =
7576
7677parseTypeSynonymDeclaration :: TokenParser Declaration
7778parseTypeSynonymDeclaration =
78− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
79+ TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
7980 <*> many (indented *> kindedIdent)
8081 <*> (indented *> equals *> noWildcards parsePolyType)
8182
@@ -101,21 +102,18 @@ parseValueDeclaration = do
101102 return $ maybe value (`Let` value) whereClause
102103
103104parseExternDeclaration :: TokenParser Declaration
104−parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
105− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
105+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>
106+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)
106107 <*> (indented *> doubleColon *> parseKind)
107108 <|> (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."
111109 ty <- indented *> doubleColon *> noWildcards parsePolyType
112110 return $ ExternDeclaration ident ty))
113111
114112parseAssociativity :: TokenParser Associativity
115113parseAssociativity =
116− (P.try (reserved "infixl") >> return Infixl) <|>
117− (P.try (reserved "infixr") >> return Infixr) <|>
118− (P.try (reserved "infix") >> return Infix)
114+ (reserved "infixl" *> return Infixl) <|>
115+ (reserved "infixr" *> return Infixr) <|>
116+ (reserved "infix" *> return Infix)
119117
120118parseFixity :: TokenParser Fixity
121119parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
@@ -124,8 +122,9 @@ parseFixityDeclaration :: TokenParser Declaration
124122parseFixityDeclaration = do
125123 fixity <- parseFixity
126124 indented
125+ alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"
127126 name <- symbol
128− return $ FixityDeclaration fixity name
127+ return $ FixityDeclaration fixity name alias
129128
130129parseImportDeclaration :: TokenParser Declaration
131130parseImportDeclaration = do
@@ -152,9 +151,10 @@ parseImportDeclaration' = do
152151 qName <- qualifiedName
153152 return (moduleName', declType, Just qName, True)
154153 qualifyingList expectedType = do
155− idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)
156− return $ fromMaybe Implicit (expectedType <$> idents)
157−
154+ declType <- P.optionMaybe
155+ $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))
156+ <|> (const (Implicit True) <$> (indented *> parens (symbol' "..")))
157+ return $ fromMaybe (Implicit False) declType
158158
159159parseDeclarationRef :: TokenParser DeclarationRef
160160parseDeclarationRef =
@@ -172,9 +172,9 @@ parseDeclarationRef =
172172parseTypeClassDeclaration :: TokenParser Declaration
173173parseTypeClassDeclaration = do
174174 reserved "class"
175− implies <- P.option [] $ do
175+ implies <- P.option [] . P.try $ do
176176 indented
177− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
177+ implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
178178 lfatArrow
179179 return implies
180180 className <- indented *> properName
@@ -183,13 +183,17 @@ parseTypeClassDeclaration = do
183183 indented *> reserved "where"
184184 indented *> mark (P.many (same *> positioned parseTypeDeclaration))
185185 return $ TypeClassDeclaration className idents implies members
186+ where
187+
188+parseConstraint :: TokenParser Constraint
189+parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)
186190
187191parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
188192parseInstanceDeclaration = do
189193 reserved "instance"
190194 name <- parseIdent <* indented <* doubleColon
191− deps <- P.optionMaybe $ do
192− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
195+ deps <- P.optionMaybe $ P.try $ do
196+ deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
193197 indented
194198 rfatArrow
195199 return deps
@@ -321,11 +325,12 @@ parseIdentifierAndValue =
321325 <|> (,) <$> (C.indented *> stringLiteral) <*> rest
322326 where
323327 rest = C.indented *> colon *> C.indented *> val
324− val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
328+ val = (underscore *> pure Nothing) <|> (Just <$> parseValue)
325329
326330parseAbs :: TokenParser Expr
327331parseAbs = do
328332 symbol' "\\"
333+ -- TODO: remove this 'try' after operator aliases are finished (0.9)
329334 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
330335 C.indented *> rarrow
331336 value <- parseValue
@@ -341,11 +346,11 @@ parseConstructor :: TokenParser Expr
341346parseConstructor = Constructor <$> C.parseQualified C.properName
342347
343348parseCase :: 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)
345350 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))
346351
347352parseCaseAlternative :: TokenParser CaseAlternative
348−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
353+parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)
349354 <*> (Left <$> (C.indented *>
350355 P.many1 ((,) <$> parseGuard
351356 <*> (indented *> rarrow *> parseValue)
@@ -370,23 +375,25 @@ parseLet = do
370375
371376parseValueAtom :: TokenParser Expr
372377parseValueAtom = P.choice
373− [ P.try parseNumericLiteral
374− , P.try parseCharLiteral
375− , P.try parseStringLiteral
376− , P.try parseBooleanLiteral
377− , parseArrayLiteral
378− , P.try parseObjectLiteral
379− , P.try parseObjectGetter
380− , parseAbs
381− , P.try parseConstructor
382− , P.try parseVar
383− , parseCase
384− , parseIfThenElse
385− , parseDo
386− , parseLet
387− , P.try $ Parens <$> parens parseValue
388− , parseOperatorSection
389− , P.try parseObjectUpdaterWildcard ]
378+ [ parseNumericLiteral
379+ , parseCharLiteral
380+ , parseStringLiteral
381+ , parseBooleanLiteral
382+ , parseArrayLiteral
383+ , P.try parseObjectLiteral
384+ , P.try parseObjectGetter
385+ , parseAbs
386+ , P.try parseConstructor
387+ , P.try parseVar
388+ , parseCase
389+ , parseIfThenElse
390+ , parseDo
391+ , parseLet
392+ , P.try $ Parens <$> parens parseValue
393+ , parseOperatorSection
394+ -- TODO: combine this with parseObjectGetter
395+ , parseObjectUpdaterWildcard
396+ ]
390397
391398-- |
392399-- Parse an expression in backticks or an operator
@@ -422,13 +429,14 @@ parseDoNotationLet :: TokenParser DoNotationElement
422429parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
423430
424431parseDoNotationBind :: TokenParser DoNotationElement
425−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
432+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue
426433
427434parseDoNotationElement :: TokenParser DoNotationElement
428435parseDoNotationElement = P.choice
429− [ P.try parseDoNotationBind
436+ [ parseDoNotationBind
430437 , parseDoNotationLet
431− , P.try (DoNotationValue <$> parseValue) ]
438+ , DoNotationValue <$> parseValue
439+ ]
432440
433441parseObjectGetter :: TokenParser Expr
434442parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
@@ -438,7 +446,8 @@ indexersAndAccessors :: TokenParser Expr
438446indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom
439447 where
440448 postfixTable = [ parseAccessor
441− , P.try . parseUpdaterBody . Just ]
449+ , P.try . parseUpdaterBody . Just
450+ ]
442451
443452-- |
444453-- Parse a value
@@ -450,9 +459,9 @@ parseValue = withSourceSpan PositionedValue
450459 $ indexersAndAccessors) P.<?> "expression"
451460 where
452461 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
454463 ]
455− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
464+ operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)
456465 ]
457466 , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
458467 return (BinaryNoParens ident)) P.AssocRight
@@ -482,9 +491,6 @@ parseNumberBinder = NumberBinder <$> (sign <*> number)
482491 <|> (symbol' "+" >> return id)
483492 <|> return id
484493
485−parseVarBinder :: TokenParser Binder
486−parseVarBinder = VarBinder <$> C.parseIdent
487−
488494parseNullaryConstructorBinder :: TokenParser Binder
489495parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
490496
@@ -497,9 +503,13 @@ parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdenti
497503parseArrayBinder :: TokenParser Binder
498504parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
499505
500−parseNamedBinder :: TokenParser Binder
501−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
502− <*> (C.indented *> parseBinder)
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
511+ let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder)
512+ parseNamedBinder <|> return (VarBinder name)
503513
504514parseNullBinder :: TokenParser Binder
505515parseNullBinder = underscore *> return NullBinder
@@ -517,43 +527,41 @@ parseIdentifierAndBinder =
517527-- Parse a binder
518528--
519529parseBinder :: TokenParser Binder
520−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))
530+parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)
521531 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 ] ]
524532 -- 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)
526534 ]
527535 parseBinderAtom :: TokenParser Binder
528− parseBinderAtom = P.choice (map P.try
536+ parseBinderAtom = P.choice
529537 [ parseNullBinder
530538 , parseCharBinder
531539 , parseStringBinder
532540 , parseBooleanBinder
533541 , parseNumberBinder
534− , parseNamedBinder
535− , parseVarBinder
542+ , parseVarOrNamedBinder
536543 , parseConstructorBinder
537544 , parseObjectBinder
538545 , parseArrayBinder
539− , parens parseBinder ]) P.<?> "binder"
546+ , parens parseBinder
547+ ] P.<?> "binder"
540548
541549-- |
542550-- Parse a binder as it would appear in a top level declaration
543551--
544552parseBinderNoParens :: TokenParser Binder
545−parseBinderNoParens = P.choice (map P.try
546− [ parseNullBinder
547− , parseCharBinder
548− , parseStringBinder
549− , parseBooleanBinder
550− , parseNumberBinder
551− , parseNamedBinder
552− , parseVarBinder
553− , parseNullaryConstructorBinder
554− , parseObjectBinder
555− , parseArrayBinder
556− , parens parseBinder ]) P.<?> "binder"
553+parseBinderNoParens = P.choice
554+ [ parseNullBinder
555+ , parseCharBinder
556+ , parseStringBinder
557+ , parseBooleanBinder
558+ , parseNumberBinder
559+ , parseVarOrNamedBinder
560+ , parseNullaryConstructorBinder
561+ , parseObjectBinder
562+ , parseArrayBinder
563+ , parens parseBinder
564+ ] P.<?> "binder"
557565
558566-- |
559567-- Parse a guard
src/Language/PureScript/Parser/Kinds.hs+4−3
@@ -33,10 +33,11 @@ parseBang :: TokenParser Kind
3333parseBang = const Bang <$> symbol' "!"
3434
3535parseTypeAtom :: TokenParser Kind
36−parseTypeAtom = indented *> P.choice (map P.try
36+parseTypeAtom = indented *> P.choice
3737 [ parseStar
3838 , parseBang
39− , parens parseKind ])
39+ , parens parseKind
40+ ]
4041-- |
4142-- Parse a kind
4243--
@@ -44,4 +45,4 @@ parseKind :: TokenParser Kind
4445parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
4546 where
4647 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
6767 , natural
6868 , reservedPsNames
6969 , reservedTypeNames
70− , opChars
70+ , isSymbolChar
7171 )
7272 where
7373
7474import Prelude hiding (lex)
7575
76−import Data.Char (isSpace)
76+import Data.Char (isSpace, isAscii, isSymbol)
7777
7878import Control.Monad (void, guard)
7979import Data.Functor.Identity
@@ -233,7 +233,7 @@ parseToken = P.choice
233233 uidentLetter = P.alphaNum <|> P.char '_'
234234
235235 symbolChar :: P.Parsec String u Char
236− symbolChar = P.oneOf opChars
236+ symbolChar = P.satisfy isSymbolChar
237237
238238 parseCharLiteral :: P.Parsec String u Char
239239 parseCharLiteral = PT.charLiteral tokenParser
@@ -516,5 +516,5 @@ reservedTypeNames = [ "forall", "where" ]
516516-- |
517517-- The characters allowed for use in operators
518518--
519−opChars :: [Char]
520−opChars = ":!#$%&*+./<=>?@\\^|-~"
519+isSymbolChar :: Char -> Bool
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−
161module Language.PureScript.Parser.Types (
172 parseType,
183 parsePolyType,
@@ -32,19 +17,8 @@ import Language.PureScript.Environment
3217import qualified Text.Parsec as P
3318import qualified Text.Parsec.Expr as P
3419
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−
4620parseFunction :: TokenParser Type
47−parseFunction = parens $ rarrow >> return tyFunction
21+parseFunction = parens rarrow >> return tyFunction
4822
4923parseObject :: TokenParser Type
5024parseObject = braces $ TypeApp tyObject <$> parseRow
@@ -62,45 +36,48 @@ parseTypeConstructor :: TokenParser Type
6236parseTypeConstructor = TypeConstructor <$> parseQualified properName
6337
6438parseForAll :: 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)
6640 <*> parseType
6741
6842-- |
6943-- Parse a type as it appears in e.g. a data constructor
7044--
7145parseTypeAtom :: TokenParser Type
72−parseTypeAtom = indented *> P.choice (map P.try
73− [ parseArray
74− , parseArrayOf
75− , parseFunction
46+parseTypeAtom = indented *> P.choice
47+ [ P.try parseConstrainedType
48+ , P.try parseFunction
7649 , parseObject
7750 , parseTypeWildcard
51+ , parseForAll
7852 , parseTypeVariable
7953 , parseTypeConstructor
80− , parseForAll
81− , parens parseRow
82− , parseConstrainedType
54+ -- This try is needed due to some unfortunate ambiguities between rows and kinded types
55+ , P.try (parens parseRow)
8356 , parens parsePolyType
84− ])
57+ ]
8558
8659parseConstrainedType :: TokenParser Type
8760parseConstrainedType = do
88− constraints <- parens . commaSep1 $ do
89− className <- parseQualified properName
90− indented
91− ty <- P.many parseTypeAtom
92− return (className, ty)
61+ constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
9362 _ <- rfatArrow
9463 indented
9564 ty <- parseType
9665 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+
9773
9874parseAnyType :: TokenParser Type
9975parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
10076 where
10177 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
102− , [ P.Infix (rarrow >> return function) P.AssocRight ] ]
103− postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)
78+ , [ P.Infix (rarrow >> return function) P.AssocRight ]
79+ ]
80+ postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)
10481 ]
10582
10683-- |
src/Language/PureScript/Pretty/Common.hs+2−2
@@ -18,7 +18,7 @@ module Language.PureScript.Pretty.Common where
1818import Control.Monad.State
1919import Data.List (intercalate)
2020
21−import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)
21+import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)
2222
2323import Text.PrettyPrint.Boxes
2424
@@ -68,7 +68,7 @@ prettyPrintMany f xs = do
6868--
6969prettyPrintObjectKey :: String -> String
7070prettyPrintObjectKey s | s `elem` reservedPsNames = show s
71− | any (`elem` opChars) s = show s
71+ | any isSymbolChar s = show s
7272 | otherwise = s
7373
7474-- | 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
121121 match _ = Nothing
122122
123123matchTypeAtom :: Pattern () Type Box
124−matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType
124+matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType
125125
126126matchType :: Pattern () Type Box
127127matchType = buildPrettyPrinter operators matchTypeAtom
128128 where
129129 operators :: OperatorTable () Type Box
130130 operators =
131− OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]
132− , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)
133− ]
131+ OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
132+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]
134133 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]
135− , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]
136− , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ]
134+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]
135+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]
137136 ]
138137
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+
139145forall_ :: Pattern () Type ([String], Type)
140146forall_ = mkPattern match
141147 where
src/Language/PureScript/Pretty/Values.hs+1
@@ -160,6 +160,7 @@ prettyPrintBinderAtom (ArrayBinder bs) =
160160 ++ " ]"
161161prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
162162prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
163+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
163164prettyPrintBinderAtom b = parens (prettyPrintBinder b)
164165
165166-- |
src/Language/PureScript/Renamer.hs+27−29
@@ -1,22 +1,9 @@
1−-----------------------------------------------------------------------------
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.PureScript.Renamer
5−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
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−
171{-# LANGUAGE FlexibleContexts #-}
182{-# LANGUAGE ScopedTypeVariables #-}
193
4+-- |
5+-- Renaming pass that prevents shadowing of local identifiers.
6+--
207module Language.PureScript.Renamer (renameInModules) where
218
229import Prelude ()
@@ -25,6 +12,7 @@ import Prelude.Compat
2512import Control.Monad.State
2613
2714import Data.List (find)
15+import Data.Maybe (fromJust, fromMaybe)
2816
2917import qualified Data.Map as M
3018import qualified Data.Set as S
@@ -76,19 +64,29 @@ newScope x = do
7664-- unique name is generated and stored.
7765--
7866updateScope :: Ident -> Rename Ident
79−updateScope i@(Ident name) | name == C.__unused = return i
80−updateScope name = do
81− scope <- get
82− name' <- if name `S.member` rsUsedNames scope
83− then do
84− let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
85− Just newName = find (`S.notMember` rsUsedNames scope) newNames
86− return newName
87− else return name
88− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
89− , rsUsedNames = S.insert name' (rsUsedNames s)
90− }
91− return name'
67+updateScope ident =
68+ case ident of
69+ Ident name | name == C.__unused -> return ident
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
75+ scope <- get
76+ let usedNames = rsUsedNames scope
77+ name' =
78+ if baseName `S.member` usedNames
79+ then getNewName usedNames baseName
80+ else baseName
81+ modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)
82+ , rsUsedNames = S.insert name' (rsUsedNames s)
83+ }
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..] ]
9290
9391-- |
9492-- Finds the new name to use for an ident.
src/Language/PureScript/Sugar/CaseDeclarations.hs+42−28
@@ -1,22 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CaseDeclarations
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
114-- |
125-- This module implements the desugaring pass which replaces top-level binders with
136-- case expressions.
147--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
208module Language.PureScript.Sugar.CaseDeclarations (
219 desugarCases,
2210 desugarCasesModule
@@ -26,8 +14,8 @@ import Prelude ()
2614import Prelude.Compat
2715
2816import Language.PureScript.Crash
29−import Data.Maybe (catMaybes)
30−import Data.List (nub, groupBy)
17+import Data.Maybe (catMaybes, mapMaybe)
18+import Data.List (nub, groupBy, foldl1')
3119
3220import Control.Monad ((<=<), forM, replicateM, join, unless)
3321import Control.Monad.Error.Class (MonadError(..))
@@ -51,26 +39,54 @@ isLeft (Right _) = False
5139desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
5240desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
5341 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
5571
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]
5773desugarAbs = flip parU f
5874 where
5975 (f, _, _) = everywhereOnValuesM return replace return
6076
61− replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
77+ replace :: Expr -> m Expr
6278 replace (Abs (Right binder) val) = do
63− ident <- Ident <$> freshName
79+ ident <- freshIdent'
6480 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
6581 replace other = return other
6682
6783-- |
6884-- Replace all top-level binders with case expressions.
6985--
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]
7187desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
7288 where
73− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
89+ desugarRest :: [Declaration] -> m [Declaration]
7490 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
7591 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
7692 desugarRest (ValueDeclaration name nameKind bs result : rest) =
@@ -108,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
108124 isVarBinder _ = False
109125
110126 fromVarBinder :: Binder -> m Ident
111− fromVarBinder NullBinder = Ident <$> freshName
127+ fromVarBinder NullBinder = freshIdent'
112128 fromVarBinder (VarBinder name) = return name
113129 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
114130 fromVarBinder (TypedBinder _ b) = fromVarBinder b
@@ -137,7 +153,7 @@ makeCaseDeclaration ident alternatives = do
137153 argNames = map join $ foldl1 resolveNames namedArgs
138154 args <- if allUnique (catMaybes argNames)
139155 then mapM argName argNames
140− else replicateM (length argNames) (Ident <$> freshName)
156+ else replicateM (length argNames) freshIdent'
141157 let vars = map (Var . Qualified Nothing) args
142158 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
143159 value = foldr (Abs . Left) (Case vars binders) args
@@ -162,9 +178,7 @@ makeCaseDeclaration ident alternatives = do
162178
163179 argName :: Maybe Ident -> m Ident
164180 argName (Just name) = return name
165− argName _ = do
166− name <- freshName
167− return (Ident name)
181+ argName _ = freshIdent'
168182
169183 -- Combine two lists of potential names from two case alternatives
170184 -- by zipping correspoding columns.
src/Language/PureScript/Sugar/DoNotation.hs+4−16
@@ -1,22 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.DoNotation
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
114-- |
125-- This module implements the desugaring pass which replaces do-notation statements with
136-- appropriate calls to bind from the Prelude.Monad type class.
147--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
208module Language.PureScript.Sugar.DoNotation (
219 desugarDoModule
2210) where
@@ -68,7 +56,7 @@ desugarDo d =
6856 return $ App (App bind val) (Abs (Left ident) rest')
6957 go (DoNotationBind binder val : rest) = do
7058 rest' <- go rest
71− ident <- Ident <$> freshName
59+ ident <- freshIdent'
7260 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
7361 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
7462 go (DoNotationLet ds : rest) = do
src/Language/PureScript/Sugar/Names.hs+26−19
@@ -50,7 +50,7 @@ desugarImports externs modules = do
5050 ss = internalModuleSourceSpan "<Externs>"
5151 env' = M.insert efModuleName (ss, nullImports, members) env
5252 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)
5454 exps <- resolveExports env' efModuleName imps members efExports
5555 return $ M.insert efModuleName (ss, imps, exps) env
5656 where
@@ -197,16 +197,16 @@ renameInModule env imports (Module ss coms mn decls exps) =
197197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)
198198
199199 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)
201201
202202 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)
204204
205205 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)
207207
208208 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)
210210
211211 -- Used when performing an update to qualify values and classes with their
212212 -- module of original definition.
@@ -226,25 +226,30 @@ renameInModule env imports (Module ss coms mn decls exps) =
226226 -- Update names so unqualified references become qualified, and locally
227227 -- qualified references are replaced with their canoncial qualified names
228228 -- (e.g. M.Map -> Data.Map.Map).
229− update :: (Ord a) => (Qualified a -> SimpleErrorMessage)
230− -> M.Map (Qualified a) (Qualified a, ModuleName)
231− -> (Exports -> a -> Maybe (Qualified a))
232− -> (Qualified a -> Name)
233− -> Qualified a
234− -> Maybe SourceSpan
235− -> m (Qualified a)
236− update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $
229+ update
230+ :: (Ord a, Show a)
231+ => (Qualified a -> SimpleErrorMessage)
232+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
233+ -> (Exports -> a -> Maybe (Qualified a))
234+ -> (Qualified a -> Name)
235+ -> (a -> String)
236+ -> Qualified a
237+ -> Maybe SourceSpan
238+ -> m (Qualified a)
239+ update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $
237240 case (M.lookup qname imps, mn') of
241+
238242 -- We found the name in our imports, so we return the name for it,
239243 -- qualifying with the name of the module it was originally defined in
240244 -- rather than the module we're importing from, to handle the case of
241− -- re-exports.
242− (Just (qn, mnOrig), _) -> do
243− case qn of
244− Qualified (Just mnNew) _ ->
245− modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
246− _ -> return ()
245+ -- re-exports. If there are multiple options for the name to resolve to
246+ -- in scope, we throw an error.
247+ (Just options, _) -> do
248+ checkImportConflicts render options
249+ let (Qualified (Just mnNew) _, mnOrig) = head options
250+ modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
247251 return $ Qualified (Just mnOrig) name
252+
248253 -- If the name wasn't found in our imports but was qualified then we need
249254 -- to check whether it's a failed import from a "pseudo" module (created
250255 -- 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) =
252257 (Nothing, Just mn'') -> do
253258 modExports <- getExports env mn''
254259 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)
260+
255261 -- If neither of the above cases are true then it's an undefined or
256262 -- unimported symbol.
257263 _ -> throwError . errorMessage $ unknown qname
264+
258265 where
259266 positioned err = case pos of
260267 Nothing -> err
src/Language/PureScript/Sugar/Names/Env.hs+44−12
@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
23
34module Language.PureScript.Sugar.Names.Env
45 ( Imports(..)
@@ -14,14 +15,19 @@ module Language.PureScript.Sugar.Names.Env
1415 , exportTypeClass
1516 , exportValue
1617 , getExports
18+ , checkImportConflicts
1719 ) where
1820
21+import Data.Function (on)
22+import Data.List (groupBy, sortBy, nub)
23+import Data.Maybe (fromJust)
1924import qualified Data.Map as M
2025
2126import Control.Monad
2227import Control.Monad.Error.Class (MonadError(..))
2328
2429import Language.PureScript.AST
30+import Language.PureScript.Crash
2531import Language.PureScript.Names
2632import Language.PureScript.Environment
2733import Language.PureScript.Errors
@@ -34,19 +40,19 @@ data Imports = Imports
3440 -- |
3541 -- Local names for types within a module mapped to to their qualified names
3642 --
37− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
43+ importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
3844 -- |
3945 -- Local names for data constructors within a module mapped to to their qualified names
4046 --
41− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
47+ , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
4248 -- |
4349 -- Local names for classes within a module mapped to to their qualified names
4450 --
45− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
51+ , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
4652 -- |
4753 -- Local names for values within a module mapped to to their qualified names
4854 --
49− , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)
55+ , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]
5056 -- |
5157 -- The list of modules that have been imported into the current scope.
5258 --
@@ -116,9 +122,10 @@ envModuleExports (_, _, exps) = exps
116122-- The exported types from the @Prim@ module
117123--
118124primExports :: Exports
119−primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
125+primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
120126 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)
122129
123130-- | Environment which only contains the Prim module.
124131primEnv :: Env
@@ -132,15 +139,17 @@ primEnv = M.singleton
132139--
133140exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports
134141exportType exps name dctors mn = do
135− let exTypes = exportedTypes exps
142+ let exTypes' = exportedTypes exps
143+ let exTypes = filter ((/= mn) . snd) exTypes'
136144 let exDctors = (snd . fst) `concatMap` exTypes
137145 let exClasses = exportedTypeClasses exps
138− when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name
146+
147+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
139148 when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
140149 forM_ dctors $ \dctor -> do
141150 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
142151 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' }
144153
145154-- |
146155-- 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
149158exportTypeClass exps name mn = do
150159 let exTypes = exportedTypes exps
151160 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
153162 when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
154163 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
155164 return $ exps { exportedTypeClasses = classes }
@@ -168,9 +177,9 @@ exportValue exps name mn = do
168177--
169178addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
170179addExport what name mn exports =
171− if any ((== name) . fst) exports
180+ if any (\(name', mn') -> name == name' && mn /= mn') exports
172181 then throwConflictError what name
173− else return $ (name, mn) : exports
182+ else return $ nub $ (name, mn) : exports
174183
175184-- |
176185-- Raises an error for when there is more than one definition for something.
@@ -181,3 +190,26 @@ throwConflictError conflict = throwError . errorMessage . conflict
181190-- Gets the exports for a module, or an error message if the module doesn't exist
182191getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports
183192getExports 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−
141{-# LANGUAGE FlexibleContexts #-}
152{-# LANGUAGE RankNTypes #-}
163{-# LANGUAGE ScopedTypeVariables #-}
@@ -60,6 +47,7 @@ findExportable (Module _ _ mn ds _) =
6047 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn
6148 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn
6249 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn
50+ updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn
6351 updateExports exps (ExternDeclaration name _) = exportValue exps name mn
6452 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d
6553 updateExports exps _ = return exps
@@ -110,20 +98,30 @@ resolveExports env mn imps exps refs =
11098 let isPseudo = isPseudoModule name
11199 when (not isPseudo && not (isImportedModule name)) $
112100 throwError . errorMessage . UnknownExportModule $ name
113− let reTypes = extract isPseudo name (importedTypes imps)
114− let reDctors = extract isPseudo name (importedDataConstructors imps)
115− let reClasses = extract isPseudo name (importedTypeClasses imps)
116− let reValues = extract isPseudo name (importedValues imps)
101+ reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)
102+ reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)
103+ reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)
104+ reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)
117105 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
118106 result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)
119107 foldM (uncurry . exportValue) result'' (map resolveValue reValues)
120108 elaborateModuleExports result _ = return result
121109
122110 -- 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
124− extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]
125− extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)
126− extract False name = map fst . M.elems . M.filter (eqQual name . fst)
111+ -- boolean is true the values are filtered by the qualification
112+ extract
113+ :: (Ord a)
114+ => Bool
115+ -> ModuleName
116+ -> (a -> String)
117+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
118+ -> m [Qualified a]
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
127125
128126 -- Check whether a module name refers to a "pseudo module" that came into
129127 -- existence in an import scope due to importing one or more modules as
@@ -135,7 +133,7 @@ resolveExports env mn imps exps refs =
135133 -- function to either extract the keys or values. We test the keys to see if a
136134 -- value being re-exported belongs to a qualified module, and we test the
137135 -- 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
139137 testQuals f mn' = any (eqQual mn') (f (importedTypes imps))
140138 || any (eqQual mn') (f (importedDataConstructors imps))
141139 || 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) =
7979 warned' <- (warned ++) <$>
8080 if (length unqual < 2)
8181 then return []
82− else case find (\(_, typ, _) -> typ == Implicit) unqual of
82+ else case find (\(_, typ, _) -> isImplicit typ) unqual of
8383 Just i ->
8484 for (delete i unqual) $ \i'@(pos, typ, _) -> do
8585 warn pos $ RedundantUnqualifiedImport mn typ
@@ -98,8 +98,8 @@ resolveImports env (Module ss coms currentModule decls exps) =
9898
9999 return ()
100100
101− let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports
102− resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)
101+ let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports
102+ resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)
103103 return (Module ss coms currentModule decls' exps, resolved)
104104
105105 where
@@ -138,7 +138,7 @@ resolveImports env (Module ss coms currentModule decls exps) =
138138 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do
139139 modExports <- getExports env mn
140140 typ' <- case typ of
141− Implicit -> return Implicit
141+ Implicit b -> return $ Implicit b
142142 Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs
143143 Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs
144144 return $ ImportDeclaration mn typ' qual isOldSyntax
@@ -159,18 +159,17 @@ resolveImports env (Module ss coms currentModule decls exps) =
159159resolveModuleImport
160160 :: forall m
161161 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
162− => ModuleName
163− -> Env
162+ => Env
164163 -> Imports
165164 -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
166165 -> m Imports
167−resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps
166+resolveModuleImport env ie (mn, imps) = foldM go ie imps
168167 where
169168 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
170169 go ie' (pos, typ, impQual) = do
171170 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
172171 let ie'' = ie' { importedModules = mn : importedModules ie' }
173− positioned $ resolveImport currentModule mn modExports ie'' impQual typ
172+ positioned $ resolveImport mn modExports ie'' impQual typ
174173 where
175174 positioned err = case pos of
176175 Nothing -> err
@@ -183,17 +182,16 @@ resolveImport
183182 :: forall m
184183 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
185184 => ModuleName
186− -> ModuleName
187185 -> Exports
188186 -> Imports
189187 -> Maybe ModuleName
190188 -> ImportDeclarationType
191189 -> m Imports
192−resolveImport currentModule importModule exps imps impQual = resolveByType
190+resolveImport importModule exps imps impQual = resolveByType
193191 where
194192
195193 resolveByType :: ImportDeclarationType -> m Imports
196− resolveByType Implicit = importAll importExplicit
194+ resolveByType (Implicit _) = importAll importExplicit
197195 resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs
198196 resolveByType (Hiding refs) = do
199197 imps' <- checkRefs True refs >> importAll (importNonHidden refs)
@@ -262,20 +260,20 @@ resolveImport currentModule importModule exps imps impQual = resolveByType
262260 importExplicit imp (PositionedDeclarationRef pos _ r) =
263261 warnAndRethrowWithPosition pos $ importExplicit imp r
264262 importExplicit imp (ValueRef name) = do
265− values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name
263+ let values' = updateImports (importedValues imp) (exportedValues exps) name
266264 return $ imp { importedValues = values' }
267265 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
269267 let exportedDctors :: [(ProperName, ModuleName)]
270268 exportedDctors = allExportedDataConstructors name
271269 dctorNames :: [ProperName]
272270 dctorNames = fst `map` exportedDctors
273271 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors
274272 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)
276274 return $ imp { importedTypes = types', importedDataConstructors = dctors' }
277275 importExplicit imp (TypeClassRef name) = do
278− typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name
276+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
279277 return $ imp { importedTypeClasses = typeClasses' }
280278 importExplicit _ _ = internalError "Invalid argument to importExplicit"
281279
@@ -286,33 +284,14 @@ resolveImport currentModule importModule exps imps impQual = resolveByType
286284 Nothing -> internalError "Invalid state in allExportedDataConstructors"
287285 Just ((_, dctors), mn) -> map (, mn) dctors
288286
289− -- Add something to the Imports if it does not already exist there
287+ -- Add something to an import resolution list
290288 updateImports
291289 :: (Ord a)
292− => M.Map (Qualified a) (Qualified a, ModuleName)
293− -> (a -> String)
290+ => M.Map (Qualified a) [(Qualified a, ModuleName)]
294291 -> [(a, ModuleName)]
295292 -> a
296− -> m (M.Map (Qualified a) (Qualified a, ModuleName))
297− updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of
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')
303− in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) 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"
293+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
294+ updateImports imps' exps' name =
295+ let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
296+ currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')
297+ in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'
src/Language/PureScript/Sugar/ObjectWildcards.hs+3−17
@@ -1,17 +1,3 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.ObjectWildcards
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
151{-# LANGUAGE FlexibleContexts #-}
162{-# LANGUAGE ScopedTypeVariables #-}
173
@@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
4430 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
4531 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
4632 desugarExpr (ObjectUpdater Nothing ps) = do
47− obj <- Ident <$> freshName
33+ obj <- freshIdent'
4834 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
4935 desugarExpr (ObjectGetter prop) = do
50− arg <- Ident <$> freshName
36+ arg <- freshIdent'
5137 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
5238 desugarExpr e = return e
5339
@@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
6349 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
6450 mkProp (name, Just e) = return (Nothing, (name, e))
6551 mkProp (name, Nothing) = do
66− arg <- Ident <$> freshName
52+ arg <- freshIdent'
6753 return (Just arg, (name, Var (Qualified Nothing arg)))
src/Language/PureScript/Sugar/Operators.hs+33−27
@@ -1,13 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Operators
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RecordWildCards #-}
5+
116-- |
127-- This module implements the desugaring pass which reapplies binary operators based
138-- on their fixity data and removes explicit parentheses.
@@ -15,13 +10,6 @@
1510-- The value parser ignores fixity data when parsing binary operator applications, so
1611-- it is necessary to reorder them here.
1712--
18−-----------------------------------------------------------------------------
19−
20−{-# LANGUAGE Rank2Types #-}
21−{-# LANGUAGE FlexibleContexts #-}
22−{-# LANGUAGE ScopedTypeVariables #-}
23−{-# LANGUAGE RecordWildCards #-}
24−
2513module Language.PureScript.Sugar.Operators (
2614 rebracket,
2715 removeSignedLiterals,
@@ -44,6 +32,8 @@ import Control.Monad.Supply.Class
4432import Data.Function (on)
4533import Data.Functor.Identity
4634import Data.List (groupBy, sortBy)
35+import Data.Maybe (mapMaybe, fromMaybe)
36+import qualified Data.Map as M
4737
4838import qualified Text.Parsec as P
4939import qualified Text.Parsec.Pos as P
@@ -57,9 +47,24 @@ import qualified Language.PureScript.Constants as C
5747rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
5848rebracket externs ms = do
5949 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
60− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
61− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
62− traverse (rebracketModule opTable) ms
50+ ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities
51+ let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities
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
6368
6469removeSignedLiterals :: Module -> Module
6570removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
@@ -82,17 +87,18 @@ removeParens =
8287 go (Parens val) = val
8388 go val = val
8489
85−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]
90+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
8691externsFixities ExternsFile{..} =
87− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)
88− | ExternsFixity assoc prec op <- efFixities
92+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
93+ | ExternsFixity assoc prec op alias <- efFixities
8994 ]
9095
91−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
96+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
9297collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
9398 where
94− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
95− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
99+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
100+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =
101+ [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]
96102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"
97103 collect _ = []
98104
@@ -172,6 +178,6 @@ desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> trav
172178 goExpr :: Expr -> m Expr
173179 goExpr (OperatorSection op (Left val)) = return $ App op val
174180 goExpr (OperatorSection op (Right val)) = do
175− arg <- Ident <$> freshName
181+ arg <- freshIdent'
176182 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
177183 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−
161{-# LANGUAGE FlexibleContexts #-}
172{-# LANGUAGE MultiParamTypeClasses #-}
183{-# LANGUAGE OverloadedStrings #-}
@@ -20,6 +5,9 @@
205{-# LANGUAGE RankNTypes #-}
216{-# LANGUAGE ScopedTypeVariables #-}
227
8+-- |
9+-- This module implements the generic deriving elaboration that takes place during desugaring.
10+--
2311module Language.PureScript.Sugar.TypeClasses.Deriving (
2412 deriveInstances
2513) where
@@ -32,7 +20,7 @@ import Data.Maybe (fromMaybe)
3220import Data.Ord (comparing)
3321
3422import Control.Monad (replicateM)
35−import Control.Monad.Supply.Class (MonadSupply, freshName)
23+import Control.Monad.Supply.Class (MonadSupply)
3624import Control.Monad.Error.Class (MonadError(..))
3725
3826import Language.PureScript.Crash
@@ -106,7 +94,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
10694
10795 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
10896 mkCtorClause (ctorName, tys) = do
109− idents <- replicateM (length tys) (fmap Ident freshName)
97+ idents <- replicateM (length tys) freshIdent'
11098 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
11199 where
112100 caseResult idents =
@@ -172,7 +160,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch
172160
173161 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
174162 mkAlternative (ctorName, tys) = do
175− idents <- replicateM (length tys) (fmap Ident freshName)
163+ idents <- replicateM (length tys) freshIdent'
176164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
177165 . Right
178166 $ 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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
161{-# LANGUAGE ScopedTypeVariables #-}
172{-# LANGUAGE FlexibleInstances #-}
183{-# LANGUAGE FlexibleContexts #-}
194
5+-- |
6+-- The top-level type checker, which checks all declarations in a module.
7+--
208module Language.PureScript.TypeChecker (
219 module T,
2210 typeCheckModule
@@ -37,6 +25,7 @@ import Data.Foldable (for_, traverse_)
3725import qualified Data.Map as M
3826
3927import Control.Monad (when, unless, void, forM, forM_)
28+import Control.Monad.Supply.Class (MonadSupply)
4029import Control.Monad.State.Class (MonadState(..), modify)
4130import Control.Monad.Error.Class (MonadError(..))
4231import Control.Monad.Writer.Class (MonadWriter(..))
@@ -191,12 +180,12 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
191180-- * Process module imports
192181--
193182typeCheckAll :: 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) =>
195184 ModuleName ->
196185 [DeclarationRef] ->
197186 [Declaration] ->
198187 m [Declaration]
199−typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds
188+typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
200189 where
201190 go :: Declaration -> m Declaration
202191 go (DataDeclaration dtype name args dctors) = do
@@ -290,13 +279,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
290279 go (PositionedDeclaration pos com d) =
291280 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
292281
293− checkOrphanFixities :: Declaration -> m ()
294− checkOrphanFixities (FixityDeclaration _ name) = do
282+ checkFixities :: Declaration -> m ()
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
295287 env <- getEnv
296288 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
297− checkOrphanFixities (PositionedDeclaration pos _ d) =
298− warnAndRethrowWithPosition pos $ checkOrphanFixities d
299− checkOrphanFixities _ = return ()
289+ checkFixities (PositionedDeclaration pos _ d) =
290+ warnAndRethrowWithPosition pos $ checkFixities d
291+ checkFixities _ = return ()
300292
301293 checkInstanceMembers :: [Declaration] -> m [Declaration]
302294 checkInstanceMembers instDecls = do
@@ -344,7 +336,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
344336-- required by exported members are also exported.
345337--
346338typeCheckModule :: 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) =>
348340 Module ->
349341 m Module
350342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
@@ -355,6 +347,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
355347 checkTypesAreExported e
356348 checkClassMembersAreExported e
357349 checkClassesAreExported e
350+ checkNonAliasesAreExported e
358351 return $ Module ss coms mn decls' (Just exps)
359352 where
360353
@@ -429,3 +422,17 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
429422 extractMemberName (TypeDeclaration memberName _) = memberName
430423 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
431424 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
5757 , checkNextKind :: Int -- ^ The next kind unification variable
5858 , checkNextSkolem :: Int -- ^ The next skolem variable
5959 , checkNextSkolemScope :: Int -- ^ The next skolem scope constant
60− , checkNextDictName :: Int -- ^ The next type class dictionary name
6160 , checkCurrentModule :: Maybe ModuleName -- ^ The current module
6261 , checkSubstitution :: Substitution -- ^ The current substitution
6362 }
6463
6564-- | Create an empty @CheckState@
6665emptyCheckState :: 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
6867
6968-- | Unification variables
7069type Unknown = Int
@@ -202,13 +201,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()
202201guardWith _ True = return ()
203202guardWith e False = throwError e
204203
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−
212204-- | Run a computation in the substitution monad, generating a return value and the final substitution.
213205liftUnify ::
214206 (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−
161{-# LANGUAGE FlexibleContexts #-}
172{-# LANGUAGE ScopedTypeVariables #-}
183{-# LANGUAGE MultiParamTypeClasses #-}
194{-# LANGUAGE OverloadedStrings #-}
205
6+-- |
7+-- This module implements the type checker
8+--
219module Language.PureScript.TypeChecker.Types (
2210 typesOf
2311) where
@@ -48,6 +36,7 @@ import qualified Data.Map as M
4836
4937import Control.Monad
5038import Control.Monad.State.Class (MonadState(..), gets)
39+import Control.Monad.Supply.Class (MonadSupply)
5140import Control.Monad.Error.Class (MonadError(..))
5241import Control.Monad.Writer.Class (MonadWriter(..))
5342
@@ -72,7 +61,7 @@ import Language.PureScript.Types
7261-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
7362-- type class dictionaries and type annotations.
7463typesOf ::
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) =>
7665 ModuleName ->
7766 [(Ident, Expr)] ->
7867 m [(Ident, (Expr, Type))]
@@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do
129118 return (untyped, typed, dict, untypedDict)
130119
131120checkTypedBindingGroupElement ::
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) =>
133122 ModuleName ->
134123 (Ident, (Expr, Type, Bool)) ->
135124 TypeData ->
@@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
148137 return (ident, (val'', ty''))
149138
150139typeForBindingGroupElement ::
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) =>
152141 Bool ->
153142 (Ident, Expr) ->
154143 TypeData ->
@@ -218,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
218207
219208-- | Infer a type for a value, rethrowing any error to provide a more useful error message
220209infer ::
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) =>
222211 Expr ->
223212 m Expr
224213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
225214
226215-- | Infer a type for a value
227216infer' ::
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) =>
229218 Expr ->
230219 m Expr
231220infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
@@ -312,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
312301infer' _ = internalError "Invalid argument to infer"
313302
314303inferLetBinding ::
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) =>
316305 [Declaration] ->
317306 [Declaration] ->
318307 Expr ->
@@ -423,7 +412,7 @@ binderRequiresMonotype _ = True
423412
424413-- | Instantiate polytypes only when necessitated by a binder.
425414instantiateForBinders ::
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) =>
427416 [Expr] ->
428417 [CaseAlternative] ->
429418 m ([Expr], [Type])
@@ -440,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
440429-- Check the types of the return values in a set of binders in a case statement
441430--
442431checkBinders ::
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) =>
444433 [Type] ->
445434 Type ->
446435 [CaseAlternative] ->
@@ -470,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
470459-- Check the type of a value, rethrowing errors to provide a better error message
471460--
472461check ::
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) =>
474463 Expr ->
475464 Type ->
476465 m Expr
@@ -480,7 +469,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
480469-- Check the type of a value
481470--
482471check' :: 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) =>
484473 Expr ->
485474 Type ->
486475 m Expr
@@ -495,9 +484,8 @@ check' val (ForAll ident ty _) = do
495484 val' <- check skVal sk
496485 return $ TypedValue True val' (ForAll ident ty (Just scope))
497486check' val t@(ConstrainedType constraints ty) = do
498− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
499− n <- freshDictionaryName
500− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
487+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->
488+ freshIdent ("dict" ++ className)
501489 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
502490 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
503491 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
@@ -639,7 +627,7 @@ check' val ty = do
639627-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
640628--
641629checkProperties ::
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) =>
643631 Expr ->
644632 [(String, Expr)] ->
645633 Type ->
@@ -671,7 +659,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
671659
672660-- | Check the type of a function application, rethrowing errors to provide a better error message
673661checkFunctionApplication ::
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) =>
675663 Expr ->
676664 Type ->
677665 Expr ->
@@ -683,7 +671,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication
683671
684672-- | Check the type of a function application
685673checkFunctionApplication' ::
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) =>
687675 Expr ->
688676 Type ->
689677 Expr ->
tests/Main.hs+10
@@ -68,6 +68,7 @@ import qualified System.FilePath.Glob as Glob
6868import Text.Parsec (ParseError)
6969
7070import TestsSetup
71+import TestPscPublish
7172
7273modulesDir :: FilePath
7374modulesDir = ".test_modules" </> "node_modules"
@@ -171,6 +172,11 @@ assertDoesNotCompile inputFiles foreigns = do
171172
172173main :: IO ()
173174main = do
175+ testCompiler
176+ testPscPublish
177+
178+testCompiler :: IO ()
179+testCompiler = do
174180 fetchSupportCode
175181 cwd <- getCurrentDirectory
176182
@@ -203,6 +209,10 @@ main = do
203209 in putStrLn $ fp' ++ ": " ++ err
204210 exitFailure
205211
212+testPscPublish :: IO ()
213+testPscPublish = do
214+ testPackage "tests/support/prelude"
215+
206216supportModules :: [String]
207217supportModules =
208218 [ "Control.Monad.Eff.Class"
psc-publish/tests/Test.hs → tests/TestPscPublish.hsrenamed+24−38
@@ -2,30 +2,23 @@
22{-# OPTIONS_GHC -fno-warn-unused-imports #-}
33{-# LANGUAGE ScopedTypeVariables #-}
44
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
126
137import Control.Monad
148import Control.Applicative
159import Control.Exception
1610import System.Process
1711import System.Directory
12+import System.IO
13+import System.Exit
1814import qualified Data.ByteString.Lazy as BL
1915import Data.ByteString.Lazy (ByteString)
2016import qualified Data.Aeson as A
2117import Data.Aeson.BetterErrors
18+import Data.Version
2219
23−import Main
2420import Language.PureScript.Docs
25−
26−pkgName = "purescript-prelude"
27−packageUrl = "https://github.com/purescript/" ++ pkgName
28−packageDir = "tmp/" ++ pkgName
21+import Language.PureScript.Publish
2922
3023pushd :: forall a. FilePath -> IO a -> IO a
3124pushd dir act = do
@@ -35,38 +28,12 @@ pushd dir act = do
3528 setCurrentDirectory original
3629 either throwIO return result
3730
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−
5931data TestResult
6032 = ParseFailed String
6133 | Mismatch ByteString ByteString -- ^ encoding before, encoding after
6234 | Pass ByteString
6335 deriving (Show, Read)
6436
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−
7037roundTrip :: UploadedPackage -> TestResult
7138roundTrip pkg =
7239 let before = A.encode pkg
@@ -77,3 +44,22 @@ roundTrip pkg =
7744 if before == after
7845 then Pass before
7946 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.