0b98112 · rowtype-yoga/purescript-native

examples/passing/Do.purs+28−23

compare with golang

unifiedsplit

@@ -1,54 +1,59 @@

1−module Do where

1+module Prelude where

2

3−data Maybe a = Nothing | Just a

3+class Monad m where

4+ ret :: forall a. a -> m a

5+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

4

6

5−bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b

7+module Do where

6−bindMaybe Nothing _ = Nothing

7−bindMaybe (Just a) f = f a

8

9−maybe = { ret: Just, bind: bindMaybe }

9+import Prelude

10+

11+data Maybe a = Nothing | Just a

10

12

11−test1 = maybe do Just "abc"

13+instance Prelude.Monad Maybe where

14+ ret = Just

15+ (>>=) Nothing _ = Nothing

16+ (>>=) (Just a) f = f a

12

17

13−test2 = maybe do return "xyz"

18+test1 = do Just "abc"

14

19

15−test3 = maybe do

20+test3 = do

16 (x : _) <- Just [1, 2, 3]

21 (x : _) <- Just [1, 2, 3]

17 (y : _) <- Just [4, 5, 6]

22 (y : _) <- Just [4, 5, 6]

18− return x + y

23+ Just (x + y)

19

24

20−test4 = maybe do

25+test4 = do

21 Just 1

26 Just 1

22 Nothing :: Maybe Number

27 Nothing :: Maybe Number

23− return 2

28+ Just 2

24

29

25−test5 mx my = maybe do

30+test5 mx my = do

26 x <- mx

31 x <- mx

27 y <- my

32 y <- my

28− return x + y

33+ Just (x + y)

29

34

30−test6 mx my mz = maybe do

35+test6 mx my mz = do

31 x <- mx

36 x <- mx

32 y <- my

37 y <- my

33 let sum = x + y

38 let sum = x + y

34 z <- mz

39 z <- mz

35− return z + sum

40+ Just (z + sum)

36

41

37−test7 mx = maybe do let Just x = mx

42+test7 mx = do let Just x = mx

38− return x

43+ Just x

39

44

40−test8 = maybe do return (maybe do return 1)

45+test8 = do Just (do Just 1)

41

46

42(<$>) :: forall a b. (a -> b) -> Maybe a -> Maybe b

47(<$>) :: forall a b. (a -> b) -> Maybe a -> Maybe b

43−(<$>) f m = maybe do

48+(<$>) f m = do

44 a <- m

49 a <- m

45− return f a

50+ ret (f a)

46

51

47(<*>) :: forall a b. (Maybe (a -> b)) -> Maybe a -> Maybe b

52(<*>) :: forall a b. (Maybe (a -> b)) -> Maybe a -> Maybe b

48−(<*>) f m = maybe do

53+(<*>) f m = do

49 g <- f

54 g <- f

50 a <- m

55 a <- m

51− return g a

56+ ret (g a)

52

57

53foo x y z = x + y + z

58foo x y z = x + y + z

54

59

examples/passing/Eff.purs+19−10

@@ -1,19 +1,29 @@

1+module Prelude where

2+

3+class Monad m where

4+ ret :: forall a. a -> m a

5+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

6+

1module Eff where

7module Eff where

2

8

9+import Prelude

10+

3-- Eff Monad

11-- Eff Monad

4

12

5foreign import data Eff :: # ! -> * -> *

13foreign import data Eff :: # ! -> * -> *

6

14

7−foreign import ret :: forall e a. a -> Eff e a

15+foreign import retEff :: forall e a. a -> Eff e a

8

16

9−foreign import (>>=) :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

17+foreign import bindEff :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

18+

19+instance Prelude.Monad (Eff e) where

20+ ret = retEff

21+ (>>=) = bindEff

10

22

11type Pure a = forall e. Eff e a

23type Pure a = forall e. Eff e a

12

24

13foreign import runPure :: forall a. Pure a -> a

