git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge remote-tracking branch 'upstream/master' into pure11-0.8
commitfc062f224501787364c29331006fa26a090e0fc8 authorAndy Arvanitis <andyarvanitis@gmail.com> dateSun 31 Jan 2016, 15:01 (11 years ago) parent2d469bd1b5d32d
8 files changed+78−24
compare with golang
unifiedsplit
CONTRIBUTORS.md+1 examples/passing/TCO.purs+20 examples/passing/UnicodeType.purs+23 src/Language/PureScript/CodeGen/JS/Optimizer.hs+14−10 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+3−3 src/Language/PureScript/Linter/Exhaustive.hs+10−10 src/Language/PureScript/Parser/Lexer.hs+6 src/Language/PureScript/Parser/Types.hs+1−1
CONTRIBUTORS.md+1
@@ -64,6 +64,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
6464- [@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).
6565- [@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).
6666- [@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).
6768
6869### Companies
6970
examples/passing/TCO.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff.Console (print)
5+
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
2+
3+import Prelude
4+
5+class (Monad m) ⇐ Monad1 m where
6+ f1 :: Int
7+
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
5151optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
5252optimize' js = do
5353 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
5567 [ collapseNestedBlocks
5668 , collapseNestedIfs
57− , tco opts
58− , magicDo opts
5969 , removeCodeAfterReturnStatements
6070 , removeUnusedArg
6171 , removeUndefinedApp
@@ -63,13 +73,7 @@ optimize' js = do
6373 , etaConvert
6474 , evaluateIifes
6575 , inlineVariables
66− , inlineValues
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
76+ ]
7377
7478untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
7579untilFixedPoint f = go
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+3−3
@@ -3,7 +3,7 @@
33--
44module Language.PureScript.CodeGen.JS.Optimizer.Inliner
55 ( inlineVariables
6− , inlineValues
6+ , inlineCommonValues
77 , inlineOperator
88 , inlineCommonOperators
99 , inlineFnComposition
@@ -77,8 +77,8 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
7777 go (map (replaceIdent var js) sts)
7878 go (s:sts) = s : go sts
7979
80−inlineValues :: JS -> JS
81−inlineValues = everywhereOnJS convert
80+inlineCommonValues :: JS -> JS
81+inlineCommonValues = everywhereOnJS convert
8282 where
8383 convert :: JS -> JS
8484 convert (JSApp fn [dict])
src/Language/PureScript/Linter/Exhaustive.hs+10−10
@@ -31,13 +31,13 @@ import Language.PureScript.Kinds
3131import Language.PureScript.Types as P
3232import Language.PureScript.Errors
3333
34−-- | There are two modes of failure for the redudancy check:
34+-- | There are two modes of failure for the redundancy check:
3535--
3636-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
3737-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
3838--
3939-- We want to warn the user in the first case.
40−data RedudancyError = Incomplete | Unknown
40+data RedundancyError = Incomplete | Unknown
4141
4242-- |
4343-- 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')
106106-- Find the uncovered set between two binders:
107107-- the first binder is the case we are trying to cover, the second one is the matching binder
108108--
109−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
109+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
110110missingCasesSingle _ _ _ NullBinder = ([], return True)
111111missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
112112missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
@@ -175,7 +175,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)
175175-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
176176-- (which ought to be available soon), or increase the complexity of the algorithm.
177177--
178−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
178+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
179179missingCasesMultiple env mn = go
180180 where
181181 go [] [] = ([], pure True)
@@ -210,10 +210,10 @@ isExhaustiveGuard (Right _) = True
210210-- |
211211-- Returns the uncovered set of case alternatives
212212--
213−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
213+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
214214missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
215215
216−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
216+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
217217missingAlternative env mn ca uncovered
218218 | isExhaustiveGuard (caseAlternativeResult ca) = mcases
219219 | otherwise = ([uncovered], snd mcases)
@@ -229,13 +229,13 @@ missingAlternative env mn ca uncovered
229229checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
230230checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
231231 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]]))
233233 step (uncovered, (nec, redundant)) ca =
234234 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
235235 (missed', approx) = splitAt 10000 (nub (concat missed))
236− cond = liftA2 (&&) (or <$> sequenceA pr) nec
236+ cond = or <$> sequenceA pr
237237 in (missed', ( if null approx
238− then cond
238+ then liftA2 (&&) cond nec
239239 else Left Incomplete
240240 , if either (const True) id cond
241241 then redundant
@@ -243,7 +243,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold
243243 )
244244 )
245245
246− makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
246+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()
247247 makeResult (bss, (rr, bss')) =
248248 do unless (hasConstraint || null bss) tellNonExhaustive
249249 unless (null bss') tellRedundant
src/Language/PureScript/Parser/Lexer.hs+6
@@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do
185185parseToken :: P.Parsec String u Token
186186parseToken = P.choice
187187 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
188+ , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow
188189 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
190+ , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow
189191 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
192+ , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow
190193 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
194+ , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow
191195 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
196+ , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon
192197 , P.try $ P.char '(' *> pure LParen
193198 , P.try $ P.char ')' *> pure RParen
194199 , P.try $ P.char '{' *> pure LBrace
@@ -411,6 +416,7 @@ reserved :: String -> TokenParser ()
411416reserved s = token go P.<?> show s
412417 where
413418 go (LName s') | s == s' = Just ()
419+ go (Symbol s') | s == s' = Just ()
414420 go _ = Nothing
415421
416422uname :: TokenParser String
src/Language/PureScript/Parser/Types.hs+1−1
@@ -36,7 +36,7 @@ parseTypeConstructor :: TokenParser Type
3636parseTypeConstructor = TypeConstructor <$> parseQualified properName
3737
3838parseForAll :: 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)
4040 <*> parseType
4141
4242-- |