2901b40 · rowtype-yoga/purescript-native

examples/failing/TypedBinders.pursnew file+10

compare with golang

unifiedsplit

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

1+-- @shouldFailWith ErrorParsingModule

2+module Main where

3+

4+import Prelude

5+

6+test = (\f :: Int -> Int -> f 10) id

7+

8+main = do

9+ let t1 = test

10+ Control.Monad.Eff.Console.log "Done"

examples/failing/TypedBinders2.pursnew file+9

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

1+-- @shouldFailWith TypesDoNotUnify

2+module Main where

3+

4+import Prelude

5+

6+main = do

7+ s :: String <- Control.Monad.Eff.Console.log "Foo"

8+ Control.Monad.Eff.Console.log "Done"

9+

examples/failing/TypedBinders3.pursnew file+12

@@ -0,0 +1,12 @@

1+-- @shouldFailWith TypesDoNotUnify

2+module Main where

3+

4+import Prelude

5+

6+test = case 1 of

7+ (0 :: String) -> true

8+ _ -> false

9+

10+main = do

11+ let t = test

12+ Control.Monad.Eff.Console.log "Done"

examples/passing/TypedBinders.pursnew file+62

@@ -0,0 +1,62 @@

1+module Main where

2+

3+import Prelude

4+

5+data Tuple a b = Tuple a b

6+

7+class MonadState s m where

8+ get :: m s

9+ put :: s -> m {}

10+

11+data State s a = State (s -> Tuple s a)

12+

13+runState s (State f) = f s

14+

15+instance functorState :: Functor (State s) where

16+ map = liftM1

17+

18+instance applyState :: Apply (State s) where

19+ apply = ap

20+

21+instance applicativeState :: Applicative (State s) where

22+ pure a = State $ \s -> Tuple s a

23+

24+instance bindState :: Bind (State s) where

25+ bind f g = State $ \s -> case runState s f of

26+ Tuple s1 a -> runState s1 (g a)

27+

28+instance monadState :: Monad (State s)

29+

30+instance monadStateState :: MonadState s (State s) where

31+ get = State (\s -> Tuple s s)

32+ put s = State (\_ -> Tuple s {})

33+

34+modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}

35+modify f = do

36+ s <- get

37+ put (f s)

38+

39+test :: Tuple String String

40+test = runState "" $ do

41+ modify $ (++) "World!"

42+ modify $ (++) "Hello, "

43+ str :: String <- get

44+ return str

45+

46+test2 :: (Int -> Int) -> Int

47+test2 = (\(f :: Int -> Int) -> f 10)

48+

49+test3 :: Int -> Boolean

50+test3 n = case n of

51+ (0 :: Int) -> true

52+ _ -> false

53+

54+test4 :: Tuple Int Int -> Tuple Int Int

55+test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a)

56+

57+main = do

58+ let t1 = test

59+ t2 = test2 id

60+ t3 = test3 1

61+ t4 = test4 (Tuple 1 0)

62+ Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/AST/Binders.hs+7−1

@@ -21,6 +21,7 @@ import qualified Data.Data as D

21import Language.PureScript.AST.SourcePos

22import Language.PureScript.Names

23import Language.PureScript.Comments

24+import Language.PureScript.Types

24

25

25-- |

26-- |

26-- Data type for binders

27-- Data type for binders

@@ -69,7 +70,11 @@ data Binder

69 -- |

70 -- |

70 -- A binder with source position information

71 -- A binder with source position information

71 --

72 --

72− | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Read, Eq, D.Data, D.Typeable)

73+ | PositionedBinder SourceSpan [Comment] Binder

74+ -- |

75+ -- A binder with a type annotation

76+ --

77+ | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)

73

78

74-- |

79-- |

75-- Collect all names introduced in binders in an expression

80-- Collect all names introduced in binders in an expression

@@ -83,4 +88,5 @@ binderNames = go []

83 go ns (ArrayBinder bs) = foldl go ns bs

