ghc/compiler/typecheck/TcDefaults.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[TcDefaults]{Typechecking \tr{default} declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcDefaults ( tcDefaults ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( HsDecl(..), TyDecl, ClassDecl, InstDecl, HsBinds,
  14                           DefaultDecl(..), HsType, IfaceSig,
  15                           HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
  16 import RnHsSyn          ( RenamedHsDecl(..), RenamedDefaultDecl(..) )
  17 import TcHsSyn          ( TcIdOcc )
  18
  19 import TcMonad
  20 import Inst             ( InstOrigin(..) )
  21 import TcEnv            ( tcLookupClassByKey )
  22 import SpecEnv          ( SpecEnv )
  23 import TcMonoType       ( tcHsType )
  24 import TcSimplify       ( tcSimplifyCheckThetas )
  25
  26 import TysWiredIn       ( intTy, doubleTy, unitTy )
  27 import Type             ( SYN_IE(Type) )
  28 import Unique           ( numClassKey )
  29 import Pretty           ( ptext, vcat )
  30 import ErrUtils         ( addShortErrLocLine )
  31 import Util
  32 \end{code}
  33
  34 \begin{code}
  35 default_default = [intTy, doubleTy]         -- language-specified default `default'
  36
  37 tcDefaults :: [RenamedHsDecl]
  38            -> TcM s [Type]          -- defaulting types to heave
  39                                     -- into Tc monad for later use
  40                                     -- in Disambig.
  41 tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
  42
  43 tc_defaults [] = returnTc default_default
  44
  45 tc_defaults [DefaultDecl mono_tys locn]
  46   = tcAddSrcLoc locn $
  47     mapTc tcHsType mono_tys     `thenTc` \ tau_tys ->
  48
  49     case tau_tys of
  50       [] -> returnTc []         -- no defaults
  51
  52       _  ->
  53             -- Check that all the types are instances of Num
  54             -- We only care about whether it worked or not
  55
  56         tcLookupClassByKey numClassKey                  `thenNF_Tc` \ num ->
  57         tcSimplifyCheckThetas
  58                 [ (num, ty) | ty <- tau_tys ]           `thenTc_`
  59
  60         returnTc tau_tys
  61
  62 tc_defaults decls
  63   = failTc (dupDefaultDeclErr decls)
  64
  65
  66 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
  67   = vcat (item1 : map dup_item dup_things)
  68   where
  69     item1
  70       = addShortErrLocLine locn1 (\ sty ->
  71         ptext SLIT("multiple default declarations")) sty
  72
  73     dup_item (DefaultDecl _ locn)
  74       = addShortErrLocLine locn (\ sty ->
  75         ptext SLIT("here was another default declaration")) sty
  76
  77 \end{code}