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 module TcDefaults ( tcDefaults ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), DefaultDecl(..) )
  12 import RnHsSyn          ( RenamedHsDecl(..), RenamedDefaultDecl(..) )
  13
  14 import TcMonad
  15 import Inst             ( InstOrigin(..) )
  16 import TcEnv            ( TcIdOcc, tcLookupClassByKey )
  17 import TcMonoType       ( tcHsType )
  18 import TcSimplify       ( tcSimplifyCheckThetas )
  19
  20 import TysWiredIn       ( intTy, doubleTy, unitTy )
  21 import Type             ( Type )
  22 import Unique           ( numClassKey )
  23 import ErrUtils         ( addShortErrLocLine )
  24 import Outputable
  25 import Util
  26 \end{code}
  27
  28 \begin{code}
  29 default_default = [intTy, doubleTy]         -- language-specified default `default'
  30
  31 tcDefaults :: [RenamedHsDecl]
  32            -> TcM s [Type]          -- defaulting types to heave
  33                                     -- into Tc monad for later use
  34                                     -- in Disambig.
  35 tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
  36
  37 tc_defaults [] = returnTc default_default
  38
  39 tc_defaults [DefaultDecl mono_tys locn]
  40   = tcAddSrcLoc locn $
  41     mapTc tcHsType mono_tys     `thenTc` \ tau_tys ->
  42
  43     case tau_tys of
  44       [] -> returnTc []         -- no defaults
  45
  46       _  ->
  47             -- Check that all the types are instances of Num
  48             -- We only care about whether it worked or not
  49
  50         tcAddErrCtxt defaultDeclCtxt            $
  51         tcLookupClassByKey numClassKey          `thenNF_Tc` \ num ->
  52         tcSimplifyCheckThetas
  53                 [{- Nothing given -}]
  54                 [ (num, [ty]) | ty <- tau_tys ] `thenTc_`
  55
  56         returnTc tau_tys
  57
  58 tc_defaults decls
  59   = failWithTc (dupDefaultDeclErr decls)
  60
  61
  62 defaultDeclCtxt =  ptext SLIT("when checking that each type in a default declaration")
  63                     $$ ptext SLIT("is an instance of class Num")
  64
  65
  66 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things)
  67   = vcat (item1 : map dup_item dup_things)
  68   where
  69     item1
  70       = addShortErrLocLine locn1 (ptext SLIT("multiple default declarations"))
  71
  72     dup_item (DefaultDecl _ locn)
  73       = addShortErrLocLine locn (ptext SLIT("here was another default declaration"))
  74 \end{code}