88 go ns (ArrayBinder bs) = foldl go ns bs

84 go ns (NamedBinder name b) = go (name : ns) b

89 go ns (NamedBinder name b) = go (name : ns) b

85 go ns (PositionedBinder _ _ b) = go ns b

90 go ns (PositionedBinder _ _ b) = go ns b

91+ go ns (TypedBinder _ b) = go ns b

86 go ns _ = ns

92 go ns _ = ns

src/Language/PureScript/AST/Traversals.hs+6

@@ -79,6 +79,7 @@ everywhereOnValues f g h = (f', g', h')

79 h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

80 h' (NamedBinder name b) = h (NamedBinder name (h' b))

81 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

82+ h' (TypedBinder t b) = h (TypedBinder t (h' b))

82 h' other = h other

83 h' other = h other

83

84

84 handleCaseAlternative :: CaseAlternative -> CaseAlternative

85 handleCaseAlternative :: CaseAlternative -> CaseAlternative

@@ -135,6 +136,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

135 h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs

136 h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs

136 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

137 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

137 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

138 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

139+ h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

138 h' other = h other

140 h' other = h other

139

141

140 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs

142 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs

@@ -187,6 +189,7 @@ everywhereOnValuesM f g h = (f', g', h')

187 h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h

189 h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h

188 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

190 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

189 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

191 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

192+ h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

190 h' other = h other

193 h' other = h other

191

194

192 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs

195 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs

@@ -242,6 +245,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

242 h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

245 h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

243 h' b@(NamedBinder _ b1) = h b <> h' b1

246 h' b@(NamedBinder _ b1) = h b <> h' b1

244 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

247 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

248+ h' b@(TypedBinder _ b1) = h b <> h' b1

245 h' b = h b

249 h' b = h b

246

250

247 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

251 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

@@ -310,6 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

310 h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

314 h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

311 h' s (NamedBinder _ b1) = h'' s b1

315 h' s (NamedBinder _ b1) = h'' s b1

312 h' s (PositionedBinder _ _ b1) = h'' s b1

316 h' s (PositionedBinder _ _ b1) = h'' s b1

317+ h' s (TypedBinder _ b1) = h'' s b1

313 h' _ _ = r0

318 h' _ _ = r0

314

319

315 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

320 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

@@ -379,6 +384,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

379 h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs

384 h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs

380 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

385 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

381 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

386 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

387+ h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

382 h' _ other = return other

388 h' _ other = return other

383

389

384 i'' s = uncurry i' <=< i s

390 i'' s = uncurry i' <=< i s

src/Language/PureScript/CoreFn/Desugar.hs+2

@@ -166,6 +166,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

166 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

167 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

168 binderToCoreFn (Just ss) (com ++ com1) b

169+ binderToCoreFn ss com (A.TypedBinder _ b) =

170+ binderToCoreFn ss com b

169

171

170 -- |

172 -- |

171 -- Gets metadata for values.

173 -- Gets metadata for values.

src/Language/PureScript/Linter.hs+1

@@ -86,6 +86,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

86 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)

87 stepB s (VarBinder name) = bindName s name

88 stepB s (NamedBinder name _) = bindName s name

89+ stepB s (TypedBinder _ b) = stepB s b

89 stepB s _ = (s, mempty)

90 stepB s _ = (s, mempty)

90

91

91 bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

92 bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

src/Language/PureScript/Linter/Exhaustive.hs+1

@@ -160,6 +160,7 @@ missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

160 | bl == br = ([], return True)

161 | otherwise = ([BooleanBinder bl], return False)

162missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

163+missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

163missingCasesSingle _ _ b _ = ([b], Left Unknown)

164missingCasesSingle _ _ b _ = ([b], Left Unknown)

164

165

165-- |

166-- |

src/Language/PureScript/Parser/Declarations.hs+4−1

@@ -523,10 +523,13 @@ parseIdentifierAndBinder = do

