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 #include "HsVersions.h"
  11
  12 import HsSyn
  13 import Name
  14 import Class
  15 import TcRnMonad
  16 import TcEnv
  17 import TcHsType
  18 import TcSimplify
  19 import TcType
  20 import PrelNames
  21 import DynFlags
  22 import SrcLoc
  23 import Maybe
  24 import Outputable
  25 \end{code}
  26
  27 \begin{code}
  28 tcDefaults :: [LDefaultDecl Name]
  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 curent 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 locn (DefaultDecl [])]
  46   = returnM (Just [])           -- Default declaration specifying no types
  47
  48 tcDefaults [L locn (DefaultDecl mono_tys)]
  49   = setSrcSpan locn                     $
  50     addErrCtxt defaultDeclCtxt          $
  51     do  { ovl_str <- doptM Opt_OverloadedStrings
  52         ; num_class    <- tcLookupClass numClassName
  53         ; is_str_class <- tcLookupClass isStringClassName
  54         ; let deflt_clss | ovl_str   = [num_class, is_str_class]
  55                          | otherwise = [num_class]
  56
  57         ; tau_tys <- mappM (tc_default_ty deflt_clss) mono_tys
  58
  59         ; return (Just tau_tys) }
  60
  61 tcDefaults decls@(L locn (DefaultDecl _) : _)
  62   = setSrcSpan locn $
  63     failWithTc (dupDefaultDeclErr decls)
  64
  65
  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 = ptext SLIT("When checking the types in a default declaration")
  83
  84 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  85   = hang (ptext SLIT("Multiple default declarations"))
  86       4  (vcat (map pp dup_things))
  87   where
  88     pp (L locn (DefaultDecl _)) = ptext SLIT("here was another default declaration") <+> ppr locn
  89
  90 polyDefErr ty
  91   = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty)
  92
  93 badDefaultTy ty deflt_clss
  94   = hang (ptext SLIT("The default type") <+> quotes (ppr ty) <+> ptext SLIT("is not an instance of"))
  95        2 (foldr1 (\a b -> a <+> ptext SLIT("or") <+> b) (map (quotes. ppr) deflt_clss))
  96 \end{code}
  97