80ecc42 · rowtype-yoga/purescript-native

examples/passing/OperatorSections.pursnew file+21

compare with golang

unifiedsplit

@@ -0,0 +1,21 @@

1+module Main where

2+

3+foreign import eqeqeq

4+ """

5+ function eqeqeq(x) {

6+ return function (y) {

7+ if (x == y) return x;

8+ throw new Error("Unexpected result: " + x + " /== " + y);

9+ };

10+ };

11+ """ :: forall a. a -> a -> a

12+

13+(===) = eqeqeq

14+infixl 4 ===

15+

16+main = do

17+ Debug.Trace.print $ (/ 2) 4 === 2

18+ Debug.Trace.print $ (2 /) 4 === 0.5

19+ Debug.Trace.print $ (`const` 1) 2 === 2

20+ Debug.Trace.print $ (1 `const`) 2 === 1

21+ Debug.Trace.trace "Done!"

src/Language/PureScript/AST/Declarations.hs+5

@@ -312,6 +312,11 @@ data Expr

312 --

313 | Parens Expr

314 -- |

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)

319+ -- |

315 -- An array literal

320 -- An array literal

316 --

321 --

317 | ArrayLiteral [Expr]

322 | ArrayLiteral [Expr]

src/Language/PureScript/Parser/Declarations.hs+8−1

@@ -353,7 +353,14 @@ parseValueAtom = P.choice

353 , parseIfThenElse

354 , parseDo

355 , parseLet

356− , Parens <$> parens parseValue ]

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

357+ , parseOperatorSection ]

358+

359+parseOperatorSection :: TokenParser Expr

360+parseOperatorSection = parens $ left <|> right

361+ where

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

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

357

364

358parsePropertyUpdate :: TokenParser (String, Maybe Expr)

365parsePropertyUpdate :: TokenParser (String, Maybe Expr)

359parsePropertyUpdate = do

366parsePropertyUpdate = do

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

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

73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

74 , currentIndent

75 ]

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

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

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

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

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

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

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

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

src/Language/PureScript/Sugar.hs+5−2

@@ -37,7 +37,9 @@ import Language.PureScript.Sugar.TypeDeclarations as S

37--

38-- * Remove signed literals in favour of `negate` applications

39--

40−-- * Desguar object literals with wildcards into lambdas

40+-- * Desugar object literals with wildcards into lambdas

41+--

42+-- * Desugar operator sections

41--

43--

42-- * Desugar do-notation using the @Prelude.Monad@ type class

44-- * Desugar do-notation using the @Prelude.Monad@ type class

43--

45--

@@ -56,7 +58,8 @@ import Language.PureScript.Sugar.TypeDeclarations as S

56desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

58desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

57desugar = map removeSignedLiterals

59desugar = map removeSignedLiterals

58 >>> map desugarObjectConstructors

60 >>> map desugarObjectConstructors

61+ >>> mapM desugarOperatorSections

59− >>> mapM desugarDoModule

62+ >=> mapM desugarDoModule

60 >=> desugarCasesModule

63 >=> desugarCasesModule

61 >=> lift . (desugarTypeDeclarationsModule

64 >=> lift . (desugarTypeDeclarationsModule

62 >=> desugarImports

65 >=> desugarImports

src/Language/PureScript/Sugar/Operators.hs+17−2

@@ -21,12 +21,14 @@

21

22module Language.PureScript.Sugar.Operators (

23 rebracket,

24− removeSignedLiterals

24+ removeSignedLiterals,

25+ desugarOperatorSections

25) where

26) where

26

27

27−import Language.PureScript.Names

28import Language.PureScript.AST

29import Language.PureScript.Errors

30+import Language.PureScript.Names

31+import Language.PureScript.Supply

30

32

31import Control.Applicative

33import Control.Applicative

32import Control.Monad.State

34import Control.Monad.State

@@ -148,3 +150,16 @@ matchOp op = do

148 ident <- parseOp

150 ident <- parseOp

149 guard $ ident == op

151 guard $ ident == op

150

152

153+desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module

154+desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts

155+ where

156+

157+ goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

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

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

165+ goExpr other = return other