00086aa · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #850 from purescript/839

00086aaPhil Freeman12 years ago

examples/passing/ExtendedInfixOperators.pursnew file+20

compare with golang

unifiedsplit

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

1+module Main where

3+zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

4+zipWith _ [] _ = []

5+zipWith _ _ [] = []

6+zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys

8+test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]

10+comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering

11+comparing f = compare `Data.Function.on` f

12+

13+sum [] = 0

14+sum (x:xs) = x + sum xs

15+

16+test2 = [1, 2, 3] `comparing sum` [4, 5, 6]

17+

18+main = do

19+ Debug.Trace.print test1

20+ Debug.Trace.print test2

src/Language/PureScript/AST/Declarations.hs+2−2

@@ -305,7 +305,7 @@ data Expr

305 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

306 -- will be removed.

307 --

308− | BinaryNoParens (Qualified Ident) Expr Expr

308+ | BinaryNoParens Expr Expr Expr

309 -- |

310 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

311 -- will be removed.

@@ -315,7 +315,7 @@ data Expr

315 -- Operator section. This will be removed during desugaring and replaced with a partially applied

316 -- operator or lambda to flip the arguments.

317 --

318− | OperatorSection (Qualified Ident) (Either Expr Expr)

318+ | OperatorSection Expr (Either Expr Expr)

319 -- |

320 -- An array literal

321 --

src/Language/PureScript/AST/Traversals.hs+18−19

@@ -43,10 +43,10 @@ everywhereOnValues f g h = (f', g', h')

44 g' :: Expr -> Expr

45 g' (UnaryMinus v) = g (UnaryMinus (g' v))

46− g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

46+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

47 g' (Parens v) = g (Parens (g' v))

48− g' (OperatorSection op (Left v)) = g (OperatorSection op (Left $ g' v))

48+ g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

49− g' (OperatorSection op (Right v)) = g (OperatorSection op (Right $ g' v))

49+ g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

50 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

51 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

52 g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

@@ -85,7 +85,6 @@ everywhereOnValues f g h = (f', g', h')

85 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

86 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

88−

89everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

88everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

90 (Declaration -> m Declaration) ->

89 (Declaration -> m Declaration) ->

91 (Expr -> m Expr) ->

90 (Expr -> m Expr) ->

@@ -102,10 +101,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

102 f' other = f other

101 f' other = f other

103

102

104 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

103 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

105− g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')

104+ g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

106 g' (Parens v) = Parens <$> (g v >>= g')

105 g' (Parens v) = Parens <$> (g v >>= g')

107− g' (OperatorSection op (Left v)) = OperatorSection op . Left <$> (g v >>= g')

106+ g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

108− g' (OperatorSection op (Right v)) = OperatorSection op . Right <$> (g v >>= g')

107+ g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

109 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

108 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

110 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

109 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

111 g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs

110 g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs

@@ -155,10 +154,10 @@ everywhereOnValuesM f g h = (f', g', h')

155 f' other = f other

154 f' other = f other

156

155

157 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

156 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

158− g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g

157+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

159 g' (Parens v) = (Parens <$> g' v) >>= g

158 g' (Parens v) = (Parens <$> g' v) >>= g

160− g' (OperatorSection op (Left v)) = (OperatorSection op . Left <$> g' v) >>= g

159+ g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

161− g' (OperatorSection op (Right v)) = (OperatorSection op . Right <$> g' v) >>= g

160+ g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

162 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

161 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

163 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

162 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

164 g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g

163 g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g

@@ -211,10 +210,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

211 f' d = f d

210 f' d = f d

212

211

213 g' v@(UnaryMinus v1) = g v <> g' v1

212 g' v@(UnaryMinus v1) = g v <> g' v1

214− g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2

213+ g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2

215 g' v@(Parens v1) = g v <> g' v1

214 g' v@(Parens v1) = g v <> g' v1

216− g' v@(OperatorSection _ (Left v1)) = g v <> g' v1

215+ g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1

217− g' v@(OperatorSection _ (Right v1)) = g v <> g' v1

216+ g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1

218 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

217 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

219 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

218 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

220 g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

219 g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

@@ -278,10 +277,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

278 g'' s v = let (s', r) = g s v in r <> g' s' v

277 g'' s v = let (s', r) = g s v in r <> g' s' v

279

278

280 g' s (UnaryMinus v1) = g'' s v1

279 g' s (UnaryMinus v1) = g'' s v1

281− g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2

280+ g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

282 g' s (Parens v1) = g'' s v1

281 g' s (Parens v1) = g'' s v1

283− g' s (OperatorSection _ (Left v)) = g'' s v

282+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

284− g' s (OperatorSection _ (Right v)) = g'' s v

283+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

285 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

284 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

286 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

285 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

287 g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

286 g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

@@ -348,10 +347,10 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

348 g'' s = uncurry g' <=< g s

347 g'' s = uncurry g' <=< g s

349

348

350 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

349 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

351− g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2

350+ g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

352 g' s (Parens v) = Parens <$> g'' s v

351 g' s (Parens v) = Parens <$> g'' s v

353− g' s (OperatorSection op (Left v)) = OperatorSection op . Left <$> g'' s v

352+ g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

354− g' s (OperatorSection op (Right v)) = OperatorSection op . Right <$> g'' s v

353+ g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

355 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

354 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

356 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

355 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

357 g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs

356 g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs

src/Language/PureScript/ModuleDependencies.hs−1

@@ -54,7 +54,6 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

55 forValues :: Expr -> [ModuleName]

56 forValues (Var (Qualified (Just mn) _)) = [mn]

57− forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]

58 forValues (Constructor (Qualified (Just mn) _)) = [mn]

57 forValues (Constructor (Qualified (Just mn) _)) = [mn]

59 forValues (TypedValue _ _ ty) = forTypes ty

58 forValues (TypedValue _ _ ty) = forTypes ty

60 forValues _ = []

59 forValues _ = []

src/Language/PureScript/Parser/Common.hs−6

@@ -88,12 +88,6 @@ buildPostfixParser fs first = do

88 Nothing -> return a

89 Just a' -> go a'

91−-- |

92−-- Parse an identifier in backticks or an operator

93−--

94−parseIdentInfix :: TokenParser (Qualified Ident)

95−parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))

