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