Skip to content

Commit 00086aa

Browse files
paf31paf31
committed
Merge pull request purescript#850 from purescript/839
Extended infix operators
2 parents 075a90c + 6120951 commit 00086aa

File tree

9 files changed

+63
-47
lines changed

9 files changed

+63
-47
lines changed

‎examples/passing/ExtendedInfixOperators.purs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
module Main where
2+
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
7+
8+
test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]
9+
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‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 18 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -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-
8988
everywhereOnValuesTopDownM :: (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‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Language.PureScript.Parser.Common
4141
import Language.PureScript.Parser.Types
4242
import Language.PureScript.Parser.Kinds
4343
import Language.PureScript.Parser.Lexer
44+
import Language.PureScript.Names
4445
import Language.PureScript.CodeGen.JS.AST
4546
import 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+
359367
parseOperatorSection :: TokenParser Expr
360368
parseOperatorSection = 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

365373
parsePropertyUpdate :: TokenParser (String, Maybe Expr)
366374
parsePropertyUpdate = 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‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -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

110110
matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
111111
matchOperators 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"
136136
parseOp :: P.Parsec Chain () (Qualified Ident)
137137
parseOp = 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

148148
matchOp :: Qualified Ident -> P.Parsec Chain () ()
149149
matchOp 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

0 commit comments

Comments
 (0)