7540821 · rowtype-yoga/purescript-native

examples/failing/BindInDo-2.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+-- @shouldFailWith CannotUseBindWithDo

2+module Main where

3+

4+import Prelude

5+

6+foo = do

7+ let bind = 42

8+ x <- [4, 5, 6]

9+ pure x

examples/failing/BindInDo.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith CannotUseBindWithDo

2+module Main where

3+

4+import Prelude

5+

6+foo = do

7+ bind <- [1,2,3]

8+ x <- [4, 5, 6]

9+ pure x

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

@@ -138,6 +138,7 @@ data SimpleErrorMessage

138 | CannotGeneralizeRecursiveFunction Ident Type

139 | CannotDeriveNewtypeForData (ProperName 'TypeName)

140 | ExpectedWildcard (ProperName 'TypeName)

141+ | CannotUseBindWithDo

141 deriving (Show)

142 deriving (Show)

142

143

143-- | Error message hints, providing more detailed information about failure.

144-- | Error message hints, providing more detailed information about failure.

src/Language/PureScript/Errors.hs+5

@@ -172,6 +172,7 @@ errorCode em = case unwrapErrorMessage em of

172 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

173 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

174 ExpectedWildcard{} -> "ExpectedWildcard"

175+ CannotUseBindWithDo{} -> "CannotUseBindWithDo"

175

176

176-- |

177-- |

177-- A stack trace for an error

178-- A stack trace for an error

@@ -880,6 +881,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

880 paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."

881 paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."

881 ]

882 ]

882

883

884+ renderSimpleErrorMessage CannotUseBindWithDo =

885+ paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

886+ ]

887+

883 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

888 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

884 renderHint (ErrorUnifyingTypes t1 t2) detail =

889 renderHint (ErrorUnifyingTypes t1 t2) detail =

885 paras [ detail

890 paras [ detail

src/Language/PureScript/Sugar/DoNotation.hs+8−1

@@ -9,7 +9,6 @@ import Prelude.Compat

9import Control.Monad.Error.Class (MonadError(..))

10import Control.Monad.Supply.Class

11

12−

13import Language.PureScript.AST

12import Language.PureScript.AST

14import Language.PureScript.Crash

13import Language.PureScript.Crash

15import Language.PureScript.Errors

14import Language.PureScript.Errors

@@ -49,6 +48,8 @@ desugarDo d =

49 return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')

48 return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')

50 go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind

49 go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind

51 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

50 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

51+ go (DoNotationBind b _ : _) | Ident C.bind `elem` binderNames b =

52+ throwError . errorMessage $ CannotUseBindWithDo

52 go (DoNotationBind (VarBinder ident) val : rest) = do

53 go (DoNotationBind (VarBinder ident) val : rest) = do

53 rest' <- go rest

54 rest' <- go rest

54 return $ App (App bind val) (Abs (Left ident) rest')

55 return $ App (App bind val) (Abs (Left ident) rest')

@@ -58,6 +59,12 @@ desugarDo d =

58 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

59 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

59 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

60 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

60 go (DoNotationLet ds : rest) = do

61 go (DoNotationLet ds : rest) = do

62+ let checkBind :: Declaration -> m ()

63+ checkBind (ValueDeclaration (Ident name) _ _ _)

64+ | name == C.bind = throwError . errorMessage $ CannotUseBindWithDo

65+ checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl)

66+ checkBind _ = pure ()

67+ mapM_ checkBind ds

61 rest' <- go rest

68 rest' <- go rest

62 return $ Let ds rest'

69 return $ Let ds rest'

63 go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)

70 go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)