Fix #11974 by adding a more smarts to TcDefaults.
[ghc.git] / compiler / typecheck / TcDefaults.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1993-1998
4
5 \section[TcDefaults]{Typechecking \tr{default} declarations}
6 -}
7
8 module TcDefaults ( tcDefaults ) where
9
10 import HsSyn
11 import Name
12 import Class
13 import TcRnMonad
14 import TcEnv
15 import TcHsType
16 import TcHsSyn
17 import TcSimplify
18 import TcValidity
19 import TcType
20 import PrelNames
21 import SrcLoc
22 import Outputable
23 import FastString
24 import qualified GHC.LanguageExtensions as LangExt
25
26 tcDefaults :: [LDefaultDecl Name]
27 -> TcM (Maybe [Type]) -- Defaulting types to heave
28 -- into Tc monad for later use
29 -- in Disambig.
30
31 tcDefaults []
32 = getDeclaredDefaultTys -- No default declaration, so get the
33 -- default types from the envt;
34 -- i.e. use the current ones
35 -- (the caller will put them back there)
36 -- It's important not to return defaultDefaultTys here (which
37 -- we used to do) because in a TH program, tcDefaults [] is called
38 -- repeatedly, once for each group of declarations between top-level
39 -- splices. We don't want to carefully set the default types in
40 -- one group, only for the next group to ignore them and install
41 -- defaultDefaultTys
42
43 tcDefaults [L _ (DefaultDecl [])]
44 = return (Just []) -- Default declaration specifying no types
45
46 tcDefaults [L locn (DefaultDecl mono_tys)]
47 = setSrcSpan locn $
48 addErrCtxt defaultDeclCtxt $
49 do { ovl_str <- xoptM LangExt.OverloadedStrings
50 ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
51 ; num_class <- tcLookupClass numClassName
52 ; deflt_str <- if ovl_str
53 then mapM tcLookupClass [isStringClassName]
54 else return []
55 ; deflt_interactive <- if ext_deflt
56 then mapM tcLookupClass interactiveClassNames
57 else return []
58 ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
59
60 ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
61
62 ; return (Just tau_tys) }
63
64 tcDefaults decls@(L locn (DefaultDecl _) : _)
65 = setSrcSpan locn $
66 failWithTc (dupDefaultDeclErr decls)
67
68
69 tc_default_ty :: [Class] -> LHsType Name -> TcM Type
70 tc_default_ty deflt_clss hs_ty
71 = do { (ty, _kind) <- solveEqualities $
72 tcLHsType hs_ty
73 ; ty <- zonkTcTypeToType emptyZonkEnv ty -- establish Type invariants
74 ; checkValidType DefaultDeclCtxt ty
75
76 -- Check that the type is an instance of at least one of the deflt_clss
77 ; oks <- mapM (check_instance ty) deflt_clss
78 ; checkTc (or oks) (badDefaultTy ty deflt_clss)
79 ; return ty }
80
81 check_instance :: Type -> Class -> TcM Bool
82 -- Check that ty is an instance of cls
83 -- We only care about whether it worked or not; return a boolean
84 check_instance ty cls
85 = do { (_, success) <- discardErrs $
86 askNoErrs $
87 simplifyDefault [mkClassPred cls [ty]]
88 ; return success }
89
90 defaultDeclCtxt :: SDoc
91 defaultDeclCtxt = text "When checking the types in a default declaration"
92
93 dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
94 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
95 = hang (text "Multiple default declarations")
96 2 (vcat (map pp dup_things))
97 where
98 pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn
99 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
100
101 badDefaultTy :: Type -> [Class] -> SDoc
102 badDefaultTy ty deflt_clss
103 = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
104 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))