25foreign import runPure :: forall a. Pure a -> a

14

26

15−eff = { ret: ret, bind: (>>=) }

16−

17-- Errors

27-- Errors

18

28

19foreign import data Error :: * -> !

29foreign import data Error :: * -> !

@@ -49,13 +59,12 @@ foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r

49-- Tests

59-- Tests

50

60

51test1 = runPure (runState 0 (catchError (\s -> ret 0)

61test1 = runPure (runState 0 (catchError (\s -> ret 0)

52− (eff do

53− s <- get

62+ (do s <- get

54− throwError "Error!"

63+ throwError "Error!"

55− set (s + 1)

64+ set (s + 1)

56− return s)))

65+ ret s)))

57

66

58−test2 = runPure (runST (eff do

67+test2 = runPure (runST (do

59 ref <- newSTRef 0

68 ref <- newSTRef 0

60 modifySTRef (\n -> n + 1) ref

69 modifySTRef (\n -> n + 1) ref

61 readSTRef ref))

70 readSTRef ref))

examples/passing/TypeClasses.purs−7

@@ -46,10 +46,3 @@ instance (TypeClasses.Show a) => TypeClasses.Show [a] where

46 show [] = "[]"

47 show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs

48

49−module Main where

50−

51−import Trace

52−import TypeClasses

53−import TypeClasses2

54−

55−main = print (show ["a", "b", "c"])

libraries/jquery/tests/jquery.purs+2−2

@@ -5,7 +5,7 @@ import Eff

5import Trace

6import JQuery

7

8−main = eff do

8+main = do

9 -- Get the document body

10 b <- body

11

@@ -22,7 +22,7 @@ main = eff do

22 greeting `append` b

23

24 -- Listen for change events on the text box

25− flip (on "change") input $ eff do

25+ flip (on "change") input $ do

26 name <- getValue input

27 trace $ "Name changed to " ++ name

28 setText ("Hello, " ++ name) greeting

libraries/prelude/prelude.purs+18−2

@@ -24,6 +24,20 @@ module Prelude where

24

25 infixr 1000 $

26

27+ class Show a where

28+ show :: a -> String

29+

30+ instance Show String where

31+ show s = s

32+

33+ instance Show Boolean where

34+ show true = "true"

35+ show false = "false"

36+

37+ class Monad m where

38+ ret :: forall a. a -> m a

39+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

40+

27module Maybe where

41module Maybe where

28

42

29 data Maybe a = Nothing | Just a

43 data Maybe a = Nothing | Just a

@@ -277,7 +291,9 @@ module Eff where

277

291

278 foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a

292 foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a

279

293

294+ instance Prelude.Monad (Eff e) where

280− eff = { ret: retEff, bind: bindEff }

295+ ret = retEff

296+ (>>=) = bindEff

281

297

282module Errors where

298module Errors where

283

299

@@ -311,7 +327,7 @@ module Trace where

311

327

312 foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}

328 foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}

313

329

314− foreign import print "function print(o) { return function() { console.log(JSON.stringify(o)); return {}; }; }" :: forall a r. a -> Eff (trace :: Trace | r) {}

330+ foreign import print "function print(dict) { return function (o) { return function() { console.log(Prelude.show(dict)(o)); return {}; }; }; }" :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

315

331

316module ST where

332module ST where

317

333

psci/Main.hs+3−5

@@ -60,14 +60,12 @@ createTemporaryModule imports value =

60 let

61 moduleName = P.ProperName "Main"

62 importDecl m = P.ImportDeclaration m Nothing

63− effModule = P.ModuleName (P.ProperName "Eff")

64 traceModule = P.ModuleName (P.ProperName "Trace")

63 traceModule = P.ModuleName (P.ProperName "Trace")

65− effMonad = P.Var (P.Qualified (Just effModule) (P.Ident "eff"))

66 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

64 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

67 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

65 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

