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 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 TcType
  18 import PrelNames
  19 import DynFlags
  20 import SrcLoc
  21 import Maybe
  22 import Outputable
  23 import FastString
  24 \end{code}
  25
  26 \begin{code}
  27 tcDefaults :: [LDefaultDecl Name]
  28            -> TcM (Maybe [Type])    -- Defaulting types to heave
  29                                     -- into Tc monad for later use
  30                                     -- in Disambig.
  31
  32 tcDefaults []
  33   = getDeclaredDefaultTys       -- No default declaration, so get the
  34                                 -- default types from the envt;
  35                                 -- i.e. use the curent ones
  36                                 -- (the caller will put them back there)
  37         -- It's important not to return defaultDefaultTys here (which
  38         -- we used to do) because in a TH program, tcDefaults [] is called
  39         -- repeatedly, once for each group of declarations between top-level
  40         -- splices.  We don't want to carefully set the default types in
  41         -- one group, only for the next group to ignore them and install
  42         -- defaultDefaultTys
  43
  44 tcDefaults [L _ (DefaultDecl [])]
  45   = return (Just [])            -- Default declaration specifying no types
  46
  47 tcDefaults [L locn (DefaultDecl mono_tys)]
  48   = setSrcSpan locn                     $
  49     addErrCtxt defaultDeclCtxt          $
  50     do  { ovl_str <- doptM Opt_OverloadedStrings
  51         ; num_class    <- tcLookupClass numClassName
  52         ; is_str_class <- tcLookupClass isStringClassName
  53         ; let deflt_clss | ovl_str   = [num_class, is_str_class]
  54                          | otherwise = [num_class]
  55
  56         ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
  57
  58         ; return (Just tau_tys) }
  59
  60 tcDefaults decls@(L locn (DefaultDecl _) : _)
  61   = setSrcSpan locn $
  62     failWithTc (dupDefaultDeclErr decls)
  63
  64
  65 tc_default_ty :: [Class] -> LHsType Name -> TcM Type
  66 tc_default_ty deflt_clss hs_ty
  67  = do   { ty <- tcHsSigType DefaultDeclCtxt hs_ty
  68         ; checkTc (isTauTy ty) (polyDefErr hs_ty)
  69
  70         -- Check that the type is an instance of at least one of the deflt_clss
  71         ; oks <- mapM (check_instance ty) deflt_clss
  72         ; checkTc (or oks) (badDefaultTy ty deflt_clss)
  73         ; return ty }
  74
  75 check_instance :: Type -> Class -> TcM Bool
  76   -- Check that ty is an instance of cls
  77   -- We only care about whether it worked or not; return a boolean
  78 check_instance ty cls
  79   = do  { (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
  80         ; return (isJust mb_res) }
  81
  82 defaultDeclCtxt :: SDoc
  83 defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")
  84
  85 dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
  86 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  87   = hang (ptext (sLit "Multiple default declarations"))
  88       4  (vcat (map pp dup_things))
  89   where
  90     pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
  91 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
  92
  93 polyDefErr :: LHsType Name -> SDoc
  94 polyDefErr ty
  95   = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty)
  96
  97 badDefaultTy :: Type -> [Class] -> SDoc
  98 badDefaultTy ty deflt_clss
  99   = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
 100        2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))
 101 \end{code}
 102