0574eeb · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #714 from purescript/287

0574eebPhil Freeman12 years ago

examples/failing/TypeWildcards1.pursnew file+4

compare with golang

unifiedsplit

@@ -0,0 +1,4 @@

1+module TypeWildcards where

3+type Test = _

examples/failing/TypeWildcards2.pursnew file+4

@@ -0,0 +1,4 @@

1+module TypeWildcards where

3+data Test = Test _

examples/failing/TypeWildcards3.pursnew file+7

@@ -0,0 +1,7 @@

1+module TypeWildcards where

3+data Foo a = Foo

5+instance showFoo :: Show (Foo _) where

6+ show Foo = "Foo"

examples/passing/TypeWildcards.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+testTopLevel :: _ -> _

4+testTopLevel n = n + 1

6+test :: forall a. (Eq a) => (a -> a) -> a -> a

7+test f a = go (f a) a

8+ where

9+ go :: _ -> _ -> _

10+ go a1 a2 | a1 == a2 = a1

11+ go a1 _ = go (f a1) a1

12+

13+main = Debug.Trace.trace "Done"

src/Language/PureScript/Parser/Declarations.hs+8−8

@@ -64,7 +64,7 @@ parseDataDeclaration = do

64 tyArgs <- many (indented *> kindedIdent)

65 ctors <- P.option [] $ do

66 _ <- lexeme $ indented *> P.char '='

67− sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe

67+ sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

68 return $ DataDeclaration dtype name tyArgs ctors

70parseTypeDeclaration :: P.Parsec String ParseState Declaration

@@ -76,7 +76,7 @@ parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

76parseTypeSynonymDeclaration =

77 TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

78 <*> many (indented *> kindedIdent)

79− <*> (lexeme (indented *> P.char '=') *> parsePolyType)

79+ <*> (lexeme (indented *> P.char '=') *> noWildcards parsePolyType)

81parseValueDeclaration :: P.Parsec String ParseState Declaration

82parseValueDeclaration = do

@@ -106,16 +106,16 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp

106 <|> (do reserved "instance"

107 name <- parseIdent <* lexeme (indented *> P.string "::")

108 deps <- P.option [] $ do

109− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

109+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

110 indented

111 reservedOp "=>"

112 return deps

113 className <- indented *> parseQualified properName

114− tys <- P.many (indented *> parseTypeAtom)

114+ tys <- P.many (indented *> noWildcards parseTypeAtom)

115 return $ ExternInstanceDeclaration name deps className tys)

116 <|> (do ident <- parseIdent

117 js <- P.optionMaybe (JSRaw <$> stringLiteral)

118− ty <- lexeme (indented *> P.string "::") *> parsePolyType

118+ ty <- lexeme (indented *> P.string "::") *> noWildcards parsePolyType

119 return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))

120

121parseAssociativity :: P.Parsec String ParseState Associativity

@@ -176,7 +176,7 @@ parseTypeClassDeclaration = do

176 reserved "class"

177 implies <- P.option [] $ do

178 indented

179− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

179+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

180 reservedOp "<="

181 return implies

182 className <- indented *> properName

@@ -191,12 +191,12 @@ parseTypeInstanceDeclaration = do

191 reserved "instance"

192 name <- parseIdent <* lexeme (indented *> P.string "::")

193 deps <- P.optionMaybe $ do

194− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

194+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

195 indented

196 reservedOp "=>"

197 return deps

198 className <- indented *> parseQualified properName

199− ty <- P.many (indented *> parseTypeAtom)

199+ ty <- P.many (indented *> (noWildcards parseTypeAtom))

200 members <- P.option [] . P.try $ do

201 indented *> reserved "where"

202 mark (P.many (same *> positioned parseValueDeclaration))

src/Language/PureScript/Parser/Types.hs+14

@@ -16,6 +16,7 @@

16module Language.PureScript.Parser.Types (

17 parseType,

18 parsePolyType,

19+ noWildcards,

19 parseTypeAtom

20 parseTypeAtom

20) where

21) where

@@ -43,6 +44,9 @@ parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction

43parseObject :: P.Parsec String ParseState Type

44parseObject :: P.Parsec String ParseState Type

44parseObject = braces $ TypeApp tyObject <$> parseRow

45parseObject = braces $ TypeApp tyObject <$> parseRow