68− (P.Do effMonad [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

66+ (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

69− , P.DoNotationValue (P.App trace [ P.Var (P.Qualified Nothing (P.Ident "it")) ] )

67+ , P.DoNotationValue (P.App trace [ P.Var (P.Qualified Nothing (P.Ident "it")) ] )

70− ])

68+ ])

71 in

69 in

72 P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

70 P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

73

71

src/Language/PureScript/Parser/Values.hs+7−10

@@ -113,6 +113,7 @@ parseValueAtom = P.choice

113 , parseBlock

114 , parseCase

115 , parseIfThenElse

116+ , parseDo

116 , Parens <$> C.parens parseValue ]

117 , Parens <$> C.parens parseValue ]

117

118

118parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

119parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

@@ -126,6 +127,12 @@ parseAccessor :: Value -> P.Parsec String ParseState Value

126parseAccessor (Constructor _) = P.unexpected "constructor"

127parseAccessor (Constructor _) = P.unexpected "constructor"

127parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

128parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

128

129

130+parseDo :: P.Parsec String ParseState Value

131+parseDo = do

132+ C.reserved "do"

133+ C.indented

134+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))

135+

129parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

136parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

130parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)

137parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)

131 <*> (C.indented *> C.reservedOp "=" *> parseValue)

138 <*> (C.indented *> C.reservedOp "=" *> parseValue)

@@ -133,21 +140,12 @@ parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseB

133parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

140parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

134parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)

141parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)

135

142

136−parseDoNotationReturn :: P.Parsec String ParseState DoNotationElement

137−parseDoNotationReturn = DoNotationReturn <$> (C.reserved "return" *> C.indented *> parseValue)

138−

139parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

143parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

140parseDoNotationElement = P.choice

144parseDoNotationElement = P.choice

141 [ P.try parseDoNotationBind

145 [ P.try parseDoNotationBind

142 , parseDoNotationLet

146 , parseDoNotationLet

143− , parseDoNotationReturn

144 , P.try (DoNotationValue <$> parseValue) ]

147 , P.try (DoNotationValue <$> parseValue) ]

145

148

146−parseManyDoNotationElements :: P.Parsec String ParseState [DoNotationElement]

147−parseManyDoNotationElements = do

148− C.indented

149− C.mark (P.many (C.same *> C.mark parseDoNotationElement))

150−

151parseValue :: P.Parsec String ParseState Value

149parseValue :: P.Parsec String ParseState Value

152parseValue =

150parseValue =

153 (buildExpressionParser operators

151 (buildExpressionParser operators

@@ -160,7 +158,6 @@ parseValue =

160 postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

158 postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

161 , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

159 , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

162 , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

160 , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

163− , \v -> P.try $ Do v <$> (C.indented *> C.reserved "do" *> parseManyDoNotationElements)

164 ]

161 ]

165 operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

162 operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

166 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)

163 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)

src/Language/PureScript/Pretty/Values.hs+1−8

@@ -40,6 +40,7 @@ literals = mkPattern match

40 match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

42 match (Var ident) = Just $ show ident

43+ match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

43 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

44 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

44 match _ = Nothing

45 match _ = Nothing

45

46

@@ -107,17 +108,10 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

107 match' (Binary op' v1 v2) | op' == op = Just (v1, v2)

108 match' (Binary op' v1 v2) | op' == op = Just (v1, v2)

108 match' _ = Nothing

109 match' _ = Nothing

109

110

110−_do :: Pattern () Value ([DoNotationElement], Value)

111−_do = mkPattern match

112− where

113− match (Do val els) = Just (els, val)

114− match _ = Nothing

115−

116prettyPrintDoNotationElement :: DoNotationElement -> String

111prettyPrintDoNotationElement :: DoNotationElement -> String

117prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

112prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

118prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

113prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

119prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

114prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

120−prettyPrintDoNotationElement (DoNotationReturn val) = "return " ++ prettyPrintValue val

121

115

122prettyPrintValue :: Value -> String

