Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[ghc.git] / compiler / typecheck / TcDefaults.lhs
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 \begin{code}
8 {-# OPTIONS -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
13 -- for details
14
15 module TcDefaults ( tcDefaults ) where
16
17 import HsSyn
18 import Name
19 import Class
20 import TcRnMonad
21 import TcEnv
22 import TcHsType
23 import TcSimplify
24 import TcType
25 import PrelNames
26 import DynFlags
27 import SrcLoc
28 import Data.Maybe
29 import Outputable
30 import FastString
31 \end{code}
32
33 \begin{code}
34 tcDefaults :: [LDefaultDecl Name]
35            -> TcM (Maybe [Type])    -- Defaulting types to heave
36                                     -- into Tc monad for later use
37                                     -- in Disambig.
38
39 tcDefaults [] 
40   = getDeclaredDefaultTys       -- No default declaration, so get the
41                                 -- default types from the envt; 
42                                 -- i.e. use the curent ones
43                                 -- (the caller will put them back there)
44         -- It's important not to return defaultDefaultTys here (which
45         -- we used to do) because in a TH program, tcDefaults [] is called
46         -- repeatedly, once for each group of declarations between top-level
47         -- splices.  We don't want to carefully set the default types in
48         -- one group, only for the next group to ignore them and install
49         -- defaultDefaultTys
50
51 tcDefaults [L _ (DefaultDecl [])]
52   = return (Just [])            -- Default declaration specifying no types
53
54 tcDefaults [L locn (DefaultDecl mono_tys)]
55   = setSrcSpan locn                     $
56     addErrCtxt defaultDeclCtxt          $
57     do  { ovl_str <- xoptM Opt_OverloadedStrings
58         ; num_class    <- tcLookupClass numClassName
59         ; is_str_class <- tcLookupClass isStringClassName
60         ; let deflt_clss | ovl_str   = [num_class, is_str_class]
61                          | otherwise = [num_class]
62
63         ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
64     
65         ; return (Just tau_tys) }
66
67 tcDefaults decls@(L locn (DefaultDecl _) : _)
68   = setSrcSpan locn $
69     failWithTc (dupDefaultDeclErr decls)
70
71
72 tc_default_ty :: [Class] -> LHsType Name -> TcM Type
73 tc_default_ty deflt_clss hs_ty 
74  = do   { ty <- tcHsSigType DefaultDeclCtxt hs_ty
75         ; checkTc (isTauTy ty) (polyDefErr hs_ty)
76
77         -- Check that the type is an instance of at least one of the deflt_clss
78         ; oks <- mapM (check_instance ty) deflt_clss
79         ; checkTc (or oks) (badDefaultTy ty deflt_clss)
80         ; return ty }
81
82 check_instance :: Type -> Class -> TcM Bool
83   -- Check that ty is an instance of cls
84   -- We only care about whether it worked or not; return a boolean
85 check_instance ty cls
86   = do  { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
87         ; return (isJust mb_res) }
88     
89 defaultDeclCtxt :: SDoc
90 defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")
91
92 dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
93 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
94   = hang (ptext (sLit "Multiple default declarations"))
95        2 (vcat (map pp dup_things))
96   where
97     pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
98 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
99
100 polyDefErr :: LHsType Name -> SDoc
101 polyDefErr ty 
102   = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty) 
103
104 badDefaultTy :: Type -> [Class] -> SDoc
105 badDefaultTy ty deflt_clss
106   = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
107        2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))
108 \end{code}
109