Add kind equalities to GHC.
[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 TcSimplify
17 import TcMType
18 import TcType
19 import PrelNames
20 import DynFlags
21 import SrcLoc
22 import Data.Maybe
23 import Outputable
24 import FastString
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 Opt_OverloadedStrings
50 ; num_class <- tcLookupClass numClassName
51 ; is_str_class <- tcLookupClass isStringClassName
52 ; let deflt_clss | ovl_str = [num_class, is_str_class]
53 | otherwise = [num_class]
54
55 ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
56
57 ; return (Just tau_tys) }
58
59 tcDefaults decls@(L locn (DefaultDecl _) : _)
60 = setSrcSpan locn $
61 failWithTc (dupDefaultDeclErr decls)
62
63
64 tc_default_ty :: [Class] -> LHsType Name -> TcM Type
65 tc_default_ty deflt_clss hs_ty
66 = do { ty <- solveEqualities $
67 tcHsLiftedType hs_ty
68 ; ty <- zonkTcType ty -- establish Type invariants
69 ; checkTc (isTauTy ty) (polyDefErr hs_ty)
70
71 -- Check that the type is an instance of at least one of the deflt_clss
72 ; oks <- mapM (check_instance ty) deflt_clss
73 ; checkTc (or oks) (badDefaultTy ty deflt_clss)
74 ; return ty }
75
76 check_instance :: Type -> Class -> TcM Bool
77 -- Check that ty is an instance of cls
78 -- We only care about whether it worked or not; return a boolean
79 check_instance ty cls
80 = do { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
81 ; return (isJust mb_res) }
82
83 defaultDeclCtxt :: SDoc
84 defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")
85
86 dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
87 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
88 = hang (ptext (sLit "Multiple default declarations"))
89 2 (vcat (map pp dup_things))
90 where
91 pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
92 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
93
94 polyDefErr :: LHsType Name -> SDoc
95 polyDefErr ty
96 = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty)
97
98 badDefaultTy :: Type -> [Class] -> SDoc
99 badDefaultTy ty deflt_clss
100 = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
101 2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))