d824d56 · rowtype-yoga/purescript-native

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

Do notation

commitd824d563436bead3532e24d073d0868a889aa5c1 authorPhil Freeman <paf31@cantab.net> dateTue 7 Jan 2014, 17:06 (13 years ago) parentb10f11b

12 files changed+190−26

compare with golang

unifiedsplit

examples/failing/Do.purs+10 examples/passing/Do.purs+55 examples/passing/Eff.purs+13−10 examples/shelltest/Foreach.js−1 examples/shelltest/runAll.test−7 purescript.cabal+6−4 src/Language/PureScript.hs+6−1 src/Language/PureScript/DoNotation.hs+52 src/Language/PureScript/Parser/Common.hs+2−1 src/Language/PureScript/Parser/Values.hs+25−1 src/Language/PureScript/Pretty/Values.hs+13 src/Language/PureScript/Values.hs+8−1

examples/failing/Do.pursnew file+10

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

1+module Do where

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

5+test1 = id do let x = 1

7+test2 y = id do x <- y

9+test3 = id do return 1

10+ return 2

examples/passing/Do.pursnew file+55

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

1+module Do where

3+data Maybe a = Nothing | Just a

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

6+bindMaybe Nothing _ = Nothing

7+bindMaybe (Just a) f = f a

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

33-- Eff Monad

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

1212

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

1414

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

16+

1517-- Errors

1618

1719foreign import data Error :: * -> !

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

4749-- Tests

4850

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

50− (get >>= \s ->

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

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

53− ret s)))

54−

55−test2 = runPure (runST (

56− newSTRef 0 >>= \ref ->

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

58− readSTRef ref))

52+ (eff do

53+ s <- get

54+ throwError "Error!"

55+ set (s + 1)

56+ return s)))

57+

58+test2 = runPure (runST (eff do

59+ ref <- newSTRef 0

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

61+ readSTRef ref))

5962

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

1414>>>2

1515>>>= 0

1616

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

11name: purescript

2−version: 0.2.5

2+version: 0.2.6

33cabal-version: >=1.8

44build-type: Simple

55license: MIT

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

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

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

1919 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

2321 Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

2422 Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

2523 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

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

3937 Language.PureScript.TypeChecker.Types Language.PureScript.Types

4038 Language.PureScript.Unknown Language.PureScript.Values Main

4139 Language.PureScript.CaseDeclarations

40+ Language.PureScript.DoNotation

41+ Language.PureScript.TypeDeclarations

42+ Language.PureScript.BindingGroups

43+ Language.PureScript.Scope

4244 exposed: True

4345 buildable: True

4446 hs-source-dirs: src

src/Language/PureScript.hs+6−1

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

2828import Language.PureScript.CaseDeclarations as P

2929import Language.PureScript.TypeDeclarations as P

3030import Language.PureScript.BindingGroups as P

31+import Language.PureScript.DoNotation as P

3132

3233import Data.List (intercalate)

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

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

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

3637compile ms = do

3738 bracketted <- rebracket ms

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

39+ desugared <- desugarDo

40+ >=> desugarCasesModule

41+ >=> desugarTypeDeclarationsModule

42+ >=> (return . createBindingGroupsModule)

43+ $ bracketted

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

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

4146 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"

7070 , "Boolean"

7171 , "infixl"

7272 , "infixr"

73− , "module" ]

73+ , "module"

74+ , "let" ]

7475

7576builtInOperators :: [String]

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

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

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

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

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

127127

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+

128150parseValue :: P.Parsec String ParseState Value

129151parseValue =

130152 (buildExpressionParser operators

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

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

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

138160 , \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+ ]

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

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

142166 , 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)

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

107107 match' _ = Nothing

108108

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+

109121prettyPrintValue :: Value -> String

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

111123 where

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

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

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

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

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

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

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

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

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

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

7070 | Block [Statement]

7171 | Constructor (Qualified ProperName)

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

7481

7582data Statement

7683 = VariableIntroduction Ident Value