0b98112 · rowtype-yoga/purescript-native

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

Do notation using type classes

commit0b98112e1eff1cd78ccb44eec8fd3e7df60c1ab4 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 22:15 (13 years ago) parentc9ea112

10 files changed+104−90

compare with golang

unifiedsplit

examples/passing/Do.purs+28−23 examples/passing/Eff.purs+19−10 examples/passing/TypeClasses.purs−7 libraries/jquery/tests/jquery.purs+2−2 libraries/prelude/prelude.purs+18−2 psci/Main.hs+3−5 src/Language/PureScript/Parser/Values.hs+7−10 src/Language/PureScript/Pretty/Values.hs+1−8 src/Language/PureScript/Sugar/DoNotation.hs+24−20 src/Language/PureScript/Values.hs+2−3

examples/passing/Do.purs+28−23

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

1−module Do where

1+module Prelude where

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

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

6−bindMaybe Nothing _ = Nothing

7−bindMaybe (Just a) f = f a

7+module Do where

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

9+import Prelude

10+

11+data Maybe a = Nothing | Just a

1012

11−test1 = maybe do Just "abc"

13+instance Prelude.Monad Maybe where

14+ ret = Just

15+ (>>=) Nothing _ = Nothing

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

1217

13−test2 = maybe do return "xyz"

18+test1 = do Just "abc"

1419

15−test3 = maybe do

20+test3 = do

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

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

18− return x + y

23+ Just (x + y)

1924

20−test4 = maybe do

25+test4 = do

2126 Just 1

2227 Nothing :: Maybe Number

23− return 2

28+ Just 2

2429

25−test5 mx my = maybe do

30+test5 mx my = do

2631 x <- mx

2732 y <- my

28− return x + y

33+ Just (x + y)

2934

30−test6 mx my mz = maybe do

35+test6 mx my mz = do

3136 x <- mx

3237 y <- my

3338 let sum = x + y

3439 z <- mz

35− return z + sum

40+ Just (z + sum)

3641

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

38− return x

42+test7 mx = do let Just x = mx

43+ Just x

3944

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

45+test8 = do Just (do Just 1)

4146

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

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

48+(<$>) f m = do

4449 a <- m

45− return f a

50+ ret (f a)

4651

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

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

53+(<*>) f m = do

4954 g <- f

5055 a <- m

51− return g a

56+ ret (g a)

5257

5358foo x y z = x + y + z

5459

examples/passing/Eff.purs+19−10

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

1+module Prelude where

3+class Monad m where

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

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

17module Eff where

9+import Prelude

10+

311-- Eff Monad

412

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

614

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

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

816

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

1022

1123type Pure a = forall e. Eff e a

1224

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

1426

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

16−

1727-- Errors

1828

1929foreign import data Error :: * -> !

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

4959-- Tests

5060

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

52− (eff do

53− s <- get

54− throwError "Error!"

55− set (s + 1)

56− return s)))

62+ (do s <- get

63+ throwError "Error!"

64+ set (s + 1)

65+ ret s)))

5766

58−test2 = runPure (runST (eff do

67+test2 = runPure (runST (do

5968 ref <- newSTRef 0

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

6170 readSTRef ref))

examples/passing/TypeClasses.purs−7

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

4646 show [] = "[]"

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

4848

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

55import Trace

66import JQuery

8−main = eff do

8+main = do

99 -- Get the document body

1010 b <- body

1111

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

2222 greeting `append` b

2323

2424 -- Listen for change events on the text box

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

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

2626 name <- getValue input

2727 trace $ "Name changed to " ++ name

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

libraries/prelude/prelude.purs+18−2

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

2424

2525 infixr 1000 $

2626

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+

2741module Maybe where

2842

2943 data Maybe a = Nothing | Just a

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

277291

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

279293

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

294+ instance Prelude.Monad (Eff e) where

295+ ret = retEff

296+ (>>=) = bindEff

281297

282298module Errors where

283299

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

311327

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

313329

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) {}

315331

316332module ST where

317333

psci/Main.hs+3−5

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

6060 let

6161 moduleName = P.ProperName "Main"

6262 importDecl m = P.ImportDeclaration m Nothing

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

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

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

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

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

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

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

70− ])

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

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

68+ ])

7169 in

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

7371

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

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

113113 , parseBlock

114114 , parseCase

115115 , parseIfThenElse

116+ , parseDo

116117 , Parens <$> C.parens parseValue ]

117118

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

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

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

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

128129

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+

129136parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

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

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

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

133140parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

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

135142

136−parseDoNotationReturn :: P.Parsec String ParseState DoNotationElement

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

138−

139143parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

140144parseDoNotationElement = P.choice

141145 [ P.try parseDoNotationBind

142146 , parseDoNotationLet

143− , parseDoNotationReturn

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

145148

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

147−parseManyDoNotationElements = do

148− C.indented

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

150−

151149parseValue :: P.Parsec String ParseState Value

152150parseValue =

153151 (buildExpressionParser operators

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

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

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

162160 , \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)

164161 ]

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

166163 , 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

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

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

4242 match (Var ident) = Just $ show ident

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

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

4445 match _ = Nothing

4546

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

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

108109 match' _ = Nothing

109110

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

111−_do = mkPattern match

112− where

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

114− match _ = Nothing

115−

116111prettyPrintDoNotationElement :: DoNotationElement -> String

117112prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

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

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

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

121115

122116prettyPrintValue :: Value -> String

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

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

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

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

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

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

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

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

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

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

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

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

2727desugarDo = everywhereM (mkM replace)

2828 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 ">>="))

2935 replace :: Value -> Either String Value

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

36+ replace (Do els) = go els

3137 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

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

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

40+ go [DoNotationValue val] = return val

41+ go (DoNotationValue val : rest) = do

42+ rest' <- go rest

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

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

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

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

47+ rest' <- go rest

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

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

50+ rest' <- go rest

4751 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 $ App (App bind [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]

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

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

55+ rest' <- go rest

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

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

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

7272 | Constructor (Qualified ProperName)

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

7474 | TypedValue Bool Value Type

75− | Do Value [DoNotationElement]

75+ | Do [DoNotationElement]

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

7777

7878data TypeClassDictionaryInScope

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

8585data DoNotationElement

8686 = DoNotationValue Value

8787 | DoNotationBind Binder Value

88− | DoNotationLet Binder Value

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

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

9089

9190data Statement

9291 = VariableIntroduction Ident Value