d824d56 · rowtype-yoga/purescript-native

examples/failing/Do.pursnew file+10

compare with golang

unifiedsplit

@@ -0,0 +1,10 @@

1+module Do where

2+

3+id = { ret: \x -> x, bind: \x f -> f x }

4+

5+test1 = id do let x = 1

6+

7+test2 y = id do x <- y

8+

9+test3 = id do return 1

10+ return 2

examples/passing/Do.pursnew file+55

@@ -0,0 +1,55 @@

1+module Do where

2+

3+data Maybe a = Nothing | Just a

4+

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

6+bindMaybe Nothing _ = Nothing

7+bindMaybe (Just a) f = f a

8+

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

10+

11+test1 = maybe do Just "abc"

12+

13+test2 = maybe do return "xyz"

14+

15+test3 = maybe do

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

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

18+ return x + y

19+

20+test4 = maybe do

21+ Just 1

22+ Nothing

23+ return 2

24+

25+test5 mx my = maybe do

26+ x <- mx

27+ y <- my

28+ return x + y

29+

30+test6 mx my mz = maybe do

31+ x <- mx

32+ y <- my

33+ let sum = x + y

34+ z <- mz

35+ return z + sum

36+

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

38+ return x

39+

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

41+

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

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

44+ a <- m

45+ return f a

46+

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

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

49+ g <- f

50+ a <- m

51+ return g a

52+

53+foo x y z = x + y + z

54+

55+test9 = foo <$> Just 1 <*> Just 2 <*> Just 3

examples/passing/Eff.purs+13−10

@@ -1,4 +1,4 @@

1−module Kinds where

1+module Eff where

2

3-- Eff Monad

4

@@ -12,6 +12,8 @@ type Pure a = forall e. Eff e a

12

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

14

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

16+

15-- Errors

17-- Errors

16

18

17foreign import data Error :: * -> !

19foreign import data Error :: * -> !

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

47-- Tests

49-- Tests

48

50

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

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

52+ (eff do

50− (get >>= \s ->

53+ s <- get

51− throwError "Error!" >>= \_ ->

54+ throwError "Error!"

52− set (s + 1) >>= \_ ->

55+ set (s + 1)

53− ret s)))

56+ return s)))

54−

57+

55−test2 = runPure (runST (

58+test2 = runPure (runST (eff do

56− newSTRef 0 >>= \ref ->

59+ ref <- newSTRef 0

57− modifySTRef (\n -> n + 1) ref >>= \_ ->

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

58− readSTRef ref))

61+ readSTRef ref))

59

62

examples/shelltest/Foreach.jsdeleted−1

@@ -1 +0,0 @@

1−console.log(Foreach.sum([1,2,3,4,5]));

examples/shelltest/runAll.test−7

@@ -14,10 +14,3 @@ mkdir -p tests && ../../dist/build/psc/psc ../passing/List.purs -o tests/List.j

14>>>2

15>>>= 0

16

17−# Foreach

18−mkdir -p tests && ../../dist/build/psc/psc ../passing/Foreach.purs -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | nodejs

19−<<<

20−>>>

21−15

22−>>>2

23−>>>= 0

purescript.cabal+6−4

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.2.5

2+version: 0.2.6

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -17,9 +17,7 @@ library

17 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

18 directory -any, filepath -any, mtl -any, parsec -any, syb -any,

19 transformers -any, utf8-string -any

20− exposed-modules: Language.PureScript.TypeDeclarations

21− Language.PureScript.BindingGroups Language.PureScript.Scope

22− Data.Generics.Extras Language.PureScript

20+ exposed-modules: Data.Generics.Extras Language.PureScript

23 Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

21 Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

24 Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

22 Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

25 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

23 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

@@ -39,6 +37,10 @@ library

39 Language.PureScript.TypeChecker.Types Language.PureScript.Types

37 Language.PureScript.TypeChecker.Types Language.PureScript.Types

40 Language.PureScript.Unknown Language.PureScript.Values Main

38 Language.PureScript.Unknown Language.PureScript.Values Main

41 Language.PureScript.CaseDeclarations

39 Language.PureScript.CaseDeclarations

40+ Language.PureScript.DoNotation

41+ Language.PureScript.TypeDeclarations

42+ Language.PureScript.BindingGroups

43+ Language.PureScript.Scope

42 exposed: True

44 exposed: True

43 buildable: True

45 buildable: True

44 hs-source-dirs: src

46 hs-source-dirs: src

src/Language/PureScript.hs+6−1

@@ -28,6 +28,7 @@ import Language.PureScript.Operators as P

