ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcTyDecls]{Typecheck type declarations}
   5
   6 \begin{code}
   7 module TcTyDecls ( tcTyDecl, kcConDetails ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType,
  12                           getBangType, getBangStrictness, conDetailsTys
  13                         )
  14 import RnHsSyn          ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
  15 import BasicTypes       ( NewOrData(..) )
  16
  17 import TcMonoType       ( tcHsTyVars, tcHsTheta, tcHsType,
  18                           kcHsContext, kcHsSigType, kcHsLiftedSigType
  19                         )
  20 import TcEnv            ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) )
  21 import TcType           ( tyVarsOfTypes, tyVarsOfPred, ThetaType )
  22 import RnEnv            ( lookupSysName )
  23 import TcRnMonad
  24
  25 import DataCon          ( DataCon, mkDataCon, dataConFieldLabels )
  26 import FieldLabel       ( fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
  27 import MkId             ( mkDataConId, mkDataConWrapId, mkRecordSelId )
  28 import Var              ( TyVar )
  29 import Name             ( Name )
  30 import OccName          ( mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
  31 import Outputable
  32 import TyCon            ( TyCon, DataConDetails(..), visibleDataCons,
  33                           tyConTyVars, tyConName )
  34 import VarSet           ( intersectVarSet, isEmptyVarSet )
  35 import Generics         ( mkTyConGenInfo )
  36 import CmdLineOpts      ( DynFlag(..) )
  37 import List             ( nubBy )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection{Type checking}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 \begin{code}
  47 tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
  48 tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
  49   = tcLookupTyCon tycon_name                    `thenM` \ tycon ->
  50     tcExtendTyVarEnv (tyConTyVars tycon)        $
  51     tcHsType rhs                                `thenM` \ rhs_ty ->
  52     returnM (tycon_name, SynTyDetails rhs_ty)
  53
  54 tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context,
  55                   tcdName = tycon_name, tcdCons = con_decls,
  56                   tcdGeneric = generic})
  57   = tcLookupTyCon tycon_name                    `thenM` \ tycon ->
  58     let
  59         tyvars = tyConTyVars tycon
  60     in
  61     tcExtendTyVarEnv tyvars                             $
  62     tcHsTheta context                                   `thenM` \ ctxt ->
  63     tcConDecls new_or_data tycon tyvars ctxt con_decls  `thenM` \ data_cons ->
  64     let
  65         sel_ids = mkRecordSelectors tycon data_cons
  66     in
  67     tcGenericInfo tycon generic                         `thenM` \ gen_info ->
  68     returnM (tycon_name, DataTyDetails ctxt data_cons sel_ids gen_info)
  69
  70 tcTyDecl (ForeignType {tcdName = tycon_name})
  71   = returnM (tycon_name, ForeignTyDetails)
  72
  73
  74 tcGenericInfo tycon generics    -- Source code decl: consult the flag
  75   = do_we_want  generics        `thenM` \ want_generics ->
  76     if want_generics then
  77         mapM (lookupSysName (tyConName tycon))
  78              [mkGenOcc1, mkGenOcc2]             `thenM` \ gen_sys_names ->
  79         returnM (mkTyConGenInfo tycon gen_sys_names)
  80     else
  81         returnM Nothing
  82   where
  83     do_we_want (Just g) = returnM g             -- Interface file decl
  84                                                 -- so look at decl
  85     do_we_want Nothing  = doptM Opt_Generics    -- Source code decl
  86                                                 -- so look at flag
  87
  88 mkRecordSelectors tycon data_cons
  89   =     -- We'll check later that fields with the same name
  90         -- from different constructors have the same type.
  91      [ mkRecordSelId tycon field
  92      | field <- nubBy eq_name fields ]
  93   where
  94     fields = [ field | con <- visibleDataCons data_cons,
  95                        field <- dataConFieldLabels con ]
  96     eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
  97 \end{code}
  98
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{Kind and type check constructors}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 \begin{code}
 107 kcConDetails :: NewOrData -> RenamedContext
 108              -> HsConDetails Name (BangType Name) -> TcM ()
 109 kcConDetails new_or_data ex_ctxt details
 110   = kcHsContext ex_ctxt         `thenM_`
 111     mappM_ kc_sig_type (conDetailsTys details)
 112   where
 113     kc_sig_type = case new_or_data of
 114                     DataType -> kcHsSigType
 115                     NewType  -> kcHsLiftedSigType
 116             -- Can't allow an unlifted type here, because we're effectively
 117             -- going to remove the constructor while coercing it to a lifted type.
 118
 119
 120 tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType
 121            -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon)
 122
 123 tcConDecls new_or_data tycon tyvars ctxt con_decls
 124   = case con_decls of
 125         Unknown     -> returnM Unknown
 126         HasCons n   -> returnM (HasCons n)
 127         DataCons cs -> mappM tc_con_decl cs     `thenM` \ data_cons ->
 128                        returnM (DataCons data_cons)
 129   where
 130     tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc)
 131       = addSrcLoc src_loc                                               $
 132         tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)    $ \ ex_tyvars ->
 133         tcHsTheta ex_ctxt                                               `thenM` \ ex_theta ->
 134         case details of
 135             PrefixCon btys     -> tc_datacon ex_tyvars ex_theta btys
 136             InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
 137             RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
 138       where
 139
 140         tc_datacon ex_tyvars ex_theta btys
 141           = mappM tcHsType (map getBangType btys)       `thenM` \ arg_tys ->
 142             mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
 143
 144         tc_rec_con ex_tyvars ex_theta fields
 145           = checkTc (null ex_tyvars) (exRecConErr name) `thenM_`
 146             mappM tc_field (fields `zip` allFieldLabelTags)     `thenM` \ field_labels ->
 147             let
 148                 arg_stricts = [str | (n, bty) <- fields,
 149                                      let str = getBangStrictness bty
 150                               ]
 151             in
 152             mk_data_con ex_tyvars ex_theta arg_stricts
 153                         (map fieldLabelType field_labels) field_labels
 154
 155         tc_field ((field_label_name, bty), tag)
 156           = tcHsType (getBangType bty)          `thenM` \ field_ty ->
 157             returnM (mkFieldLabel field_label_name tycon field_ty tag)
 158
 159         mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
 160           = lookupSysName name mkWorkerOcc      `thenM` \ wkr_name ->
 161             let
 162                data_con = mkDataCon name arg_stricts fields
 163                                tyvars (thinContext arg_tys ctxt)
 164                                ex_tyvars ex_theta
 165                                arg_tys
 166                                tycon data_con_id data_con_wrap_id
 167
 168                data_con_id      = mkDataConId wkr_name data_con
 169                data_con_wrap_id = mkDataConWrapId data_con
 170             in
 171             returnM data_con
 172
 173 -- The context for a data constructor should be limited to
 174 -- the type variables mentioned in the arg_tys
 175 thinContext arg_tys ctxt
 176   = filter in_arg_tys ctxt
 177   where
 178       arg_tyvars = tyVarsOfTypes arg_tys
 179       in_arg_tys pred = not $ isEmptyVarSet $
 180                         tyVarsOfPred pred `intersectVarSet` arg_tyvars
 181 \end{code}
 182
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection{Errors and contexts}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190
 191 \begin{code}
 192 exRecConErr name
 193   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 194     $$
 195     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 196 \end{code}