0496d3c · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

commit0496d3c3888862b4267dc5be06282e57ed070e6c authorAndy Arvanitis <andyarvanitis@gmail.com> dateMon 6 Feb 2017, 19:31 (10 years ago) parent838dc61 4599160

19 files changed+100−70

compare with golang

unifiedsplit

CONTRIBUTORS.md+1

@@ -90,6 +90,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

9090- [@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).

9191- [@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).

9292- [@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).

9394

9495### Companies

9596

examples/docs/src/ExplicitTypeSignatures.purs−2

@@ -14,5 +14,3 @@ anInt = 0

1414

1515-- This should infer a type.

1616aNumber = 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

4+data X a = X

6+eg = \(X :: (forall a. X a)) -> X

psc-publish/Main.hs+3

@@ -2,10 +2,12 @@

33module Main where

5+import Control.Monad.IO.Class (liftIO)

56import Data.Version (Version(..), showVersion)

67import qualified Data.Aeson as A

78import qualified Data.ByteString.Lazy.Char8 as BL

89import Data.Monoid ((<>))

10+import Data.Time.Clock (getCurrentTime)

911

1012import Options.Applicative (Parser, ParseError (..))

1113import qualified Options.Applicative as Opts

@@ -25,6 +27,7 @@ dryRunOptions :: PublishOptions

2527dryRunOptions = defaultPublishOptions

2628 { publishGetVersion = return dummyVersion

2729 , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn

30+ , publishGetTagTime = const (liftIO getCurrentTime)

2831 }

2932 where dummyVersion = ("0.0.0", Version [0,0,0] [])

3033

purescript.cabal+4−2

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

11name: purescript

2−version: 0.10.5

2+version: 0.10.6

33cabal-version: >=1.8

44build-type: Simple

55license: BSD3

@@ -447,7 +447,9 @@ executable psc-publish

447447 purescript -any,

448448 aeson >= 0.8 && < 1.0,

449449 bytestring -any,

450− optparse-applicative -any

450+ optparse-applicative -any,

451+ time -any,

452+ transformers -any

451453 main-is: Main.hs

452454 other-modules: Paths_purescript

453455 buildable: True

src/Language/PureScript/CodeGen/JS.hs+44−23

@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

138138 -- Generate code in the simplified Javascript intermediate representation for a declaration

139139 --

140140 bindToJs :: Bind Ann -> m [JS]

141− bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val

142− bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)

141+ bindToJs (NonRec ann ident val) = nonRecToJS ann ident val

142+ bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)

143143

144144 -- |

145145 -- 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_ =

147147 --

148148 -- The main purpose of this function is to handle code generation for comments.

149149 --

150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS

150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]

151151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

152152 withoutComment <- asks optionsNoComments

153153 if withoutComment

154154 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

156159 nonRecToJS (ss, _, _, _) ident val = do

157− js <- valueToJs val

158− withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)

160+ case constructorToJs ident val of

161+ Just jss ->

162+ traverse (withPos ss) jss

163+ Nothing -> do

164+ js <- valueToJs val

165+ return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))

159166

160167 withPos :: Maybe SourceSpan -> JS -> m JS

161168 withPos (Just ss) js = do

@@ -251,23 +258,37 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

251258 JSObjectLiteral Nothing [("create",

252259 JSFunction Nothing Nothing ["value"]

253260 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

254− valueToJs' (Constructor _ _ (ProperName ctor) []) =

255− return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])

256− , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))

257− (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

258− valueToJs' (Constructor _ _ (ProperName ctor) fields) =

259− let constructor =

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

262− createFn =

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

265− in return $ iife (properToJs ctor) [ constructor

266− , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn

267− ]

268−

269− iife :: Text -> [JS] -> JS

270− iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []

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 $

276+ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))

277+ , mkAccessor "value" $

278+ JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []

279+ ]

280+ fields ->

281+ let constructor =

282+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

283+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

284+ createFn =

285+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

286+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

287+ in [ constructor

288+ , mkAccessor "create" createFn

289+ ]

290+ constructorToJs _ _ =

291+ Nothing