28import Language.PureScript.CaseDeclarations as P

29import Language.PureScript.TypeDeclarations as P

30import Language.PureScript.BindingGroups as P

31+import Language.PureScript.DoNotation as P

31

32

32import Data.List (intercalate)

33import Data.List (intercalate)

33import Control.Monad (forM_, (>=>))

34import Control.Monad (forM_, (>=>))

@@ -35,7 +36,11 @@ import Control.Monad (forM_, (>=>))

35compile :: [Module] -> Either String (String, String, Environment)

36compile :: [Module] -> Either String (String, String, Environment)

36compile ms = do

37compile ms = do

37 bracketted <- rebracket ms

38 bracketted <- rebracket ms

39+ desugared <- desugarDo

40+ >=> desugarCasesModule

41+ >=> desugarTypeDeclarationsModule

38− desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted

42+ >=> (return . createBindingGroupsModule)

43+ $ bracketted

39 (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

44 (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

40 let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared

45 let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared

41 let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

46 let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

src/Language/PureScript/DoNotation.hsnew file+52

@@ -0,0 +1,52 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.DoNotation

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.DoNotation (

16+ desugarDo

17+) where

18+

19+import Data.Data

20+import Data.Generics

21+

22+import Language.PureScript.Values

23+import Language.PureScript.Names

24+import Language.PureScript.Scope

25+

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

27+desugarDo = everywhereM (mkM replace)

28+ where

29+ replace :: Value -> Either String Value

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

31+ replace other = return other

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

33+ 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

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

38+ rest' <- go monad rest

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

40+ 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)

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

43+ rest' <- go monad rest

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

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

46+ rest' <- go monad rest

47+ let ident = head $ unusedNames rest'

48+ return $ App (App (Accessor "bind" monad) [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"

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

51+ rest' <- go monad rest

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

src/Language/PureScript/Parser/Common.hs+2−1

@@ -70,7 +70,8 @@ reservedNames = [ "case"

70 , "Boolean"

71 , "infixl"

72 , "infixr"

73− , "module" ]

73+ , "module"

74+ , "let" ]

74

75

75builtInOperators :: [String]

76builtInOperators :: [String]

76builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

77builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

src/Language/PureScript/Parser/Values.hs+25−1

@@ -125,6 +125,28 @@ parseAccessor :: Value -> P.Parsec String ParseState Value

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

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

127

128+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

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

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

131+

132+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

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

134+

135+parseDoNotationReturn :: P.Parsec String ParseState DoNotationElement

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

137+

138+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

139+parseDoNotationElement = P.choice

140+ [ P.try parseDoNotationBind

141+ , parseDoNotationLet

142+ , parseDoNotationReturn

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

144+

145+parseManyDoNotationElements :: P.Parsec String ParseState [DoNotationElement]

146+parseManyDoNotationElements = do

147+ C.indented

148+ C.mark (P.many (C.same *> C.mark parseDoNotationElement))

149+

128parseValue :: P.Parsec String ParseState Value

150parseValue :: P.Parsec String ParseState Value

129parseValue =

151parseValue =

130 (buildExpressionParser operators

152 (buildExpressionParser operators

@@ -136,7 +158,9 @@ parseValue =

136 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

158 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

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

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

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

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

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

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

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

163+ ]

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

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

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

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

142 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)

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

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

@@ -106,6 +106,18 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

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

107 match' _ = Nothing

108

109+_do :: Pattern () Value ([DoNotationElement], Value)

110+_do = mkPattern match

111+ where

112+ match (Do val els) = Just (els, val)

113+ match _ = Nothing

114+

115+prettyPrintDoNotationElement :: DoNotationElement -> String

116+prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

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

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

119+prettyPrintDoNotationElement (DoNotationReturn val) = "return " ++ prettyPrintValue val

120+

109prettyPrintValue :: Value -> String

121prettyPrintValue :: Value -> String

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

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

111 where

123 where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -70,7 +70,14 @@ data Value

70 | Block [Statement]

71 | Constructor (Qualified ProperName)

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

73− | TypedValue Value Type deriving (Show, Data, Typeable)

73+ | TypedValue Value Type

74+ | Do Value [DoNotationElement] deriving (Show, Data, Typeable)

75+

76+data DoNotationElement

77+ = DoNotationValue Value

78+ | DoNotationBind Binder Value

79+ | DoNotationLet Binder Value

80+ | DoNotationReturn Value deriving (Show, Data, Typeable)

74

81

75data Statement

82data Statement

76 = VariableIntroduction Ident Value

83 = VariableIntroduction Ident Value