47+parseTypeWildcard :: P.Parsec String ParseState Type

48+parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard

49+

46parseTypeVariable :: P.Parsec String ParseState Type

50parseTypeVariable :: P.Parsec String ParseState Type

47parseTypeVariable = do

51parseTypeVariable = do

48 ident <- identifier

52 ident <- identifier

@@ -65,6 +69,7 @@ parseTypeAtom = indented *> P.choice (map P.try

65 , parseArrayOf

69 , parseArrayOf

66 , parseFunction

70 , parseFunction

67 , parseObject

71 , parseObject

72+ , parseTypeWildcard

68 , parseTypeVariable

73 , parseTypeVariable

69 , parseTypeConstructor

74 , parseTypeConstructor

70 , parseForAll

75 , parseForAll

@@ -108,6 +113,15 @@ parseType = do

108parsePolyType :: P.Parsec String ParseState Type

113parsePolyType :: P.Parsec String ParseState Type

109parsePolyType = parseAnyType

114parsePolyType = parseAnyType

110

115

116+-- |

117+-- Parse an atomic type with no wildcards

118+--

119+noWildcards :: P.Parsec String ParseState Type -> P.Parsec String ParseState Type

120+noWildcards p = do

121+ ty <- p

122+ when (containsWildcards ty) $ P.unexpected "type wildcard"

123+ return ty

124+

111parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

125parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

112parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p

126parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p

113

127

src/Language/PureScript/Pretty/Types.hs+1

@@ -34,6 +34,7 @@ import Language.PureScript.Environment

34typeLiterals :: Pattern () Type String

35typeLiterals = mkPattern match

36 where

37+ match TypeWildcard = Just "_"

37 match (TypeVar var) = Just var

38 match (TypeVar var) = Just var

38 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

39 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

39 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

40 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

src/Language/PureScript/TypeChecker/Kinds.hs+1

@@ -149,6 +149,7 @@ infer :: Type -> UnifyT Kind Check Kind

149infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

150

151infer' :: Type -> UnifyT Kind Check Kind

152+infer' TypeWildcard = fresh

152infer' (TypeVar v) = do

153infer' (TypeVar v) = do

153 Just moduleName <- checkCurrentModule <$> get

154 Just moduleName <- checkCurrentModule <$> get

154 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

155 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

src/Language/PureScript/TypeChecker/Types.hs+13−11

@@ -129,15 +129,17 @@ typeDictionaryForBindingGroup moduleName vals = do

129

130checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))

131checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do

132+ -- Replace type wildcards

133+ ty' <- replaceTypeWildcards ty

132 -- Kind check

134 -- Kind check

133 kind <- liftCheck $ kindOf moduleName ty

135 kind <- liftCheck $ kindOf moduleName ty

134 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

136 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

135 -- Check the type with the new names in scope

137 -- Check the type with the new names in scope

136− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

138+ ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'

137 val'' <- if checkType

139 val'' <- if checkType

138− then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'

140+ then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''

139− else return (TypedValue False val' ty')

141+ else return (TypedValue False val' ty'')

140− return (ident, (val'', ty'))

142+ return (ident, (val'', ty''))

141

143

142typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))

144typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))

143typeForBindingGroupElement (ident, val) dict untypedDict = do

145typeForBindingGroupElement (ident, val) dict untypedDict = do

@@ -259,7 +261,7 @@ infer' (App f arg) = do

259infer' (Var var) = do

261infer' (Var var) = do

260 Just moduleName <- checkCurrentModule <$> get

262 Just moduleName <- checkCurrentModule <$> get

261 checkVisibility moduleName var

263 checkVisibility moduleName var

262− ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

264+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var

263 case ty of

265 case ty of

264 ConstrainedType constraints ty' -> do

266 ConstrainedType constraints ty' -> do

265 dicts <- getTypeClassDictionaries

267 dicts <- getTypeClassDictionaries

@@ -291,7 +293,7 @@ infer' (SuperClassDictionary className tys) = do

291infer' (TypedValue checkType val ty) = do

293infer' (TypedValue checkType val ty) = do

292 Just moduleName <- checkCurrentModule <$> get

294 Just moduleName <- checkCurrentModule <$> get

293 checkTypeKind moduleName ty

295 checkTypeKind moduleName ty

294− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

296+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

295 val' <- if checkType then check val ty' else return val

