ghc/compiler/typecheck/TcMonoType.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMonoType ( tcMonoType, tcInstanceType ) where
  10
  11 IMPORT_Trace            -- ToDo: rm (debugging)
  12 import Outputable
  13 import Pretty
  14
  15 import TcMonad          -- typechecking monad machinery
  16 import AbsSyn           -- the stuff being typechecked
  17
  18 #ifndef DPH
  19 import AbsPrel          ( mkListTy, mkTupleTy, mkFunTy )
  20 #else
  21 import AbsPrel          ( mkListTy, mkTupleTy, mkFunTy, mkProcessorTy, mkPodTy )
  22 #endif {- Data Parallel Haskell -}
  23 import AbsUniType       ( applySynTyCon, applyNonSynTyCon, mkDictTy,
  24                           getTyConArity, isSynTyCon, isTyVarTemplateTy,
  25                           getUniDataTyCon_maybe, maybeUnpackFunTy
  26                           IF_ATTACK_PRAGMAS(COMMA pprTyCon COMMA pprUniType)
  27                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  28                         )
  29 import UniType          ( UniType(..) ) -- ******** CHEATING **** could be undone
  30 import TyCon            --( TyCon(..) ) -- ditto, only more so
  31
  32 import CE               ( lookupCE, CE(..) )
  33 import CmdLineOpts      ( GlobalSwitch(..) )
  34 import Errors           ( confusedNameErr, tyConArityErr, instTypeErr,
  35                           Error(..)
  36                         )
  37 import Maybes           ( Maybe(..) )
  38 import TcPolyType       ( tcPolyType )
  39 import TCE              ( lookupTCE, TCE(..), UniqFM )
  40 import TVE              ( lookupTVE, TVE(..) )
  41 import Util
  42 \end{code}
  43
  44 \begin{code}
  45 tcMonoType :: CE -> TCE -> TVE -> RenamedMonoType -> Baby_TcM UniType
  46
  47 tcMonoType rec_ce rec_tce tve (MonoTyVar name)
  48   = returnB_Tc (lookupTVE tve name)
  49
  50 tcMonoType rec_ce rec_tce tve (ListMonoTy ty)
  51   = tcMonoType  rec_ce rec_tce tve ty   `thenB_Tc` \ tau_ty ->
  52     returnB_Tc (mkListTy tau_ty)
  53
  54 tcMonoType rec_ce rec_tce tve (TupleMonoTy tys)
  55   = mapB_Tc (tcPolyType rec_ce rec_tce tve) tys `thenB_Tc` \ tau_tys ->
  56     returnB_Tc (mkTupleTy (length tau_tys) tau_tys)
  57
  58 tcMonoType rec_ce rec_tce tve (FunMonoTy ty1 ty2)
  59   = tcMonoType rec_ce rec_tce tve ty1   `thenB_Tc` \ tau_ty1 ->
  60     tcMonoType rec_ce rec_tce tve ty2   `thenB_Tc` \ tau_ty2 ->
  61     returnB_Tc (mkFunTy tau_ty1 tau_ty2)
  62
  63 tcMonoType rec_ce rec_tce tve (MonoTyCon name@(WiredInTyCon tycon) tys)
  64   = let
  65         arity        = getTyConArity tycon
  66         is_syn_tycon = isSynTyCon tycon
  67     in
  68     tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
  69
  70 tcMonoType rec_ce rec_tce tve (MonoTyCon name@(PreludeTyCon _ _ arity is_data_tycon) tys)
  71   = tcMonoType_help rec_ce rec_tce tve name
  72                     (lookupTCE rec_tce name)
  73                     arity (not is_data_tycon) tys
  74
  75
  76 tcMonoType rec_ce rec_tce tve (MonoTyCon name@(OtherTyCon _ _ arity is_data_tycon _) tys)
  77   = tcMonoType_help rec_ce rec_tce tve name
  78                     (lookupTCE rec_tce name)
  79                     arity (not is_data_tycon) tys
  80
  81 tcMonoType rec_ce rec_tce tve (MonoTyCon bad_name tys)
  82   = getSrcLocB_Tc               `thenB_Tc` \ locn ->
  83     failB_Tc (confusedNameErr
  84                 "Bad name for a type constructor (a class, or a Prelude name?)"
  85                 bad_name locn)
  86
  87 -- two for unfoldings only:
  88 tcMonoType rec_ce rec_tce tve (MonoDict c ty)
  89   = tcMonoType rec_ce rec_tce tve ty    `thenB_Tc` \ new_ty ->
  90     let
  91         clas = lookupCE rec_ce c
  92     in
  93     returnB_Tc (mkDictTy clas new_ty)
  94
  95 tcMonoType rec_ce rec_tce tve (MonoTyVarTemplate tv_tmpl)
  96   = returnB_Tc (lookupTVE tve tv_tmpl)
  97
  98 #ifdef DPH
  99 tcMonoType ce tce tve (MonoTyProc tys ty)
 100   = tcMonoTypes ce tce tve tys  `thenB_Tc` \ tau_tys ->
 101     tcMonoType  ce tce tve ty   `thenB_Tc` \ tau_ty  ->
 102     returnB_Tc (mkProcessorTy tau_tys tau_ty)
 103
 104 tcMonoType ce tce tve (MonoTyPod ty)
 105   = tcMonoType ce tce tve ty    `thenB_Tc` \ tau_ty  ->
 106     returnB_Tc (mkPodTy tau_ty)
 107 #endif {- Data Parallel Haskell -}
 108
 109 #ifdef DEBUG
 110 tcMonoType rec_ce rec_tce tve bad_ty
 111   = pprPanic "tcMonoType:" (ppr PprShowAll bad_ty)
 112 #endif
 113 \end{code}
 114
 115 \begin{code}
 116 tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
 117   = tcMonoTypes rec_ce rec_tce tve tys  `thenB_Tc`    \ tau_tys ->
 118     let  cur_arity = length tys  in
 119     getSrcLocB_Tc                       `thenB_Tc` \ loc ->
 120
 121     checkB_Tc (arity /= cur_arity)
 122            (tyConArityErr name arity cur_arity loc) `thenB_Tc_`
 123
 124     returnB_Tc (if is_syn_tycon then
 125                  applySynTyCon  tycon tau_tys
 126               else
 127                  applyNonSynTyCon tycon tau_tys)
 128
 129 -- also not exported
 130 tcMonoTypes rec_ce rec_tce tve monotypes
 131    = mapB_Tc (tcMonoType rec_ce rec_tce tve) monotypes
 132 \end{code}
 133
 134 @tcInstanceType@ checks the type {\em and} its syntactic constraints:
 135 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 136 (We're checking the @Tycon a b c ...@ part here...)
 137
 138 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 139 flag is on, or (2)~the instance is imported (they must have been
 140 compiled elsewhere).  In these cases, we let them go through anyway.
 141
 142 We can also have instances for functions: @instance Foo (a -> b) ...@.
 143
 144 \begin{code}
 145 tcInstanceType :: CE -> TCE -> TVE
 146                -> Bool{-True <=> from this module-} -> SrcLoc
 147                -> RenamedMonoType
 148                -> Baby_TcM UniType
 149
 150 tcInstanceType ce tce tve from_here locn mono_ty
 151   = tcMonoType ce tce tve mono_ty       `thenB_Tc` \ tau_ty  ->
 152     let
 153         (naughty, unkosher) = bad_shape tau_ty
 154     in
 155     getSwitchCheckerB_Tc                `thenB_Tc` \ sw_chkr ->
 156     checkB_Tc
 157         (if not from_here || sw_chkr GlasgowExts then -- no "shape" checking
 158             naughty
 159          else
 160             naughty || unkosher
 161         )
 162         (instTypeErr tau_ty locn)       `thenB_Tc_`
 163     returnB_Tc tau_ty
 164   where
 165     -- "naughty" if the type is really unacceptable, no
 166     -- matter what (e.g., a type synonym); "unkosher" if
 167     -- the Haskell report forbids it, but we allow it through
 168     -- under -fglasgow-exts.
 169
 170     bad_shape ty
 171       = if (is_syn_type ty) then
 172            (True, bottom)
 173         else case (getUniDataTyCon_maybe ty) of
 174           Just (_,tys,_) -> (False, not (all isTyVarTemplateTy tys))
 175           Nothing        -> case maybeUnpackFunTy ty of
 176                               Just (t1, t2) -> (False,
 177                                                 not (all isTyVarTemplateTy [t1, t2]))
 178                               Nothing       -> (True, bottom)
 179       where
 180         bottom = panic "bad_shape"
 181
 182         is_syn_type ty -- ToDo: move to AbsUniType (or friend)?
 183           = case ty of
 184               UniSyn _ _ _ -> True
 185               _ -> False
 186 \end{code}