ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[TcTyDecls]{Typecheck type declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcTyDecls (
  10         tcTyDecl,
  11         tcConDecl,
  12         mkDataBinds
  13     ) where
  14
  15 IMP_Ubiq(){-uitous-}
  16
  17 import HsSyn            ( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..),
  18                           Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
  19                           HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo,
  20                           SYN_IE(RecFlag), nonRecursive, andMonoBinds,
  21                           HsType, Fake, InPat, HsTyVar, Fixity,
  22                           MonoBinds(..), Sig
  23                         )
  24 import HsTypes          ( getTyVarName )
  25 import RnHsSyn          ( RenamedTyDecl(..), RenamedConDecl(..) )
  26 import TcHsSyn          ( mkHsTyLam, mkHsDictLam, tcIdType,
  27                           SYN_IE(TcHsBinds), TcIdOcc(..), SYN_IE(TcMonoBinds)
  28                         )
  29 import Inst             ( newDicts, InstOrigin(..), Inst )
  30 import TcMonoType       ( tcHsTypeKind, tcHsType, tcContext )
  31 import TcSimplify       ( tcSimplifyThetas )
  32 import TcType           ( tcInstTyVars, tcInstType, tcInstId )
  33 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  34                           newLocalId, newLocalIds, tcLookupClassByKey
  35                         )
  36 import TcMonad
  37 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  38
  39 import PprType          ( GenClass, GenType{-instance Outputable-},
  40                           GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
  41                         )
  42 import CoreUnfold       ( getUnfoldingTemplate )
  43 import Class            ( GenClass{-instance Eq-}, classInstEnv, SYN_IE(Class) )
  44 import Id               ( mkDataCon, dataConSig, mkRecordSelId, idType,
  45                           dataConFieldLabels, dataConStrictMarks,
  46                           StrictnessMark(..), getIdUnfolding,
  47                           GenId{-instance NamedThing-},
  48                           SYN_IE(Id)
  49                         )
  50 import FieldLabel
  51 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  52 import SpecEnv          ( SpecEnv, nullSpecEnv )
  53 import Name             ( nameSrcLoc, isLocallyDefined, getSrcLoc,
  54                           OccName(..), Name{-instance Ord3-},
  55                           NamedThing(..)
  56                         )
  57 import Outputable       ( Outputable(..), interpp'SP )
  58 import Pretty
  59 import TyCon            ( TyCon, NewOrData, mkSynTyCon, mkDataTyCon, isAlgTyCon,
  60                           isSynTyCon, tyConDataCons
  61                         )
  62 import Type             ( GenType, -- instances
  63                           typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy,
  64                           applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
  65                           splitFunTy, mkTyVarTy, getTyVar_maybe,
  66                           SYN_IE(Type)
  67                         )
  68 import TyVar            ( tyVarKind, elementOfTyVarSet,
  69                           GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
  70 import Unique           ( Unique {- instance Eq -}, evalClassKey )
  71 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
  72 import Util             ( equivClasses, zipEqual, nOfThem, panic, assertPanic, Ord3(..) )
  73 \end{code}
  74
  75 \begin{code}
  76 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  77 \end{code}
  78
  79 Type synonym decls
  80 ~~~~~~~~~~~~~~~~~~
  81
  82 \begin{code}
  83 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  84   = tcAddSrcLoc src_loc $
  85     tcAddErrCtxt (tySynCtxt tycon_name) $
  86
  87         -- Look up the pieces
  88     tcLookupTyCon tycon_name                    `thenTc` \ (tycon_kind,  _, rec_tycon) ->
  89     mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
  90                                                 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  91
  92         -- Look at the rhs
  93     tcHsTypeKind rhs                            `thenTc` \ (rhs_kind, rhs_ty) ->
  94
  95         -- Unify tycon kind with (k1->...->kn->rhs)
  96     unifyKind tycon_kind
  97         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  98                                                 `thenTc_`
  99     let
 100         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
 101         -- because that's a TcKind and may not yet be fully unified with other kinds.
 102         -- We could have augmented the tycon environment with a knot-tied kind,
 103         -- but the simplest thing to do seems to be to get the Kind by (lazily)
 104         -- looking at the tyvars and rhs_ty.
 105         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
 106         result_kind      = typeKind rhs_ty
 107         final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
 108
 109         -- Construct the tycon
 110         tycon = mkSynTyCon (getName tycon_name)
 111                            final_tycon_kind
 112                            (length tyvar_names)
 113                            rec_tyvars
 114                            rhs_ty
 115     in
 116     returnTc tycon
 117 \end{code}
 118
 119 Algebraic data and newtype decls
 120 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 121
 122 \begin{code}
 123 tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 124   = tcAddSrcLoc src_loc $
 125     tcAddErrCtxt (tyDataCtxt tycon_name) $
 126
 127         -- Lookup the pieces
 128     tcLookupTyCon tycon_name                    `thenTc` \ (tycon_kind, _, rec_tycon) ->
 129     mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
 130                                  tyvar_names    `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 131     tc_derivs derivings                         `thenTc` \ derived_classes ->
 132
 133         -- Typecheck the context
 134     tcContext context                           `thenTc` \ ctxt ->
 135
 136         -- Unify tycon kind with (k1->...->kn->Type)
 137     unifyKind tycon_kind
 138         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 139                                                 `thenTc_`
 140
 141         -- Walk the condecls
 142     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 143                                                 `thenTc` \ con_ids ->
 144     let
 145         -- Construct the tycon
 146         final_tycon_kind :: Kind                -- NB not TcKind!
 147         final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 148
 149         tycon = mkDataTyCon (getName tycon_name)
 150                             final_tycon_kind
 151                             rec_tyvars
 152                             ctxt
 153                             con_ids
 154                             derived_classes
 155                             data_or_new
 156     in
 157     returnTc tycon
 158
 159 tc_derivs Nothing   = returnTc []
 160 tc_derivs (Just ds) = mapTc tc_deriv ds
 161
 162 tc_deriv name
 163   = tcLookupClass name `thenTc` \ (_, clas) ->
 164     returnTc clas
 165 \end{code}
 166
 167 Generating constructor/selector bindings for data declarations
 168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 169
 170 \begin{code}
 171 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
 172 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
 173 mkDataBinds (tycon : tycons)
 174   | isSynTyCon tycon = mkDataBinds tycons
 175   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 176                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 177                        returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 178
 179 mkDataBinds_one tycon
 180   = ASSERT( isAlgTyCon tycon )
 181     mapTc checkConstructorContext data_cons     `thenTc_`
 182     mapTc (mkRecordSelector tycon) groups       `thenTc` \ sel_ids ->
 183     let
 184         data_ids = data_cons ++ sel_ids
 185
 186         -- For the locally-defined things
 187         -- we need to turn the unfoldings inside the Ids into bindings,
 188         binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
 189                 | data_id <- data_ids, isLocallyDefined data_id
 190                 ]
 191     in
 192     returnTc (data_ids, andMonoBinds binds)
 193   where
 194     data_cons = tyConDataCons tycon
 195     fields = [ (con, field) | con   <- data_cons,
 196                               field <- dataConFieldLabels con
 197              ]
 198
 199         -- groups is list of fields that share a common name
 200     groups = equivClasses cmp_name fields
 201     cmp_name (_, field1) (_, field2)
 202         = fieldLabelName field1 `cmp` fieldLabelName field2
 203 \end{code}
 204
 205 -- Check that all the types of all the strict arguments are in Eval
 206
 207 \begin{code}
 208 checkConstructorContext con_id
 209   | not (isLocallyDefined con_id)
 210   = returnTc ()
 211
 212   | otherwise   -- It is locally defined
 213   = tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 214     let
 215         strict_marks         = dataConStrictMarks con_id
 216         (tyvars,theta,tau)   = splitSigmaTy (idType con_id)
 217         (arg_tys, result_ty) = splitFunTy tau
 218
 219         eval_theta = [ (eval_clas,arg_ty)
 220                      | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 221                                                         arg_tys strict_marks
 222                      ]
 223     in
 224     tcSimplifyThetas classInstEnv theta eval_theta      `thenTc` \ eval_theta' ->
 225     checkTc (null eval_theta')
 226             (missingEvalErr con_id eval_theta')
 227 \end{code}
 228
 229 \begin{code}
 230 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 231                 -- These fields all have the same name, but are from
 232                 -- different constructors in the data type
 233         -- Check that all the fields in the group have the same type
 234         -- This check assumes that all the constructors of a given
 235         -- data type use the same type variables
 236   = checkTc (all (eqTy field_ty) other_tys)
 237             (fieldTypeMisMatch field_name)      `thenTc_`
 238     returnTc selector_id
 239   where
 240     field_ty   = fieldLabelType first_field_label
 241     field_name = fieldLabelName first_field_label
 242     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 243     (tyvars, _, _, _, _, _) = dataConSig first_con
 244     data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 245     -- tyvars of first_con may be free in field_ty
 246     -- Now build the selector
 247
 248     selector_ty :: Type
 249     selector_ty  = mkForAllTys tyvars $
 250                    mkFunTy data_ty $
 251                    field_ty
 252
 253     selector_id :: Id
 254     selector_id = mkRecordSelId first_field_label selector_ty
 255 \end{code}
 256
 257 Constructors
 258 ~~~~~~~~~~~~
 259 \begin{code}
 260 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 261
 262 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
 263   = tcDataCon tycon tyvars ctxt name btys src_loc
 264
 265 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
 266   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 267
 268 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
 269   = tcAddSrcLoc src_loc $
 270     tcHsType ty `thenTc` \ arg_ty ->
 271     let
 272       data_con = mkDataCon (getName name)
 273                            [NotMarkedStrict]
 274                            [{- No labelled fields -}]
 275                            tyvars
 276                            ctxt
 277                            [] []        -- Temporary
 278                            [arg_ty]
 279                            tycon
 280     in
 281     returnTc data_con
 282
 283 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
 284   = tcAddSrcLoc src_loc $
 285     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 286     let
 287       field_label_infos = concat field_label_infos_s
 288       stricts           = [strict | (_, _, strict) <- field_label_infos]
 289       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 290
 291       field_labels      = [ mkFieldLabel (getName name) ty tag
 292                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 293
 294       data_con = mkDataCon (getName name)
 295                            stricts
 296                            field_labels
 297                            tyvars
 298                            (thinContext arg_tys ctxt)
 299                            [] []        -- Temporary
 300                            arg_tys
 301                            tycon
 302     in
 303     returnTc data_con
 304
 305 tcField (field_label_names, bty)
 306   = tcHsType (get_pty bty)      `thenTc` \ field_ty ->
 307     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 308
 309 tcDataCon tycon tyvars ctxt name btys src_loc
 310   = tcAddSrcLoc src_loc $
 311     let
 312         stricts = map get_strictness btys
 313         tys     = map get_pty btys
 314     in
 315     mapTc tcHsType tys `thenTc` \ arg_tys ->
 316     let
 317       data_con = mkDataCon (getName name)
 318                            stricts
 319                            [{- No field labels -}]
 320                            tyvars
 321                            (thinContext arg_tys ctxt)
 322                            [] []        -- Temporary
 323                            arg_tys
 324                            tycon
 325     in
 326     returnTc data_con
 327
 328 -- The context for a data constructor should be limited to
 329 -- the type variables mentioned in the arg_tys
 330 thinContext arg_tys ctxt
 331   = filter in_arg_tys ctxt
 332   where
 333       arg_tyvars = tyVarsOfTypes arg_tys
 334       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 335
 336 get_strictness (Banged   _) = MarkedStrict
 337 get_strictness (Unbanged _) = NotMarkedStrict
 338
 339 get_pty (Banged ty)   = ty
 340 get_pty (Unbanged ty) = ty
 341 \end{code}
 342
 343
 344
 345 Errors and contexts
 346 ~~~~~~~~~~~~~~~~~~~
 347 \begin{code}
 348 tySynCtxt tycon_name sty
 349   = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name]
 350
 351 tyDataCtxt tycon_name sty
 352   = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name]
 353
 354 tyNewCtxt tycon_name sty
 355   = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name]
 356
 357 fieldTypeMisMatch field_name sty
 358   = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name]
 359
 360 missingEvalErr con eval_theta sty
 361   = hsep [ptext SLIT("Missing Eval context for constructor"),
 362            ppr sty con,
 363            char ':', ppr sty eval_theta]
 364 \end{code}