d9acad2 · rowtype-yoga/purescript-native

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

on golang help sign in

Generalize types properly in MissingTypeDeclaration warnings

d9acad2Phil Freeman11 years ago

examples/passing/ContextSimplification.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+module Main where

3+import Prelude

5+-- Here, we should simplify the context so that only one Eq

6+-- constraint is added.

7+usesEqTwice x = if x == x then x == x else false

9+main = Control.Monad.Eff.Console.log "Done"

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

@@ -71,16 +71,19 @@ typesOf moduleName vals = do

71 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

72 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

73 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

74− ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict

74+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

75 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

77 forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do

78 -- Replace type class dictionary placeholders with actual dictionaries

79 (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val

80 let unsolvedTypeVars = nub $ unknownsInType ty

81+ -- Generalize and constrain the type

82+ let generalized = generalize unsolved ty

81 -- Make sure any unsolved type constraints only use type variables which appear

83 -- Make sure any unsolved type constraints only use type variables which appear

82 -- unknown in the inferred type.

84 -- unknown in the inferred type.

83− when shouldGeneralize $

85+ when shouldGeneralize $ do

86+ tell . errorMessage $ MissingTypeDeclaration ident generalized

84 forM_ unsolved $ \(_, (className, classTys)) -> do

87 forM_ unsolved $ \(_, (className, classTys)) -> do

85 let constraintTypeVars = nub $ foldMap unknownsInType classTys

88 let constraintTypeVars = nub $ foldMap unknownsInType classTys

86 when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

89 when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

@@ -89,16 +92,17 @@ typesOf moduleName vals = do

89 skolemEscapeCheck val'

92 skolemEscapeCheck val'

90 -- Check rows do not contain duplicate labels

93 -- Check rows do not contain duplicate labels

91 checkDuplicateLabels val'

94 checkDuplicateLabels val'

92− return (ident, (foldr (Abs . Left . fst) val' unsolved, varIfUnknown (constrain unsolved ty)))

95+ return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))

93 where

96 where

97+ -- | Generalize type vars using forall and add inferred constraints

98+ generalize unsolved = varIfUnknown . constrain unsolved

94− -- | Generalize over any unsolved constraints

99+ -- | Add any unsolved constraints

95 constrain [] = id

100 constrain [] = id

96 constrain cs = ConstrainedType (map snd cs)

101 constrain cs = ConstrainedType (map snd cs)

97 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

102 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

98 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

103 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

99 -- Replace all the wildcards types with their inferred types

104 -- Replace all the wildcards types with their inferred types

100 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty

105 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty

101− replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty))

102 replace _ em = em

106 replace _ em = em

103

107

104type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

108type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -151,16 +155,14 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

151

155

152typeForBindingGroupElement ::

156typeForBindingGroupElement ::

153 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

157 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

154− Bool ->

155 (Ident, Expr) ->

158 (Ident, Expr) ->

156 TypeData ->

159 TypeData ->

157 UntypedData ->

160 UntypedData ->

158 m (Ident, (Expr, Type))

161 m (Ident, (Expr, Type))

159−typeForBindingGroupElement warn (ident, val) dict untypedDict = do

162+typeForBindingGroupElement (ident, val) dict untypedDict = do

160 -- Infer the type with the new names in scope

163 -- Infer the type with the new names in scope

161 TypedValue _ val' ty <- bindNames dict $ infer val

164 TypedValue _ val' ty <- bindNames dict $ infer val

162 unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

165 unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

163− when warn . tell . errorMessage $ MissingTypeDeclaration ident ty

164 return (ident, (TypedValue True val' ty, ty))

166 return (ident, (TypedValue True val' ty, ty))

165

167

166-- | Check if a value contains a type annotation

168-- | Check if a value contains a type annotation

@@ -343,7 +345,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

343 Just moduleName <- checkCurrentModule <$> get

345 Just moduleName <- checkCurrentModule <$> get

344 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

346 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

345 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

347 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

346− ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict

348+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

347 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

349 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

348 bindNames dict $ do

350 bindNames dict $ do

349 makeBindingGroupVisible

351 makeBindingGroupVisible