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