116prettyPrintValue :: Value -> String

123prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()

117prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()

@@ -129,7 +123,6 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (

129 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

123 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

130 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

124 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

131 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

125 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

132− , [ Wrap _do $ \els val -> val ++ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }" ]

133 , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]

126 , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]

134 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

127 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

135 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

128 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

src/Language/PureScript/Sugar/DoNotation.hs+24−20

@@ -26,27 +26,31 @@ import Language.PureScript.Scope

26desugarDo :: (Data d) => d -> Either String d

27desugarDo = everywhereM (mkM replace)

28 where

29+ prelude :: ModuleName

30+ prelude = ModuleName (ProperName "Prelude")

31+ ret :: Value

32+ ret = Var (Qualified (Just prelude) (Ident "ret"))

33+ bind :: Value

34+ bind = Var (Qualified (Just prelude) (Op ">>="))

29 replace :: Value -> Either String Value

35 replace :: Value -> Either String Value

30− replace (Do monad els) = go monad els

36+ replace (Do els) = go els

31 replace other = return other

37 replace other = return other

32− go :: Value -> [DoNotationElement] -> Either String Value

38+ go :: [DoNotationElement] -> Either String Value

33− go _ [] = error "The impossible happened in desugarDo"

39+ go [] = error "The impossible happened in desugarDo"

34− go monad [DoNotationReturn val] = return $ App (Accessor "ret" monad) [val]

35− go _ (DoNotationReturn _ : _) = Left "Return statement must be the last statement in a do block"

36− go _ [DoNotationValue val] = return val

40+ go [DoNotationValue val] = return val

37− go monad (DoNotationValue val : rest) = do

41+ go (DoNotationValue val : rest) = do

38− rest' <- go monad rest

42+ rest' <- go rest

39− return $ App (App (Accessor "bind" monad) [val]) [Abs [Ident "_"] rest']

43+ return $ App (App bind [val]) [Abs [Ident "_"] rest']

40− go _ [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

44+ go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

41− go monad (DoNotationBind NullBinder val : rest) = go monad (DoNotationValue val : rest)

45+ go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

42− go monad (DoNotationBind (VarBinder ident) val : rest) = do

46+ go (DoNotationBind (VarBinder ident) val : rest) = do

43− rest' <- go monad rest

47+ rest' <- go rest

44− return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] rest']

48+ return $ App (App bind [val]) [Abs [ident] rest']

45− go monad (DoNotationBind binder val : rest) = do

49+ go (DoNotationBind binder val : rest) = do

46− rest' <- go monad rest

50+ rest' <- go rest

47 let ident = head $ unusedNames rest'

51 let ident = head $ unusedNames rest'

48− return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]

52+ return $ App (App bind [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]

49− go _ [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

53+ go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

50− go monad (DoNotationLet binder val : rest) = do

54+ go (DoNotationLet binder val : rest) = do

51− rest' <- go monad rest

55+ rest' <- go rest

52 return $ Case [val] [([binder], Nothing, rest')]

56 return $ Case [val] [([binder], Nothing, rest')]

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

@@ -72,7 +72,7 @@ data Value

72 | Constructor (Qualified ProperName)

73 | Case [Value] [([Binder], Maybe Guard, Value)]

74 | TypedValue Bool Value Type

75− | Do Value [DoNotationElement]

75+ | Do [DoNotationElement]

76 | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

77

78data TypeClassDictionaryInScope

@@ -85,8 +85,7 @@ data TypeClassDictionaryInScope

85data DoNotationElement

86 = DoNotationValue Value

87 | DoNotationBind Binder Value

88− | DoNotationLet Binder Value

88+ | DoNotationLet Binder Value deriving (Show, Data, Typeable)

89− | DoNotationReturn Value deriving (Show, Data, Typeable)

90

89

91data Statement

90data Statement

92 = VariableIntroduction Ident Value

91 = VariableIntroduction Ident Value