271292

272293 literalToValueJS :: Literal (Expr Ann) -> m JS

273294 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

110110 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))

111111

112112inlineCommonOperators :: JS -> JS

113−inlineCommonOperators = applyAll $

113+inlineCommonOperators = everywhereOnJSTopDown $ applyAll $

114114 [ binary semiringNumber opAdd Add

115115 , binary semiringNumber opMul Multiply

116116

@@ -173,38 +173,32 @@ inlineCommonOperators = applyAll $

173173 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

174174 where

175175 binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS

176− binary dict fns op = everywhereOnJS convert

177− where

176+ binary dict fns op = convert where

178177 convert :: JS -> JS

179178 convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y

180179 convert other = other

181180 binary' :: Text -> PSString -> BinaryOperator -> JS -> JS

182− binary' moduleName opString op = everywhereOnJS convert

183− where

181+ binary' moduleName opString op = convert where

184182 convert :: JS -> JS

185183 convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y

186184 convert other = other

187185 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS

188− unary dicts fns op = everywhereOnJS convert

189− where

186+ unary dicts fns op = convert where

190187 convert :: JS -> JS

191188 convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x

192189 convert other = other

193190 unary' :: Text -> PSString -> UnaryOperator -> JS -> JS

194− unary' moduleName fnName op = everywhereOnJS convert

195− where

191+ unary' moduleName fnName op = convert where

196192 convert :: JS -> JS

197193 convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x

198194 convert other = other

199195 mkFn :: Int -> JS -> JS

200− mkFn 0 = everywhereOnJS convert

201− where

196+ mkFn 0 = convert where

202197 convert :: JS -> JS

203198 convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =

204199 JSFunction s1 Nothing [] (JSBlock s2 js)

205200 convert other = other

206− mkFn n = everywhereOnJS convert

207− where

201+ mkFn n = convert where

208202 convert :: JS -> JS

209203 convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =

210204 case collectArgs n [] fn of

@@ -223,8 +217,7 @@ inlineCommonOperators = applyAll $

223217 isNFn _ _ _ = False

224218

225219 runFn :: Int -> JS -> JS

226− runFn n = everywhereOnJS convert

227− where

220+ runFn n = convert where

228221 convert :: JS -> JS

229222 convert js = fromMaybe js $ go n [] js

230223

@@ -234,8 +227,7 @@ inlineCommonOperators = applyAll $

234227 go _ _ _ = Nothing

235228

236229 inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS

237− inlineNonClassFunction p f = everywhereOnJS convert

238− where

230+ inlineNonClassFunction p f = convert where

239231 convert :: JS -> JS

240232 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

241233 convert other = other

src/Language/PureScript/Docs/RenderedCode/Types.hs+1−1

@@ -50,7 +50,7 @@ import Control.DeepSeq (NFData)

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

5151

5252import Data.Monoid ((<>))

53−import Data.Aeson.BetterErrors

53+import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray)

5454import qualified Data.Aeson as A

5555import Data.Text (Text)

5656import qualified Data.Text as T

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

@@ -11,6 +11,10 @@ import Control.Arrow ((***))

1111

1212import Data.Aeson ((.=))

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

1418import qualified Data.Map as Map

1519import Data.Time.Clock (UTCTime)

1620import qualified Data.Time.Format as TimeFormat

src/Language/PureScript/Ide/Types.hs+2

@@ -229,6 +229,8 @@ identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name

229229identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident

230230identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name

231231identifierFromDeclarationRef (P.KindRef name) = P.runProperName name

232+identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op

233+identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op

232234identifierFromDeclarationRef _ = ""

233235

234236data Success =

src/Language/PureScript/Make.hs+6−1

@@ -326,10 +326,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

326326

327327 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)

328328 getOutputTimestamp mn = do

329+ dumpCoreFn <- asks optionsDumpCoreFn

329330 let filePath = T.unpack (runModuleName mn)

330331 jsFile = outputDir </> filePath </> "index.js"

331332 externsFile = outputDir </> filePath </> "externs.json"

