fc062f2 · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'upstream/master' into pure11-0.8

fc062f2Andy Arvanitis11 years ago

CONTRIBUTORS.md+1

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

64- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, 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).

65- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, 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).

66- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, 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).

67+- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, 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).

68### Companies

69### Companies

examples/passing/TCO.pursnew file+20

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

1+module Main where

3+import Prelude

4+import Control.Monad.Eff.Console (print)

6+main = do

7+ let f x = x + 1

8+ let v = 0

9+ print (applyN 0 f v)

10+ print (applyN 1 f v)

11+ print (applyN 2 f v)

12+ print (applyN 3 f v)

13+ print (applyN 4 f v)

14+

15+applyN :: forall a. Int -> (a -> a) -> a -> a

16+applyN = go id

17+ where

18+ go f n _ | n <= 0 = f

19+ go f n g = go (f >>> g) (n - 1) g

20+

examples/passing/UnicodeType.pursnew file+23

@@ -0,0 +1,23 @@

1+module Main where

3+import Prelude

5+class (Monad m) ⇐ Monad1 m where

6+ f1 :: Int

8+class (Monad m) <= Monad2 m where

9+ f2 :: Int

10+

11+f ∷ ∀ m. Monad m ⇒ Int → m Int

12+f n = do

13+ n' ← return n

14+ return n'

15+

16+f' :: forall m. Monad m => Int -> m Int

17+f' n = do

18+ n' <- return n

19+ return n'

20+

21+(←→) a b = a ←→ b

22+

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

src/Language/PureScript/CodeGen/JS/Optimizer.hs+14−10

@@ -51,11 +51,21 @@ optimize js = do

51optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS

52optimize' js = do

53 opts <- ask

54− untilFixedPoint (inlineFnComposition . applyAll

54+ js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll

55+ [ inlineCommonValues

56+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

57+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]

58+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

59+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]

60+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

61+ , inlineCommonOperators

62+ ]) js

63+ untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'

64+ where

65+ tidyUp :: JS -> JS

66+ tidyUp = applyAll

55 [ collapseNestedBlocks

67 [ collapseNestedBlocks

56 , collapseNestedIfs

68 , collapseNestedIfs

57− , tco opts

58− , magicDo opts

59 , removeCodeAfterReturnStatements

69 , removeCodeAfterReturnStatements

60 , removeUnusedArg

70 , removeUnusedArg

61 , removeUndefinedApp

71 , removeUndefinedApp

@@ -63,13 +73,7 @@ optimize' js = do

63 , etaConvert

73 , etaConvert

64 , evaluateIifes

74 , evaluateIifes

65 , inlineVariables

75 , inlineVariables

66− , inlineValues

76+ ]

67− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

68− , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]

69− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

70− , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]

71− , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

72− , inlineCommonOperators ]) js

74untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

78untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

75untilFixedPoint f = go

79untilFixedPoint f = go

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+3−3

@@ -3,7 +3,7 @@

3--

4module Language.PureScript.CodeGen.JS.Optimizer.Inliner

5 ( inlineVariables

6− , inlineValues

6+ , inlineCommonValues

7 , inlineOperator

8 , inlineCommonOperators

9 , inlineFnComposition

@@ -77,8 +77,8 @@ inlineVariables = everywhereOnJS $ removeFromBlock go

77 go (map (replaceIdent var js) sts)

78 go (s:sts) = s : go sts

80−inlineValues :: JS -> JS

80+inlineCommonValues :: JS -> JS

81−inlineValues = everywhereOnJS convert

81+inlineCommonValues = everywhereOnJS convert

82 where

83 convert :: JS -> JS

84 convert (JSApp fn [dict])

src/Language/PureScript/Linter/Exhaustive.hs+10−10

@@ -31,13 +31,13 @@ import Language.PureScript.Kinds

31import Language.PureScript.Types as P

32import Language.PureScript.Errors

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

34+-- | There are two modes of failure for the redundancy check:

35--

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

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

38--

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

40−data RedudancyError = Incomplete | Unknown

40+data RedundancyError = Incomplete | Unknown

42-- |

43-- Qualifies a propername from a given qualified propername and a default module name

@@ -106,7 +106,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

106-- Find the uncovered set between two binders:

107-- the first binder is the case we are trying to cover, the second one is the matching binder

108--

109−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)

109+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)

110missingCasesSingle _ _ _ NullBinder = ([], return True)

111missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

112missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

@@ -175,7 +175,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)

175-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

176-- (which ought to be available soon), or increase the complexity of the algorithm.

177--

178−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

178+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

179missingCasesMultiple env mn = go

180 where

181 go [] [] = ([], pure True)

@@ -210,10 +210,10 @@ isExhaustiveGuard (Right _) = True

210-- |

211-- Returns the uncovered set of case alternatives

212--

213−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)

213+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)

214missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

215

216−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

216+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

217missingAlternative env mn ca uncovered

218 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

219 | otherwise = ([uncovered], snd mcases)

@@ -229,13 +229,13 @@ missingAlternative env mn ca uncovered

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

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

231 where

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

232+ step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))

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

234 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

235 (missed', approx) = splitAt 10000 (nub (concat missed))

236− cond = liftA2 (&&) (or <$> sequenceA pr) nec

236+ cond = or <$> sequenceA pr

237 in (missed', ( if null approx

238− then cond

238+ then liftA2 (&&) cond nec

239 else Left Incomplete

240 , if either (const True) id cond

241 then redundant

@@ -243,7 +243,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

243 )

244 )

245

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

246+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()

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

248 do unless (hasConstraint || null bss) tellNonExhaustive

249 unless (null bss') tellRedundant

src/Language/PureScript/Parser/Lexer.hs+6

@@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do

185parseToken :: P.Parsec String u Token

186parseToken = P.choice

187 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

188+ , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow

188 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

189 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

190+ , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow

189 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

191 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

192+ , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow

190 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

193 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

194+ , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow

191 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

195 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

196+ , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon

192 , P.try $ P.char '(' *> pure LParen

197 , P.try $ P.char '(' *> pure LParen

193 , P.try $ P.char ')' *> pure RParen

198 , P.try $ P.char ')' *> pure RParen

194 , P.try $ P.char '{' *> pure LBrace

199 , P.try $ P.char '{' *> pure LBrace

@@ -411,6 +416,7 @@ reserved :: String -> TokenParser ()

411reserved s = token go P.<?> show s

416reserved s = token go P.<?> show s

412 where

417 where

413 go (LName s') | s == s' = Just ()

418 go (LName s') | s == s' = Just ()

419+ go (Symbol s') | s == s' = Just ()

414 go _ = Nothing

420 go _ = Nothing

415

421

416uname :: TokenParser String

422uname :: TokenParser String

src/Language/PureScript/Parser/Types.hs+1−1

@@ -36,7 +36,7 @@ parseTypeConstructor :: TokenParser Type

36parseTypeConstructor = TypeConstructor <$> parseQualified properName

38parseForAll :: TokenParser Type

39−parseForAll = mkForAll <$> (reserved "forall" *> P.many1 (indented *> identifier) <* indented <* dot)

39+parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot)

40 <*> parseType

42-- |