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,
  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(..)
  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], TcHsBinds s)
 172 mkDataBinds [] = returnTc ([], EmptyBinds)
 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 `ThenBinds` 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,
 193               MonoBind (foldr AndMonoBinds EmptyMonoBinds binds) [] nonRecursive
 194              )
 195   where
 196     data_cons = tyConDataCons tycon
 197     fields = [ (con, field) | con   <- data_cons,
 198                               field <- dataConFieldLabels con
 199              ]
 200
 201         -- groups is list of fields that share a common name
 202     groups = equivClasses cmp_name fields
 203     cmp_name (_, field1) (_, field2)
 204         = fieldLabelName field1 `cmp` fieldLabelName field2
 205 \end{code}
 206
 207 -- Check that all the types of all the strict arguments are in Eval
 208
 209 \begin{code}
 210 checkConstructorContext con_id
 211   | not (isLocallyDefined con_id)
 212   = returnTc ()
 213
 214   | otherwise   -- It is locally defined
 215   = tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 216     let
 217         strict_marks         = dataConStrictMarks con_id
 218         (tyvars,theta,tau)   = splitSigmaTy (idType con_id)
 219         (arg_tys, result_ty) = splitFunTy tau
 220
 221         eval_theta = [ (eval_clas,arg_ty)
 222                      | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 223                                                         arg_tys strict_marks
 224                      ]
 225     in
 226     tcSimplifyThetas classInstEnv theta eval_theta      `thenTc` \ eval_theta' ->
 227     checkTc (null eval_theta')
 228             (missingEvalErr con_id eval_theta')
 229 \end{code}
 230
 231 \begin{code}
 232 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 233                 -- These fields all have the same name, but are from
 234                 -- different constructors in the data type
 235         -- Check that all the fields in the group have the same type
 236         -- This check assumes that all the constructors of a given
 237         -- data type use the same type variables
 238   = checkTc (all (eqTy field_ty) other_tys)
 239             (fieldTypeMisMatch field_name)      `thenTc_`
 240     returnTc selector_id
 241   where
 242     field_ty   = fieldLabelType first_field_label
 243     field_name = fieldLabelName first_field_label
 244     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 245     (tyvars, _, _, _, _, _) = dataConSig first_con
 246     data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 247     -- tyvars of first_con may be free in field_ty
 248     -- Now build the selector
 249
 250     selector_ty :: Type
 251     selector_ty  = mkForAllTys tyvars $
 252                    mkFunTy data_ty $
 253                    field_ty
 254
 255     selector_id :: Id
 256     selector_id = mkRecordSelId first_field_label selector_ty
 257 \end{code}
 258
 259 Constructors
 260 ~~~~~~~~~~~~
 261 \begin{code}
 262 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 263
 264 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
 265   = tcDataCon tycon tyvars ctxt name btys src_loc
 266
 267 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
 268   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 269
 270 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
 271   = tcAddSrcLoc src_loc $
 272     tcHsType ty `thenTc` \ arg_ty ->
 273     let
 274       data_con = mkDataCon (getName name)
 275                            [NotMarkedStrict]
 276                            [{- No labelled fields -}]
 277                            tyvars
 278                            ctxt
 279                            [] []        -- Temporary
 280                            [arg_ty]
 281                            tycon
 282     in
 283     returnTc data_con
 284
 285 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
 286   = tcAddSrcLoc src_loc $
 287     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 288     let
 289       field_label_infos = concat field_label_infos_s
 290       stricts           = [strict | (_, _, strict) <- field_label_infos]
 291       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 292
 293       field_labels      = [ mkFieldLabel (getName name) ty tag
 294                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 295
 296       data_con = mkDataCon (getName name)
 297                            stricts
 298                            field_labels
 299                            tyvars
 300                            (thinContext arg_tys ctxt)
 301                            [] []        -- Temporary
 302                            arg_tys
 303                            tycon
 304     in
 305     returnTc data_con
 306
 307 tcField (field_label_names, bty)
 308   = tcHsType (get_pty bty)      `thenTc` \ field_ty ->
 309     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 310
 311 tcDataCon tycon tyvars ctxt name btys src_loc
 312   = tcAddSrcLoc src_loc $
 313     let
 314         stricts = map get_strictness btys
 315         tys     = map get_pty btys
 316     in
 317     mapTc tcHsType tys `thenTc` \ arg_tys ->
 318     let
 319       data_con = mkDataCon (getName name)
 320                            stricts
 321                            [{- No field labels -}]
 322                            tyvars
 323                            (thinContext arg_tys ctxt)
 324                            [] []        -- Temporary
 325                            arg_tys
 326                            tycon
 327     in
 328     returnTc data_con
 329
 330 -- The context for a data constructor should be limited to
 331 -- the type variables mentioned in the arg_tys
 332 thinContext arg_tys ctxt
 333   = filter in_arg_tys ctxt
 334   where
 335       arg_tyvars = tyVarsOfTypes arg_tys
 336       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 337
 338 get_strictness (Banged   _) = MarkedStrict
 339 get_strictness (Unbanged _) = NotMarkedStrict
 340
 341 get_pty (Banged ty)   = ty
 342 get_pty (Unbanged ty) = ty
 343 \end{code}
 344
 345
 346
 347 Errors and contexts
 348 ~~~~~~~~~~~~~~~~~~~
 349 \begin{code}
 350 tySynCtxt tycon_name sty
 351   = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name]
 352
 353 tyDataCtxt tycon_name sty
 354   = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name]
 355
 356 tyNewCtxt tycon_name sty
 357   = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name]
 358
 359 fieldTypeMisMatch field_name sty
 360   = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name]
 361
 362 missingEvalErr con eval_theta sty
 363   = hsep [ptext SLIT("Missing Eval context for constructor"),
 364            ppr sty con,
 365            char ':', ppr sty eval_theta]
 366 \end{code}