165a6cb · rowtype-yoga/purescript-native

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

Port previous type wildcards implementation

commit165a6cb9b4577520613d0d1ac3d4a4fab3fcba64 authorPhil Freeman <paf31@cantab.net> dateSun 16 Nov 2014, 18:00 (12 years ago) parentc61ad82

7 files changed+45−11

compare with golang

unifiedsplit

examples/passing/TypeWildcards.purs+10 src/Language/PureScript/Parser/Types.hs+4 src/Language/PureScript/Pretty/Types.hs+1 src/Language/PureScript/TypeChecker/Kinds.hs+1 src/Language/PureScript/TypeChecker/Types.hs+13−11 src/Language/PureScript/TypeChecker/Unify.hs+12 src/Language/PureScript/Types.hs+4

examples/passing/TypeWildcards.pursnew file+10

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

4343parseObject :: P.Parsec String ParseState Type

4444parseObject = braces $ TypeApp tyObject <$> parseRow

4545

46+parseTypeWildcard :: P.Parsec String ParseState Type

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

48+

4649parseTypeVariable :: P.Parsec String ParseState Type

4750parseTypeVariable = do

4851 ident <- identifier

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

6568 , parseArrayOf

6669 , parseFunction

6770 , parseObject

71+ , parseTypeWildcard

6872 , parseTypeVariable

6973 , parseTypeConstructor

7074 , parseForAll

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

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

3434typeLiterals :: Pattern () Type String

3535typeLiterals = mkPattern match

3636 where

37+ match TypeWildcard = Just "_"

3738 match (TypeVar var) = Just var

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

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

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

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

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

150150

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

152+infer' TypeWildcard = fresh

152153infer' (TypeVar v) = do

153154 Just moduleName <- checkCurrentModule <$> get

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

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

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

129129

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

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

132+ -- Replace type wildcards

133+ ty' <- replaceTypeWildcards ty

132134 -- Kind check

133135 kind <- liftCheck $ kindOf moduleName ty

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

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

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

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

137139 val'' <- if checkType

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

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

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

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

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

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

141143

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

143145typeForBindingGroupElement (ident, val) dict untypedDict = do

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

259261infer' (Var var) = do

260262 Just moduleName <- checkCurrentModule <$> get

261263 checkVisibility moduleName var

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

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

263265 case ty of

264266 ConstrainedType constraints ty' -> do

265267 dicts <- getTypeClassDictionaries

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

291293infer' (TypedValue checkType val ty) = do

292294 Just moduleName <- checkCurrentModule <$> get

293295 checkTypeKind moduleName ty

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

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

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

296298 return $ TypedValue True val' ty'

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

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

303305 Just moduleName <- checkCurrentModule <$> get

304306 checkTypeKind moduleName ty

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

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

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

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

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

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

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

483485 Just moduleName <- checkCurrentModule <$> get

484486 checkVisibility moduleName var

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

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

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

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

488490 case v' of

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

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

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

505507 Just moduleName <- checkCurrentModule <$> get

506508 checkTypeKind moduleName ty1

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

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

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

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

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

510512 case val' of

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

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

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

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

557559check' val ty | containsTypeSynonyms ty = do

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

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

559561 check val ty'

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

561563 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 (

2121 unifyRows,

2222 unifiesWith,

2323 replaceVarWithUnknown,

24+ replaceTypeWildcards,

2425 varIfUnknown

2526) where

2627

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

157158replaceVarWithUnknown ident ty = do

158159 tu <- fresh

159160 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

160172

161173-- |

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

src/Language/PureScript/Types.hs+4

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

4747 --

4848 | TypeVar String

4949 -- |

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

51+ --

52+ | TypeWildcard

53+ -- |

5054 -- A type constructor

5155 --

5256 | TypeConstructor (Qualified ProperName)