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