523-- Parse a binder

524--

525parseBinder :: TokenParser Binder

526−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom)

526+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))

527 where

528 -- TODO: remove this deprecation warning in 0.8

529 operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]

530+ -- TODO: parsePolyType when adding support for polymorphic types

531+ postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType)

532+ ]

530 parseBinderAtom :: TokenParser Binder

533 parseBinderAtom :: TokenParser Binder

531 parseBinderAtom = P.choice (map P.try

534 parseBinderAtom = P.choice (map P.try

532 [ parseNullBinder

535 [ parseNullBinder

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

@@ -129,6 +129,7 @@ prettyPrintDoNotationElement (DoNotationLet ds) =

129prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

130

131prettyPrintBinderAtom :: Binder -> String

132+

132prettyPrintBinderAtom NullBinder = "_"

133prettyPrintBinderAtom NullBinder = "_"

133prettyPrintBinderAtom (StringBinder str) = show str

134prettyPrintBinderAtom (StringBinder str) = show str

134prettyPrintBinderAtom (CharBinder c) = show c

135prettyPrintBinderAtom (CharBinder c) = show c

@@ -159,4 +160,5 @@ prettyPrintBinder :: Binder -> String

159prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

160prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

160prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)

161prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)

161prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

162prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

163+prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder

162prettyPrintBinder b = prettyPrintBinderAtom b

164prettyPrintBinder b = prettyPrintBinderAtom b

src/Language/PureScript/Sugar/CaseDeclarations.hs+2

@@ -104,12 +104,14 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

104 isVarBinder NullBinder = True

105 isVarBinder (VarBinder _) = True

106 isVarBinder (PositionedBinder _ _ b) = isVarBinder b

107+ isVarBinder (TypedBinder _ b) = isVarBinder b

107 isVarBinder _ = False

108 isVarBinder _ = False

108

109

109 fromVarBinder :: Binder -> m Ident

110 fromVarBinder :: Binder -> m Ident

110 fromVarBinder NullBinder = Ident <$> freshName

111 fromVarBinder NullBinder = Ident <$> freshName

111 fromVarBinder (VarBinder name) = return name

112 fromVarBinder (VarBinder name) = return name

112 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

113 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114+ fromVarBinder (TypedBinder _ b) = fromVarBinder b

113 fromVarBinder _ = error "fromVarBinder: Invalid argument"

115 fromVarBinder _ = error "fromVarBinder: Invalid argument"

114toDecls ds@(ValueDeclaration ident _ bs result : _) = do

116toDecls ds@(ValueDeclaration ident _ bs result : _) = do

115 let tuples = map toTuple ds

117 let tuples = map toTuple ds

src/Language/PureScript/Sugar/Names.hs+4

@@ -190,6 +190,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

190 return ((Just pos, bound), v)

191 updateBinder s@(pos, _) (ConstructorBinder name b) =

192 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

193+ updateBinder s (TypedBinder t b) = do

194+ (s'@ (span', _), b') <- updateBinder s b

195+ t' <- updateTypesEverywhere span' t

196+ return (s', TypedBinder t' b')

193 updateBinder s v =

197 updateBinder s v =

194 return (s, v)

198 return (s, v)

195

199

src/Language/PureScript/TypeChecker/Types.hs+3

@@ -370,6 +370,9 @@ inferBinder val (NamedBinder name binder) = do

370 return $ M.insert name val m

371inferBinder val (PositionedBinder pos _ binder) =

372 warnAndRethrowWithPosition pos $ inferBinder val binder

373+-- TODO: When adding support for polymorphic types, check subsumption here

374+-- and change the definition of `binderRequiresMonotype`

375+inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder

373

376

374-- | Returns true if a binder requires its argument type to be a monotype.

377-- | Returns true if a binder requires its argument type to be a monotype.

375-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

378-- | If this is the case, we need to instantiate any polymorphic types before checking binders.