96−

97-- |

91-- |

98-- Mark the current indentation level

92-- Mark the current indentation level

99--

93--

src/Language/PureScript/Parser/Declarations.hs+11−3

@@ -41,6 +41,7 @@ import Language.PureScript.Parser.Common

41import Language.PureScript.Parser.Types

42import Language.PureScript.Parser.Kinds

43import Language.PureScript.Parser.Lexer

44+import Language.PureScript.Names

44import Language.PureScript.CodeGen.JS.AST

45import Language.PureScript.CodeGen.JS.AST

45import Language.PureScript.Environment

46import Language.PureScript.Environment

@@ -356,11 +357,18 @@ parseValueAtom = P.choice

356 , P.try $ Parens <$> parens parseValue

357 , P.try $ Parens <$> parens parseValue

357 , parseOperatorSection ]

358 , parseOperatorSection ]

358

359

360+-- |

361+-- Parse an expression in backticks or an operator

362+--

363+parseInfixExpr :: TokenParser Expr

364+parseInfixExpr = P.between tick tick parseValue

365+ <|> Var <$> parseQualified (Op <$> symbol)

366+

359parseOperatorSection :: TokenParser Expr

367parseOperatorSection :: TokenParser Expr

360parseOperatorSection = parens $ left <|> right

368parseOperatorSection = parens $ left <|> right

361 where

369 where

362− right = OperatorSection <$> parseIdentInfix <* indented <*> (Right <$> parseValueAtom)

370+ right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)

363− left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseIdentInfix

371+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr

364

372

365parsePropertyUpdate :: TokenParser (String, Maybe Expr)

373parsePropertyUpdate :: TokenParser (String, Maybe Expr)

366parsePropertyUpdate = do

374parsePropertyUpdate = do

@@ -411,7 +419,7 @@ parseValue = withSourceSpan PositionedValue

411 ]

419 ]

412 operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

420 operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

413 ]

421 ]

414− , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

422+ , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

415 return (BinaryNoParens ident)) P.AssocRight

423 return (BinaryNoParens ident)) P.AssocRight

416 ]

424 ]

417 ]

425 ]

src/Language/PureScript/Pretty/Values.hs+2−2

@@ -73,8 +73,8 @@ literals = mkPattern' match

73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

74 , currentIndent

75 ]

76− match (OperatorSection op (Right val)) = return $ "(" ++ show op ++ " " ++ prettyPrintValue val ++ ")"

76+ match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"

77− match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ show op ++ ")"

77+ match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"

78 match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

79 match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

80 match (TypedValue _ val _) = prettyPrintValue' val

src/Language/PureScript/Sugar/Names.hs−4

@@ -240,10 +240,6 @@ renameInModule imports exports (Module mn decls exps) =

240 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

241 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

242 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

243− updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =

244− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

245− updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

246− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

247 updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

243 updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

248 updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

244 updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

249 updateValue s v = return (s, v)

245 updateValue s v = return (s, v)

src/Language/PureScript/Sugar/Operators.hs+10−10

@@ -105,7 +105,7 @@ customOperatorTable fixities =

105 in

106 map (map (\(name, f, _, a) -> (name, f, a))) groups

107

108−type Chain = [Either Expr (Qualified Ident)]

108+type Chain = [Either Expr Expr]

109

110matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr

111matchOperators ops = parseChains

@@ -114,11 +114,11 @@ matchOperators ops = parseChains

114 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

115 parseChains other = return other

116 extendChain :: Expr -> Chain

117− extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

117+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

118 extendChain other = [Left other]

119 bracketChain :: Chain -> Either ErrorStack Expr

120 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

121− opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

121+ opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

122 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

123 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

124

@@ -136,14 +136,14 @@ parseValue = token (either Just (const Nothing)) P.<?> "expression"

136parseOp :: P.Parsec Chain () (Qualified Ident)

137parseOp = token (either (const Nothing) fromOp) P.<?> "operator"

138 where

139− fromOp q@(Qualified _ (Op _)) = Just q

139+ fromOp (Var q@(Qualified _ (Op _))) = Just q

140 fromOp _ = Nothing

141

142−parseTicks :: P.Parsec Chain () (Qualified Ident)

142+parseTicks :: P.Parsec Chain () Expr

143−parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"

143+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

144 where

145− fromOp q@(Qualified _ (Ident _)) = Just q

145+ fromOther (Var (Qualified _ (Op _))) = Nothing

146− fromOp _ = Nothing

146+ fromOther v = Just v

147

148matchOp :: Qualified Ident -> P.Parsec Chain () ()

149matchOp op = do

@@ -158,8 +158,8 @@ desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> p

158 (goDecl, _, _) = everywhereOnValuesM return goExpr return

159

160 goExpr :: Expr -> SupplyT (Either ErrorStack) Expr

161− goExpr (OperatorSection op (Left val)) = return $ App (Var op) val

161+ goExpr (OperatorSection op (Left val)) = return $ App op val

162 goExpr (OperatorSection op (Right val)) = do

163 arg <- Ident <$> freshName

164− return $ Abs (Left arg) $ App (App (Var op) (Var (Qualified Nothing arg))) val

164+ return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

165 goExpr other = return other