332− min <$> getTimestamp jsFile <*> getTimestamp externsFile

333+ coreFnFile = outputDir </> filePath </> "corefn.json"

334+ min3 js exts coreFn

335+ | dumpCoreFn = min (min js exts) coreFn

336+ | otherwise = min js exts

337+ min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile

333338

334339 readExterns :: ModuleName -> Make (FilePath, Externs)

335340 readExterns mn = do

src/Language/PureScript/Publish.hs+4−3

@@ -27,7 +27,7 @@ import Control.Category ((>>>))

2727import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

2828import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)

2929

30−import Data.Aeson.BetterErrors

30+import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText)

3131import Data.Char (isSpace)

3232import Data.String (String, lines)

3333import Data.List (stripPrefix, (\\), nubBy)

@@ -195,8 +195,9 @@ getVersionFromGitTag = do

195195getTagTime :: Text -> PrepareM UTCTime

196196getTagTime tag = do

197197 out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""

198− let time = headMay (lines out) >>= D.parseTime

199− maybe (internalError (CouldntParseGitTagDate tag)) pure time

198+ case mapMaybe D.parseTime (lines out) of

199+ [t] -> pure t

200+ _ -> internalError (CouldntParseGitTagDate tag)

200201

201202getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)

202203getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract

src/Language/PureScript/Publish/ErrorsWarnings.hs+1−1

@@ -17,7 +17,7 @@ import Prelude.Compat

1717

1818import Control.Exception (IOException)

1919

20−import Data.Aeson.BetterErrors

20+import Data.Aeson.BetterErrors (ParseError, displayError)

2121import Data.List (intersperse, intercalate)

2222import Data.List.NonEmpty (NonEmpty(..))

2323import Data.Maybe

src/Language/PureScript/TypeChecker/Types.hs+3−5

@@ -487,15 +487,12 @@ inferBinder val (NamedBinder name binder) = do

487487 return $ M.insert name val m

488488inferBinder val (PositionedBinder pos _ binder) =

489489 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`.

493490inferBinder val (TypedBinder ty binder) = do

494491 kind <- kindOf ty

495492 checkTypeKind ty kind

496− ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

493+ ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

497494 unifyTypes val ty1

498− inferBinder val binder

495+ inferBinder ty1 binder

499496inferBinder _ OpBinder{} =

500497 internalError "OpBinder should have been desugared before inferBinder"

501498inferBinder _ BinaryNoParensBinder{} =

@@ -510,6 +507,7 @@ binderRequiresMonotype NullBinder = False

510507binderRequiresMonotype (VarBinder _) = False

511508binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b

512509binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b

510+binderRequiresMonotype (TypedBinder ty b) = isMonoType ty || binderRequiresMonotype b

513511binderRequiresMonotype _ = True

514512

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

127127--

128128isMonoType :: Type -> Bool

129129isMonoType ForAll{} = False

130+isMonoType (ParensInType t) = isMonoType t

131+isMonoType (KindedType t _) = isMonoType t

130132isMonoType _ = True

131133

132134-- |

stack-ghc-8.0.yaml+8−4

@@ -1,10 +1,14 @@

1−resolver: lts-7.9

1+resolver: nightly-2017-01-31

22packages:

33- '.'

44extra-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

511- pipes-http-1.0.2

12+- turtle-1.3.1

613- wai-websockets-3.0.0.9

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

22packages:

33- '.'

44extra-deps:

5+- aeson-better-errors-0.9.1.0

56- bower-json-1.0.0.1

7+- optparse-applicative-0.13.0.0

68- turtle-1.3.1

7−- optparse-applicative-0.13.0.0

tests/TestDocs.hs−1

@@ -336,7 +336,6 @@ testCases =

336336 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))

337337 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))

338338 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))

339− , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")

340339 ])

341340

342341 , ("ConstrainedArgument",

tests/TestPscPublish.hs−9

@@ -61,13 +61,4 @@ testPackage dir = pushd dir $ do

6161 print other

6262 exitFailure

6363 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

7364 preparePackageError e = Publish.printErrorToStdout e >> exitFailure