2901b40 · rowtype-yoga/purescript-native

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

Merge pull request #1530 from 5outh/typed-binders

Typed binders

commit2901b4054fa86221c93c5e4b4645ace29ac67d13 authorPhil Freeman <paf31@cantab.net> dateSat 17 Oct 2015, 13:19 (11 years ago) parent91be491 880de6e

14 files changed+125−2

compare with golang

unifiedsplit

examples/failing/TypedBinders.pursnew file+10

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

1+-- @shouldFailWith ErrorParsingModule

2+module Main where

4+import Prelude

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

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

4+import Prelude

6+main = do

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

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

examples/failing/TypedBinders3.pursnew file+12

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

1+-- @shouldFailWith TypesDoNotUnify

2+module Main where

4+import Prelude

6+test = case 1 of

7+ (0 :: String) -> true

8+ _ -> false

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

3+import Prelude

5+data Tuple a b = Tuple a b

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

2121import Language.PureScript.AST.SourcePos

2222import Language.PureScript.Names

2323import Language.PureScript.Comments

24+import Language.PureScript.Types

2425

2526-- |

2627-- Data type for binders

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

6970 -- |

7071 -- A binder with source position information

7172 --

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)

7378

7479-- |

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

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

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

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

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

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

8692 go ns _ = ns

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

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

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

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

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

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

8283 h' other = h other

8384

8485 handleCaseAlternative :: CaseAlternative -> CaseAlternative

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

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

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

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

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

138140 h' other = h other

139141

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

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

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

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

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

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

190193 h' other = h other

191194

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

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

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

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

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

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

245249 h' b = h b

246250

247251 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'

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

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

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

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

313318 h' _ _ = r0

314319

315320 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

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

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

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

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

382388 h' _ other = return other

383389

384390 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)) =

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

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

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

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

170+ binderToCoreFn ss com b

169171

170172 -- |

171173 -- Gets metadata for values.

src/Language/PureScript/Linter.hs+1

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

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

8787 stepB s (VarBinder name) = bindName s name

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

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

8990 stepB s _ = (s, mempty)

9091

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

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

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

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

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

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

164165

165166-- |

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

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

523523-- Parse a binder

524524--

525525parseBinder :: TokenParser Binder

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

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

527527 where

528528 -- TODO: remove this deprecation warning in 0.8

529529 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+ ]

530533 parseBinderAtom :: TokenParser Binder

531534 parseBinderAtom = P.choice (map P.try

532535 [ parseNullBinder

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

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

129129prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

130130

131131prettyPrintBinderAtom :: Binder -> String

132+

132133prettyPrintBinderAtom NullBinder = "_"

133134prettyPrintBinderAtom (StringBinder str) = show str

134135prettyPrintBinderAtom (CharBinder c) = show c

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

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

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

161162prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

163+prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder

162164prettyPrintBinder b = prettyPrintBinderAtom b

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

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

104104 isVarBinder NullBinder = True

105105 isVarBinder (VarBinder _) = True

106106 isVarBinder (PositionedBinder _ _ b) = isVarBinder b

107+ isVarBinder (TypedBinder _ b) = isVarBinder b

107108 isVarBinder _ = False

108109

109110 fromVarBinder :: Binder -> m Ident

110111 fromVarBinder NullBinder = Ident <$> freshName

111112 fromVarBinder (VarBinder name) = return name

112113 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114+ fromVarBinder (TypedBinder _ b) = fromVarBinder b

113115 fromVarBinder _ = error "fromVarBinder: Invalid argument"

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

115117 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) =

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

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

192192 (,) 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')

193197 updateBinder s v =

194198 return (s, v)

195199

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

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

370370 return $ M.insert name val m

371371inferBinder val (PositionedBinder pos _ binder) =

372372 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

373376

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

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