165a6cb · rowtype-yoga/purescript-native

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

on golang help sign in

Port previous type wildcards implementation

165a6cbPhil Freeman12 years ago

examples/passing/TypeWildcards.pursnew file+10

compare with golang

unifiedsplit

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

1+module Main where

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

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

5+ where

6+ go :: _ -> _ -> _

7+ go a1 a2 | a1 == a2 = a1

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

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

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

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

43parseObject :: P.Parsec String ParseState Type

44parseObject = braces $ TypeApp tyObject <$> parseRow

46+parseTypeWildcard :: P.Parsec String ParseState Type

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

48+

46parseTypeVariable :: P.Parsec String ParseState Type

49parseTypeVariable :: P.Parsec String ParseState Type

47parseTypeVariable = do

50parseTypeVariable = do

48 ident <- identifier

51 ident <- identifier

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

65 , parseArrayOf

68 , parseArrayOf

66 , parseFunction

69 , parseFunction

67 , parseObject

70 , parseObject

71+ , parseTypeWildcard

68 , parseTypeVariable

72 , parseTypeVariable

69 , parseTypeConstructor

73 , parseTypeConstructor

70 , parseForAll

74 , parseForAll

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+4

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