ghc/compiler/typecheck/TcDefaults.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[TcDefaults]{Typechecking \tr{default} declarations}
   5
   6 \begin{code}
   7 module TcDefaults ( tcDefaults ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( DefaultDecl(..) )
  12 import Name             ( Name )
  13 import TcRnMonad
  14 import TcEnv            ( tcLookupClass )
  15 import TcHsType         ( tcHsSigType, UserTypeCtxt( DefaultDeclCtxt ) )
  16 import TcSimplify       ( tcSimplifyDefault )
  17 import TcType           ( Type, mkClassPred, isTauTy )
  18 import PrelNames        ( numClassName )
  19 import Outputable
  20 \end{code}
  21
  22 \begin{code}
  23 tcDefaults :: [DefaultDecl Name]
  24            -> TcM (Maybe [Type])    -- Defaulting types to heave
  25                                     -- into Tc monad for later use
  26                                     -- in Disambig.
  27
  28 tcDefaults []
  29   = getDefaultTys               -- No default declaration, so get the
  30                                 -- default types from the envt;
  31                                 -- i.e. use the curent ones
  32                                 -- (the caller will put them back there)
  33         -- It's important not to return defaultDefaultTys here (which
  34         -- we used to do) because in a TH program, tcDefaults [] is called
  35         -- repeatedly, once for each group of declarations between top-level
  36         -- splices.  We don't want to carefully set the default types in
  37         -- one group, only for the next group to ignore them and install
  38         -- defaultDefaultTys
  39
  40 tcDefaults [DefaultDecl [] locn]
  41   = returnM (Just [])           -- Default declaration specifying no types
  42
  43 tcDefaults [DefaultDecl mono_tys locn]
  44   = addSrcLoc locn                      $
  45     addErrCtxt defaultDeclCtxt          $
  46     tcLookupClass numClassName          `thenM` \ num_class ->
  47     mappM tc_default_ty mono_tys        `thenM` \ tau_tys ->
  48
  49         -- Check that all the types are instances of Num
  50         -- We only care about whether it worked or not
  51     tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys]      `thenM_`
  52
  53     returnM (Just tau_tys)
  54
  55 tcDefaults decls@(DefaultDecl _ loc : _) =
  56     addSrcLoc loc $
  57     failWithTc (dupDefaultDeclErr decls)
  58
  59
  60 tc_default_ty hs_ty
  61  = tcHsSigType DefaultDeclCtxt hs_ty            `thenM` \ ty ->
  62    checkTc (isTauTy ty) (polyDefErr hs_ty)      `thenM_`
  63    returnM ty
  64
  65 defaultDeclCtxt =  ptext SLIT("when checking that each type in a default declaration")
  66                     $$ ptext SLIT("is an instance of class Num")
  67
  68
  69 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things)
  70   = hang (ptext SLIT("Multiple default declarations"))
  71       4  (vcat (map pp dup_things))
  72   where
  73     pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
  74
  75 polyDefErr ty
  76   = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty)
  77 \end{code}
  78