git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix type class issue where instances with missing members were passing the type checker #126
4189e7fPhil Freeman
examples/failing/TypeClassInstances.pursnew file+8
compare with golang
unifiedsplit
@@ -0,0 +1,8 @@
1+module TypeClassInstances where
2+
3+class A a where
4+ a :: a -> String
5+ b :: a -> Number
6+
7+instance A String where
8+ a s = s
src/Language/PureScript/Sugar/TypeClasses.hs+14−7
@@ -73,22 +73,29 @@ typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type c
73
73
74typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
74typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
75typeInstanceDictionaryDeclaration mn deps name ty decls = do
75typeInstanceDictionaryDeclaration mn deps name ty decls = do
76+ m <- get
77+ (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
78+ $ M.lookup (qualify mn name) m
79+ let memberTypes = map (replaceTypeVars arg ty) instanceTys
76 entryName <- lift $ mkDictionaryValueName mn name ty
80 entryName <- lift $ mkDictionaryValueName mn name ty
77− memberNames <- mapM memberToNameAndValue decls
81+ memberNames <- mapM (memberToNameAndValue memberTypes) decls
78 return $ ValueDeclaration entryName [] Nothing
82 return $ ValueDeclaration entryName [] Nothing
79− (TypedValue False
83+ (TypedValue True
80 (Abs
84 (Abs
81 (map (\n -> Ident ('_' : show n)) [1..length deps])
85 (map (\n -> Ident ('_' : show n)) [1..length deps])
82 (ObjectLiteral memberNames))
86 (ObjectLiteral memberNames))
83 (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
87 (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
84 )
88 )
85 where
89 where
86− memberToNameAndValue :: Declaration -> Desugar (String, Value)
90+ memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
87− memberToNameAndValue (ValueDeclaration ident _ _ _) = do
91+ memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do
92+ memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys
88 memberName <- mkDictionaryEntryName mn name ty ident
93 memberName <- mkDictionaryEntryName mn name ty ident
94+ return (identToJs ident, TypedValue False
89− return (identToJs ident, if null deps then Var (Qualified Nothing memberName)
95+ (if null deps then Var (Qualified Nothing memberName)
90− else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
96+ else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
97+ (quantify memberType))
91− memberToNameAndValue _ = error "Invalid declaration in type instance definition"
98+ memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
92
99
93typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
100typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
94typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do
101typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do