git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge remote-tracking branch 'pure11/pure11' into native
e8f63d2Andy Arvanitis
CONTRIBUTORS.md+1
@@ -90,6 +90,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
90- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
90- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
91- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
91- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
92- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
92- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
93+- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
93
94
94### Companies
95### Companies
95
96
examples/docs/src/ExplicitTypeSignatures.purs−2
@@ -14,5 +14,3 @@ anInt = 0
14
14
15-- This should infer a type.
15-- This should infer a type.
16aNumber = 1.0
16aNumber = 1.0
17−
18−foreign import nestedForAll :: forall c. (forall a b. c)
examples/failing/2445.pursnew file+6
@@ -0,0 +1,6 @@
1+-- @shouldFailWith ErrorParsingModule
2+module Main where
3+
4+data X a = X
5+
6+eg = \(X :: (forall a. X a)) -> X
psc-publish/Main.hs+3
@@ -2,10 +2,12 @@
2
2
3module Main where
3module Main where
4
4
5+import Control.Monad.IO.Class (liftIO)
5import Data.Version (Version(..), showVersion)
6import Data.Version (Version(..), showVersion)
6import qualified Data.Aeson as A
7import qualified Data.Aeson as A
7import qualified Data.ByteString.Lazy.Char8 as BL
8import qualified Data.ByteString.Lazy.Char8 as BL
8import Data.Monoid ((<>))
9import Data.Monoid ((<>))
10+import Data.Time.Clock (getCurrentTime)
9
11
10import Options.Applicative (Parser, ParseError (..))
12import Options.Applicative (Parser, ParseError (..))
11import qualified Options.Applicative as Opts
13import qualified Options.Applicative as Opts
@@ -25,6 +27,7 @@ dryRunOptions :: PublishOptions
25dryRunOptions = defaultPublishOptions
27dryRunOptions = defaultPublishOptions
26 { publishGetVersion = return dummyVersion
28 { publishGetVersion = return dummyVersion
27 , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
29 , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
30+ , publishGetTagTime = const (liftIO getCurrentTime)
28 }
31 }
29 where dummyVersion = ("0.0.0", Version [0,0,0] [])
32 where dummyVersion = ("0.0.0", Version [0,0,0] [])
30
33
purescript.cabal+4−2
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.10.5
2+version: 0.10.6
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Simple
4build-type: Simple
5license: BSD3
5license: BSD3
@@ -447,7 +447,9 @@ executable psc-publish
447 purescript -any,
447 purescript -any,
448 aeson >= 0.8 && < 1.0,
448 aeson >= 0.8 && < 1.0,
449 bytestring -any,
449 bytestring -any,
450− optparse-applicative -any
450+ optparse-applicative -any,
451+ time -any,
452+ transformers -any
451 main-is: Main.hs
453 main-is: Main.hs
452 other-modules: Paths_purescript
454 other-modules: Paths_purescript
453 buildable: True
455 buildable: True
src/Language/PureScript/CodeGen/JS.hs+44−23
@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
139 --
139 --
140 bindToJs :: Bind Ann -> m [JS]
140 bindToJs :: Bind Ann -> m [JS]
141− bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
141+ bindToJs (NonRec ann ident val) = nonRecToJS ann ident val
142− bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
142+ bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
143
143
144 -- |
144 -- |
145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -147,15 +147,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
147 --
147 --
148 -- The main purpose of this function is to handle code generation for comments.
148 -- The main purpose of this function is to handle code generation for comments.
149 --
149 --
150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
152 withoutComment <- asks optionsNoComments
152 withoutComment <- asks optionsNoComments
153 if withoutComment
153 if withoutComment
154 then nonRecToJS a i (modifyAnn removeComments e)
154 then nonRecToJS a i (modifyAnn removeComments e)
155− else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
155+ else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
156+ where
157+ withHead _ [] = []
158+ withHead f (x:xs) = f x : xs
156 nonRecToJS (ss, _, _, _) ident val = do
159 nonRecToJS (ss, _, _, _) ident val = do
160+ case constructorToJs ident val of
161+ Just jss ->
162+ traverse (withPos ss) jss
163+ Nothing -> do
157− js <- valueToJs val
164+ js <- valueToJs val
158− withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
165+ return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))
159
166
160 withPos :: Maybe SourceSpan -> JS -> m JS
167 withPos :: Maybe SourceSpan -> JS -> m JS
161 withPos (Just ss) js = do
168 withPos (Just ss) js = do
@@ -251,23 +258,37 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
251 JSObjectLiteral Nothing [("create",
258 JSObjectLiteral Nothing [("create",
252 JSFunction Nothing Nothing ["value"]
259 JSFunction Nothing Nothing ["value"]
253 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
260 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
254− valueToJs' (Constructor _ _ (ProperName ctor) []) =
261+ valueToJs' (Constructor _ _ (ProperName ctor) _) =
262+ internalError $ "Unexpected constructor definition: " ++ T.unpack ctor
263+
264+ -- |
265+ -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition.
266+ -- If the argument is not a constructor, this returns Nothing.
267+ --
268+ constructorToJs :: Ident -> Expr Ann -> Maybe [JS]
269+ constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =
270+ Just jss
271+ where
272+ mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))
273+ jss = case fs of
274+ [] ->
275+ [ JSVariableIntroduction Nothing (identToJs ident) (Just $
255− return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
276+ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))
256− , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))
277+ , mkAccessor "value" $
257− (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
278+ JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []
258− valueToJs' (Constructor _ _ (ProperName ctor) fields) =
279+ ]
280+ fields ->
259− let constructor =
281+ let constructor =
260− let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
282+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
261− in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
283+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
262− createFn =
284+ createFn =
263− let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
285+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
264− in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
286+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
265− in return $ iife (properToJs ctor) [ constructor
287+ in [ constructor
266− , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn
288+ , mkAccessor "create" createFn
267− ]
289+ ]
268−
290+ constructorToJs _ _ =
269− iife :: Text -> [JS] -> JS
291+ Nothing
270− iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
271
292
272 literalToValueJS :: Literal (Expr Ann) -> m JS
293 literalToValueJS :: Literal (Expr Ann) -> m JS
273 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
294 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+9−17
@@ -110,7 +110,7 @@ inlineCommonValues = everywhereOnJS convert
110 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
110 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
111
111
112inlineCommonOperators :: JS -> JS
112inlineCommonOperators :: JS -> JS
113−inlineCommonOperators = applyAll $
113+inlineCommonOperators = everywhereOnJSTopDown $ applyAll $
114 [ binary semiringNumber opAdd Add
114 [ binary semiringNumber opAdd Add
115 , binary semiringNumber opMul Multiply
115 , binary semiringNumber opMul Multiply
116
116
@@ -173,38 +173,32 @@ inlineCommonOperators = applyAll $
173 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
173 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
174 where
174 where
175 binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS
175 binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS
176− binary dict fns op = everywhereOnJS convert
176+ binary dict fns op = convert where
177− where
178 convert :: JS -> JS
177 convert :: JS -> JS
179 convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y
178 convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y
180 convert other = other
179 convert other = other
181 binary' :: Text -> PSString -> BinaryOperator -> JS -> JS
180 binary' :: Text -> PSString -> BinaryOperator -> JS -> JS
182− binary' moduleName opString op = everywhereOnJS convert
181+ binary' moduleName opString op = convert where
183− where
184 convert :: JS -> JS
182 convert :: JS -> JS
185 convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y
183 convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y
186 convert other = other
184 convert other = other
187 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS
185 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS
188− unary dicts fns op = everywhereOnJS convert
186+ unary dicts fns op = convert where
189− where
190 convert :: JS -> JS
187 convert :: JS -> JS
191 convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x
188 convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x
192 convert other = other
189 convert other = other
193 unary' :: Text -> PSString -> UnaryOperator -> JS -> JS
190 unary' :: Text -> PSString -> UnaryOperator -> JS -> JS
194− unary' moduleName fnName op = everywhereOnJS convert
191+ unary' moduleName fnName op = convert where
195− where
196 convert :: JS -> JS
192 convert :: JS -> JS
197 convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x
193 convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x
198 convert other = other
194 convert other = other
199 mkFn :: Int -> JS -> JS
195 mkFn :: Int -> JS -> JS
200− mkFn 0 = everywhereOnJS convert
196+ mkFn 0 = convert where
201− where
202 convert :: JS -> JS
197 convert :: JS -> JS
203 convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =
198 convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =
204 JSFunction s1 Nothing [] (JSBlock s2 js)
199 JSFunction s1 Nothing [] (JSBlock s2 js)
205 convert other = other
200 convert other = other
206− mkFn n = everywhereOnJS convert
201+ mkFn n = convert where
207− where
208 convert :: JS -> JS
202 convert :: JS -> JS
209 convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
203 convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
210 case collectArgs n [] fn of
204 case collectArgs n [] fn of
@@ -223,8 +217,7 @@ inlineCommonOperators = applyAll $
223 isNFn _ _ _ = False
217 isNFn _ _ _ = False
224
218
225 runFn :: Int -> JS -> JS
219 runFn :: Int -> JS -> JS
226− runFn n = everywhereOnJS convert
220+ runFn n = convert where
227− where
228 convert :: JS -> JS
221 convert :: JS -> JS
229 convert js = fromMaybe js $ go n [] js
222 convert js = fromMaybe js $ go n [] js
230
223
@@ -234,8 +227,7 @@ inlineCommonOperators = applyAll $
234 go _ _ _ = Nothing
227 go _ _ _ = Nothing
235
228
236 inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS
229 inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS
237− inlineNonClassFunction p f = everywhereOnJS convert
230+ inlineNonClassFunction p f = convert where
238− where
239 convert :: JS -> JS
231 convert :: JS -> JS
240 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y
232 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y
241 convert other = other
233 convert other = other
src/Language/PureScript/Docs/RenderedCode/Types.hs+1−1
@@ -50,7 +50,7 @@ import Control.DeepSeq (NFData)
50import Control.Monad.Error.Class (MonadError(..))
50import Control.Monad.Error.Class (MonadError(..))
51
51
52import Data.Monoid ((<>))
52import Data.Monoid ((<>))
53−import Data.Aeson.BetterErrors
53+import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray)
54import qualified Data.Aeson as A
54import qualified Data.Aeson as A
55import Data.Text (Text)
55import Data.Text (Text)
56import qualified Data.Text as T
56import qualified Data.Text as T
src/Language/PureScript/Docs/Types.hs+4
@@ -11,6 +11,10 @@ import Control.Arrow ((***))
11
11
12import Data.Aeson ((.=))
12import Data.Aeson ((.=))
13import Data.Aeson.BetterErrors
13import Data.Aeson.BetterErrors
14+ (Parse, ParseError, parse, keyOrDefault, throwCustomError, key, asText,
15+ keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser',
16+ fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey,
17+ asString)
14import qualified Data.Map as Map
18import qualified Data.Map as Map
15import Data.Time.Clock (UTCTime)
19import Data.Time.Clock (UTCTime)
16import qualified Data.Time.Format as TimeFormat
20import qualified Data.Time.Format as TimeFormat
src/Language/PureScript/Ide/Types.hs+2
@@ -229,6 +229,8 @@ identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name
229identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident
229identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident
230identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name
230identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name
231identifierFromDeclarationRef (P.KindRef name) = P.runProperName name
231identifierFromDeclarationRef (P.KindRef name) = P.runProperName name
232+identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op
233+identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op
232identifierFromDeclarationRef _ = ""
234identifierFromDeclarationRef _ = ""
233
235
234data Success =
236data Success =
src/Language/PureScript/Make.hs+6−1
@@ -326,10 +326,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
326
326
327 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
327 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
328 getOutputTimestamp mn = do
328 getOutputTimestamp mn = do
329+ dumpCoreFn <- asks optionsDumpCoreFn
329 let filePath = T.unpack (runModuleName mn)
330 let filePath = T.unpack (runModuleName mn)
330 jsFile = outputDir </> filePath </> "index.js"
331 jsFile = outputDir </> filePath </> "index.js"
331 externsFile = outputDir </> filePath </> "externs.json"
332 externsFile = outputDir </> filePath </> "externs.json"
333+ coreFnFile = outputDir </> filePath </> "corefn.json"
334+ min3 js exts coreFn
335+ | dumpCoreFn = min (min js exts) coreFn
336+ | otherwise = min js exts
332− min <$> getTimestamp jsFile <*> getTimestamp externsFile
337+ min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile
333
338
334 readExterns :: ModuleName -> Make (FilePath, Externs)
339 readExterns :: ModuleName -> Make (FilePath, Externs)
335 readExterns mn = do
340 readExterns mn = do
src/Language/PureScript/Publish.hs+4−3
@@ -27,7 +27,7 @@ import Control.Category ((>>>))
27import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
27import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
28import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
28import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
29
29
30−import Data.Aeson.BetterErrors
30+import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText)
31import Data.Char (isSpace)
31import Data.Char (isSpace)
32import Data.String (String, lines)
32import Data.String (String, lines)
33import Data.List (stripPrefix, (\\), nubBy)
33import Data.List (stripPrefix, (\\), nubBy)
@@ -195,8 +195,9 @@ getVersionFromGitTag = do
195getTagTime :: Text -> PrepareM UTCTime
195getTagTime :: Text -> PrepareM UTCTime
196getTagTime tag = do
196getTagTime tag = do
197 out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
197 out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
198− let time = headMay (lines out) >>= D.parseTime
198+ case mapMaybe D.parseTime (lines out) of
199+ [t] -> pure t
199− maybe (internalError (CouldntParseGitTagDate tag)) pure time
200+ _ -> internalError (CouldntParseGitTagDate tag)
200
201
201getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
202getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
202getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
203getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
src/Language/PureScript/Publish/ErrorsWarnings.hs+1−1
@@ -17,7 +17,7 @@ import Prelude.Compat
17
17
18import Control.Exception (IOException)
18import Control.Exception (IOException)
19
19
20−import Data.Aeson.BetterErrors
20+import Data.Aeson.BetterErrors (ParseError, displayError)
21import Data.List (intersperse, intercalate)
21import Data.List (intersperse, intercalate)
22import Data.List.NonEmpty (NonEmpty(..))
22import Data.List.NonEmpty (NonEmpty(..))
23import Data.Maybe
23import Data.Maybe
src/Language/PureScript/TypeChecker/Types.hs+3−5
@@ -487,15 +487,12 @@ inferBinder val (NamedBinder name binder) = do
487 return $ M.insert name val m
487 return $ M.insert name val m
488inferBinder val (PositionedBinder pos _ binder) =
488inferBinder val (PositionedBinder pos _ binder) =
489 warnAndRethrowWithPositionTC pos $ inferBinder val binder
489 warnAndRethrowWithPositionTC pos $ inferBinder val binder
490−-- TODO: When adding support for polymorphic types, check subsumption here,
491−-- change the definition of `binderRequiresMonotype`,
492−-- and use `kindOfWithScopedVars`.
493inferBinder val (TypedBinder ty binder) = do
490inferBinder val (TypedBinder ty binder) = do
494 kind <- kindOf ty
491 kind <- kindOf ty
495 checkTypeKind ty kind
492 checkTypeKind ty kind
496− ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
493+ ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
497 unifyTypes val ty1
494 unifyTypes val ty1
498− inferBinder val binder
495+ inferBinder ty1 binder
499inferBinder _ OpBinder{} =
496inferBinder _ OpBinder{} =
500 internalError "OpBinder should have been desugared before inferBinder"
497 internalError "OpBinder should have been desugared before inferBinder"
501inferBinder _ BinaryNoParensBinder{} =
498inferBinder _ BinaryNoParensBinder{} =
@@ -510,6 +507,7 @@ binderRequiresMonotype NullBinder = False
510binderRequiresMonotype (VarBinder _) = False
507binderRequiresMonotype (VarBinder _) = False
511binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b
508binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b
512binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
509binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
510+binderRequiresMonotype (TypedBinder ty b) = isMonoType ty || binderRequiresMonotype b
513binderRequiresMonotype _ = True
511binderRequiresMonotype _ = True
514
512
515-- | Instantiate polytypes only when necessitated by a binder.
513-- | Instantiate polytypes only when necessitated by a binder.
src/Language/PureScript/Types.hs+2
@@ -127,6 +127,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
127--
127--
128isMonoType :: Type -> Bool
128isMonoType :: Type -> Bool
129isMonoType ForAll{} = False
129isMonoType ForAll{} = False
130+isMonoType (ParensInType t) = isMonoType t
131+isMonoType (KindedType t _) = isMonoType t
130isMonoType _ = True
132isMonoType _ = True
131
133
132-- |
134-- |
stack-ghc-8.0.yaml+8−4
@@ -1,10 +1,14 @@
1−resolver: lts-7.9
1+resolver: nightly-2017-01-31
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5+- aeson-0.11.3.0
6+- bower-json-1.0.0.1
7+- http-client-0.4.31.2
8+- http-client-tls-0.2.4.1
9+- optparse-applicative-0.13.0.0
10+- pipes-4.1.9
5- pipes-http-1.0.2
11- pipes-http-1.0.2
12+- turtle-1.3.1
6- wai-websockets-3.0.0.9
13- wai-websockets-3.0.0.9
7- websockets-0.9.6.2
14- websockets-0.9.6.2
8−- bower-json-1.0.0.1
9−- turtle-1.3.1
10−- optparse-applicative-0.13.0.0
stack.yaml+2−1
@@ -2,6 +2,7 @@ resolver: lts-6.25
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5+- aeson-better-errors-0.9.1.0
5- bower-json-1.0.0.1
6- bower-json-1.0.0.1
7+- optparse-applicative-0.13.0.0
6- turtle-1.3.1
8- turtle-1.3.1
7−- optparse-applicative-0.13.0.0
tests/TestDocs.hs−1
@@ -336,7 +336,6 @@ testCases =
336 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
336 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
337 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
337 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
338 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
338 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
339− , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
340 ])
339 ])
341
340
342 , ("ConstrainedArgument",
341 , ("ConstrainedArgument",
tests/TestPscPublish.hs−9
@@ -61,13 +61,4 @@ testPackage dir = pushd dir $ do
61 print other
61 print other
62 exitFailure
62 exitFailure
63 where
63 where
64− preparePackageError e@(UserError BowerJSONNotFound) = do
65− Publish.printErrorToStdout e
66− putStrLn ""
67− putStrLn "=========================================="
68− putStrLn "Did you forget to update the submodules?"
69− putStrLn "$ git submodule sync; git submodule update"
70− putStrLn "=========================================="
71− putStrLn ""
72− exitFailure
73 preparePackageError e = Publish.printErrorToStdout e >> exitFailure
64 preparePackageError e = Publish.printErrorToStdout e >> exitFailure