297 val' <- if checkType then check val ty' else return val

296 return $ TypedValue True val' ty'

298 return $ TypedValue True val' ty'

297infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

299infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

@@ -303,7 +305,7 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue

303 Just moduleName <- checkCurrentModule <$> get

305 Just moduleName <- checkCurrentModule <$> get

304 checkTypeKind moduleName ty

306 checkTypeKind moduleName ty

305 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

307 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

306− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

308+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

307 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

309 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

308 bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

310 bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

309inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

311inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

@@ -483,7 +485,7 @@ check' v@(Var var) ty = do

483 Just moduleName <- checkCurrentModule <$> get

485 Just moduleName <- checkCurrentModule <$> get

484 checkVisibility moduleName var

486 checkVisibility moduleName var

485 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

487 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

486− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

488+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

487 v' <- subsumes (Just v) repl ty'

489 v' <- subsumes (Just v) repl ty'

488 case v' of

490 case v' of

489 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

491 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

@@ -504,8 +506,8 @@ check' (SuperClassDictionary className tys) _ = do

504check' (TypedValue checkType val ty1) ty2 = do

506check' (TypedValue checkType val ty1) ty2 = do

505 Just moduleName <- checkCurrentModule <$> get

507 Just moduleName <- checkCurrentModule <$> get

506 checkTypeKind moduleName ty1

508 checkTypeKind moduleName ty1

507− ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

509+ ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

508− ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty2

510+ ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

509 val' <- subsumes (Just val) ty1' ty2'

511 val' <- subsumes (Just val) ty1' ty2'

510 case val' of

512 case val' of

511 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

513 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

@@ -555,7 +557,7 @@ check' (Let ds val) ty = do

555 (ds', val') <- inferLetBinding [] ds val (`check` ty)

557 (ds', val') <- inferLetBinding [] ds val (`check` ty)

556 return $ TypedValue True (Let ds' val') ty

558 return $ TypedValue True (Let ds' val') ty

557check' val ty | containsTypeSynonyms ty = do

559check' val ty | containsTypeSynonyms ty = do

558− ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

560+ ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty

559 check val ty'

561 check val ty'

560check' val kt@(KindedType ty kind) = do

562check' val kt@(KindedType ty kind) = do

561 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

563 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

src/Language/PureScript/TypeChecker/Unify.hs+12

@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Unify (

21 unifyRows,

22 unifiesWith,

23 replaceVarWithUnknown,

24+ replaceTypeWildcards,

24 varIfUnknown

25 varIfUnknown

25) where

26) where

@@ -157,6 +158,17 @@ replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type

157replaceVarWithUnknown ident ty = do

158replaceVarWithUnknown ident ty = do

158 tu <- fresh

159 tu <- fresh

159 return $ replaceTypeVars ident tu ty

160 return $ replaceTypeVars ident tu ty

161+

162+-- |

163+-- Replace type wildcards with unknowns

164+--

165+replaceTypeWildcards :: Type -> UnifyT t Check Type

166+replaceTypeWildcards = everywhereOnTypesM replace

167+ where

168+ replace TypeWildcard = do

169+ u <- fresh'

170+ return $ TUnknown u

171+ replace other = return other

160

172

161-- |

173-- |

162-- Replace outermost unsolved unification variables with named type variables

174-- Replace outermost unsolved unification variables with named type variables

src/Language/PureScript/Types.hs+14

@@ -47,6 +47,10 @@ data Type

47 --

48 | TypeVar String

49 -- |

50+ -- A type wildcard, as would appear in a partial type synonym

51+ --

52+ | TypeWildcard

53+ -- |

50 -- A type constructor

54 -- A type constructor

51 --

55 --

52 | TypeConstructor (Qualified ProperName)

56 | TypeConstructor (Qualified ProperName)

@@ -215,6 +219,16 @@ moveQuantifiersToFront = go [] []

215 [] -> constrained

219 [] -> constrained

216 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'

220 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'

217

221

222+-- |

223+-- Check if a type contains wildcards

224+--

225+containsWildcards :: Type -> Bool

226+containsWildcards = everythingOnTypes (||) go

227+ where

228+ go :: Type -> Bool

229+ go TypeWildcard = True

230+ go _ = False

231+

218--

232--

219-- Traversals

233-- Traversals

220--

234--