00086aa · rowtype-yoga/purescript-native

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

Merge pull request #850 from purescript/839

Extended infix operators

commit00086aa9973773e3dbdf6715fbd2deb62c0f394b authorPhil Freeman <paf31@cantab.net> dateSun 8 Feb 2015, 13:53 (12 years ago) parent075a90c 6120951

9 files changed+63−47

compare with golang

unifiedsplit

examples/passing/ExtendedInfixOperators.purs+20 src/Language/PureScript/AST/Declarations.hs+2−2 src/Language/PureScript/AST/Traversals.hs+18−19 src/Language/PureScript/ModuleDependencies.hs−1 src/Language/PureScript/Parser/Common.hs−6 src/Language/PureScript/Parser/Declarations.hs+11−3 src/Language/PureScript/Pretty/Values.hs+2−2 src/Language/PureScript/Sugar/Names.hs−4 src/Language/PureScript/Sugar/Operators.hs+10−10

examples/passing/ExtendedInfixOperators.pursnew file+20

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

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

306306 -- will be removed.

307307 --

308− | BinaryNoParens (Qualified Ident) Expr Expr

308+ | BinaryNoParens Expr Expr Expr

309309 -- |

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

311311 -- will be removed.

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

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

316316 -- operator or lambda to flip the arguments.

317317 --

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

318+ | OperatorSection Expr (Either Expr Expr)

319319 -- |

320320 -- An array literal

321321 --

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

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

4343

4444 g' :: Expr -> Expr

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

4747 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

8787

88−

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

9089 (Declaration -> m Declaration) ->

9190 (Expr -> m Expr) ->

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

102101 f' other = f other

103102

104103 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')

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

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

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

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

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

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

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

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

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

155154 f' other = f other

156155

157156 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

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

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

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

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

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

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

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

164163 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')

211210 f' d = f d

212211

213212 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

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

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

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

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

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

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

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

220219 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'

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

279278

280279 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

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

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

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

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

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

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

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

287286 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

348347 g'' s = uncurry g' <=< g s

349348

350349 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

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

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

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

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

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

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

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

357356 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 (

5454

5555 forValues :: Expr -> [ModuleName]

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

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

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

5958 forValues (TypedValue _ _ ty) = forTypes ty

6059 forValues _ = []

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

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

8888 Nothing -> return a

8989 Just a' -> go a'

9090

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−

9791-- |

9892-- Mark the current indentation level

9993--

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

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

4141import Language.PureScript.Parser.Types

4242import Language.PureScript.Parser.Kinds

4343import Language.PureScript.Parser.Lexer

44+import Language.PureScript.Names

4445import Language.PureScript.CodeGen.JS.AST

4546import Language.PureScript.Environment

4647

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

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

357358 , parseOperatorSection ]

358359

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+

359367parseOperatorSection :: TokenParser Expr

360368parseOperatorSection = parens $ left <|> right

361369 where

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

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

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

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

364372

365373parsePropertyUpdate :: TokenParser (String, Maybe Expr)

366374parsePropertyUpdate = do

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

411419 ]

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

413421 ]

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

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

415423 return (BinaryNoParens ident)) P.AssocRight

416424 ]

417425 ]

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

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

7373 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

7474 , currentIndent

7575 ]

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

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

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

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

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

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

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

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

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

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

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

242242 (,) (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)

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

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

249245 updateValue s v = return (s, v)

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

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

105105 in

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

107107

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

108+type Chain = [Either Expr Expr]

109109

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

111111matchOperators ops = parseChains

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

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

115115 parseChains other = return other

116116 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

118118 extendChain other = [Left other]

119119 bracketChain :: Chain -> Either ErrorStack Expr

120120 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]

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

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

124124

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

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

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

138138 where

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

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

140140 fromOp _ = Nothing

141141

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

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

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

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

144144 where

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

146− fromOp _ = Nothing

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

146+ fromOther v = Just v

147147

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

149149matchOp op = do

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

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

159159

160160 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

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

163163 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

165165 goExpr other = return other