git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #2579 from purescript/phil/2578

Defer warnings from typeDictionaryForBindingGroup call

commitd2c4b07e91c01552df6fecb67691759e57a7ffad authorGary Burgess <gary.burgess@gmail.com> dateTue 17 Jan 2017, 11:39 (10 years ago) parentb70aabf619d651
1 file changed+10−7
src/Language/PureScript/TypeChecker/Types.hs+10−7
src/Language/PureScript/TypeChecker/Types.hs+10−7
@@ -77,11 +77,11 @@ typesOf
7777 -> [(Ident, Expr)]
7878 -> m [(Ident, (Expr, Type))]
7979typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
80− tys <- capturingSubstitution tidyUp $ do
81− SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals
80+ (tys, wInfer) <- capturingSubstitution tidyUp $ do
81+ (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals
8282 ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
8383 ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict
84− return (map (False, ) ds1 ++ map (True, ) ds2)
84+ return (map (False, ) ds1 ++ map (True, ) ds2, w)
8585
8686 inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
8787 -- Replace type class dictionary placeholders with actual dictionaries
@@ -123,10 +123,13 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
123123 -- Show warnings here, since types in wildcards might have been solved during
124124 -- instance resolution (by functional dependencies).
125125 finalState <- get
126+ let replaceTypes' = replaceTypes (checkSubstitution finalState)
127+ runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState
128+ raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w
129+
130+ raisePreviousWarnings False wInfer
126131 forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
127− let replaceTypes' = replaceTypes (checkSubstitution finalState)
128− runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState
129− (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w
132+ raisePreviousWarnings shouldGeneralize w
130133
131134 return (map fst inferred)
132135 where
@@ -160,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
160163 constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)
161164
162165 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
163− tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts
166+ tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts
164167
165168 isHoleError :: ErrorMessage -> Bool
166169 isHoleError (ErrorMessage _ HoleInferredType{}) = True