compiler/typecheck/TcTyClsDecls.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1996-1998
   4 %
   5
   6 TcTyClsDecls: Typecheck type and class declarations
   7
   8 \begin{code}
   9 module TcTyClsDecls (
  10         tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
  11         checkValidTyCon, dataDeclChecks, badFamInstDecl
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import HsSyn
  17 import HscTypes
  18 import BuildTyCl
  19 import TcUnify
  20 import TcRnMonad
  21 import TcEnv
  22 import TcTyDecls
  23 import TcClassDcl
  24 import TcHsType
  25 import TcMType
  26 import TcType
  27 import TysWiredIn       ( unitTy )
  28 import Type
  29 import Class
  30 import TyCon
  31 import DataCon
  32 import Id
  33 import MkCore           ( rEC_SEL_ERROR_ID )
  34 import IdInfo
  35 import Var
  36 import VarSet
  37 import Name
  38 import NameEnv
  39 import Outputable
  40 import Maybes
  41 import Unify
  42 import Util
  43 import SrcLoc
  44 import ListSetOps
  45 import Digraph
  46 import DynFlags
  47 import FastString
  48 import Unique           ( mkBuiltinUnique )
  49 import BasicTypes
  50
  51 import Bag
  52 import Control.Monad
  53 import Data.List
  54 \end{code}
  55
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{Type checking for type and class declarations}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64
  65 tcTyAndClassDecls :: ModDetails
  66                    -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
  67                    -> TcM (TcGblEnv,         -- Input env extended by types and classes
  68                                              -- and their implicit Ids,DataCons
  69                            HsValBinds Name)  -- Renamed bindings for record selectors
  70 -- Fails if there are any errors
  71
  72 tcTyAndClassDecls boot_details decls_s
  73   = checkNoErrs $       -- The code recovers internally, but if anything gave rise to
  74                         -- an error we'd better stop now, to avoid a cascade
  75     do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
  76                   -- Remove family instance decls altogether
  77                   -- They are dealt with by TcInstDcls
  78
  79        ; tyclss <- fixM $ \ rec_tyclss ->
  80               tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
  81                 -- We must populate the environment with the loop-tied
  82                 -- T's right away (even before kind checking), because
  83                 -- the kind checker may "fault in" some type constructors
  84                 -- that recursively mention T
  85
  86               do {    -- Kind-check in dependency order
  87                       -- See Note [Kind checking for type and class decls]
  88                    kc_decls <- kcTyClDecls tyclds_s
  89
  90                       -- And now build the TyCons/Classes
  91                 ; let rec_flags = calcRecFlags boot_details rec_tyclss
  92                 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
  93
  94        ; tcExtendGlobalEnv tyclss $ do
  95        {  -- Perform the validity check
  96           -- We can do this now because we are done with the recursive knot
  97           traceTc "ready for validity check" empty
  98         ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
  99         ; traceTc "done" empty
 100
 101         -- Add the implicit things;
 102         -- we want them in the environment because
 103         -- they may be mentioned in interface files
 104         -- NB: All associated types and their implicit things will be added a
 105         --     second time here.  This doesn't matter as the definitions are
 106         --     the same.
 107         ; let { implicit_things = concatMap implicitTyThings tyclss
 108               ; rec_sel_binds   = mkRecSelBinds [tc | ATyCon tc <- tyclss]
 109               ; dm_ids          = mkDefaultMethodIds tyclss }
 110
 111         ; env <- tcExtendGlobalEnv implicit_things $
 112                  tcExtendGlobalValEnv dm_ids $
 113                  getGblEnv
 114         ; return (env, rec_sel_binds) } }
 115
 116 zipRecTyClss :: [[LTyClDecl Name]]
 117              -> [TyThing]           -- Knot-tied
 118              -> [(Name,TyThing)]
 119 -- Build a name-TyThing mapping for the things bound by decls
 120 -- being careful not to look at the [TyThing]
 121 -- The TyThings in the result list must have a visible ATyCon/AClass,
 122 -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
 123 zipRecTyClss decls_s rec_things
 124   = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
 125   where
 126     rec_type_env :: TypeEnv
 127     rec_type_env = mkTypeEnv rec_things
 128
 129     get :: TyClDecl Name -> (Name, TyThing)
 130     get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
 131       where
 132         Just (AClass cl) = lookupTypeEnv rec_type_env name
 133     get decl = (name, ATyCon tc)
 134       where
 135         name = tcdName decl
 136         Just (ATyCon tc) = lookupTypeEnv rec_type_env name
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142                 Kind checking
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 Note [Kind checking for type and class decls]
 147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 148 Kind checking is done thus:
 149
 150    1. Make up a kind variable for each parameter of the *data* type,
 151       and class, decls, and extend the kind environment (which is in
 152       the TcLclEnv)
 153
 154    2. Dependency-analyse the type *synonyms* (which must be non-recursive),
 155       and kind-check them in dependency order.  Extend the kind envt.
 156
 157    3. Kind check the data type and class decls
 158
 159 Synonyms are treated differently to data type and classes,
 160 because a type synonym can be an unboxed type
 161         type Foo = Int#
 162 and a kind variable can't unify with UnboxedTypeKind
 163 So we infer their kinds in dependency order
 164
 165 We need to kind check all types in the mutually recursive group
 166 before we know the kind of the type variables.  For example:
 167
 168 class C a where
 169    op :: D b => a -> b -> b
 170
 171 class D c where
 172    bop :: (Monad c) => ...
 173
 174 Here, the kind of the locally-polymorphic type variable "b"
 175 depends on *all the uses of class D*.  For example, the use of
 176 Monad c in bop's type signature means that D must have kind Type->Type.
 177
 178 However type synonyms work differently.  They can have kinds which don't
 179 just involve (->) and *:
 180         type R = Int#           -- Kind #
 181         type S a = Array# a     -- Kind * -> #
 182         type T a b = (# a,b #)  -- Kind * -> * -> (# a,b #)
 183 So we must infer their kinds from their right-hand sides *first* and then
 184 use them, whereas for the mutually recursive data types D we bring into
 185 scope kind bindings D -> k, where k is a kind variable, and do inference.
 186
 187 Type families
 188 ~~~~~~~~~~~~~
 189 This treatment of type synonyms only applies to Haskell 98-style synonyms.
 190 General type functions can be recursive, and hence, appear in `alg_decls'.
 191
 192 The kind of a type family is solely determinded by its kind signature;
 193 hence, only kind signatures participate in the construction of the initial
 194 kind environment (as constructed by `getInitialKind').  In fact, we ignore
 195 instances of families altogether in the following.  However, we need to
 196 include the kinds of associated families into the construction of the
 197 initial kind environment.  (This is handled by `allDecls').
 198
 199
 200 \begin{code}
 201 kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
 202 kcTyClDecls []                = return []
 203 kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
 204                                    ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
 205                                    ; return (kc_decls1 ++ kc_decls2) }
 206
 207 kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
 208 kcTyClDecls1 decls
 209   = do  {       -- Omit instances of type families; they are handled together
 210                 -- with the *heads* of class instances
 211         ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
 212               alg_at_decls           = flattenATs alg_decls
 213
 214         ; mod <- getModule
 215         ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
 216
 217                 -- First check for cyclic classes
 218         ; checkClassCycleErrs alg_decls
 219
 220            -- Kind checking; see Note [Kind checking for type and class decls]
 221         ; alg_kinds <- mapM getInitialKind alg_at_decls
 222         ; tcExtendKindEnv alg_kinds $  do
 223
 224         { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
 225         ; setLclEnv tcl_env $  do
 226         { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
 227
 228              -- Kind checking done for this group, so zonk the kind variables
 229              -- See Note [Kind checking for type and class decls]
 230         ; mapM_ (zonkTcKindToKind . snd) alg_kinds
 231
 232         ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
 233
 234 flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
 235 flattenATs decls = concatMap flatten decls
 236   where
 237     flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
 238     flatten decl                                  = [decl]
 239
 240 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
 241 -- Only for data type, class, and indexed type declarations
 242 -- Get as much info as possible from the data, class, or indexed type decl,
 243 -- so as to maximise usefulness of error messages
 244 getInitialKind (L _ decl)
 245   = do  { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
 246         ; res_kind  <- mk_res_kind decl
 247         ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
 248   where
 249     mk_arg_kind (UserTyVar _ _)      = newKindVar
 250     mk_arg_kind (KindedTyVar _ kind) = return kind
 251
 252     mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
 253     mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
 254         -- On GADT-style declarations we allow a kind signature
 255         --      data T :: *->* where { ... }
 256     mk_res_kind _ = return liftedTypeKind
 257
 258
 259 ----------------
 260 kcSynDecls :: [SCC (LTyClDecl Name)]
 261            -> TcM ([LTyClDecl Name],    -- Kind-annotated decls
 262                    TcLclEnv)    -- Kind bindings
 263 kcSynDecls []
 264   = do { tcl_env <- getLclEnv; return ([], tcl_env) }
 265 kcSynDecls (group : groups)
 266   = do  { (decl,  nk)      <- kcSynDecl group
 267         ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
 268         ; return (decl:decls, tcl_env) }
 269
 270 ----------------
 271 kcSynDecl :: SCC (LTyClDecl Name)
 272            -> TcM (LTyClDecl Name,      -- Kind-annotated decls
 273                    (Name,TcKind))       -- Kind bindings
 274 kcSynDecl (AcyclicSCC (L loc decl))
 275   = tcAddDeclCtxt decl  $
 276     kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
 277     do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
 278                         <+> brackets (ppr k_tvs))
 279        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
 280        ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
 281        ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
 282        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
 283                  (unLoc (tcdLName decl), tc_kind)) })
 284
 285 kcSynDecl (CyclicSCC decls)
 286   = do { recSynErr decls; failM }       -- Fail here to avoid error cascade
 287                                         -- of out-of-scope tycons
 288
 289 ------------------------------------------------------------------------
 290 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
 291         -- Not used for type synonyms (see kcSynDecl)
 292
 293 kcTyClDecl decl@(TyData {})
 294   = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
 295     kcTyClDeclBody decl $
 296       kcDataDecl decl
 297
 298 kcTyClDecl decl@(TyFamily {})
 299   = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl
 300
 301 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
 302   = kcTyClDeclBody decl $ \ tvs' ->
 303     do  { ctxt' <- kcHsContext ctxt
 304         ; ats'  <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
 305         ; sigs' <- mapM (wrapLocM kc_sig) sigs
 306         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
 307                         tcdATs = ats'}) }
 308   where
 309     kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
 310                                    ; return (TypeSig nm op_ty') }
 311     kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
 312                                       ; return (GenericSig nm op_ty') }
 313     kc_sig other_sig          = return other_sig
 314
 315 kcTyClDecl decl@(ForeignType {})
 316   = return decl
 317
 318 kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
 319
 320 kcTyClDeclBody :: TyClDecl Name
 321                -> ([LHsTyVarBndr Name] -> TcM a)
 322                -> TcM a
 323 -- getInitialKind has made a suitably-shaped kind for the type or class
 324 -- Unpack it, and attribute those kinds to the type variables
 325 -- Extend the env with bindings for the tyvars, taken from
 326 -- the kind of the tycon/class.  Give it to the thing inside, and
 327 -- check the result kind matches
 328 kcTyClDeclBody decl thing_inside
 329   = tcAddDeclCtxt decl          $
 330     do  { tc_ty_thing <- tcLookupLocated (tcdLName decl)
 331         ; let tc_kind    = case tc_ty_thing of
 332                              AThing k -> k
 333                              _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
 334               (kinds, _) = splitKindFunTys tc_kind
 335               hs_tvs     = tcdTyVars decl
 336               kinded_tvs = ASSERT( length kinds >= length hs_tvs )
 337                            zipWith add_kind hs_tvs kinds
 338         ; tcExtendKindEnvTvs kinded_tvs thing_inside }
 339   where
 340     add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
 341     add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
 342
 343 -- Kind check a data declaration, assuming that we already extended the
 344 -- kind environment with the type variables of the left-hand side (these
 345 -- kinded type variables are also passed as the second parameter).
 346 --
 347 kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
 348 kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 349            tvs
 350   = do  { ctxt' <- kcHsContext ctxt
 351         ; cons' <- mapM (wrapLocM kc_con_decl) cons
 352         ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
 353   where
 354     -- doc comments are typechecked to Nothing here
 355     kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
 356                                   , con_cxt = ex_ctxt, con_details = details, con_res = res })
 357       = addErrCtxt (dataConCtxt name)   $
 358         kcHsTyVars ex_tvs $ \ex_tvs' -> do
 359         do { ex_ctxt' <- kcHsContext ex_ctxt
 360            ; details' <- kc_con_details details
 361            ; res'     <- case res of
 362                 ResTyH98 -> return ResTyH98
 363                 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
 364            ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
 365                               , con_details = details', con_res = res' }) }
 366
 367     kc_con_details (PrefixCon btys)
 368         = do { btys' <- mapM kc_larg_ty btys
 369              ; return (PrefixCon btys') }
 370     kc_con_details (InfixCon bty1 bty2)
 371         = do { bty1' <- kc_larg_ty bty1
 372              ; bty2' <- kc_larg_ty bty2
 373              ; return (InfixCon bty1' bty2') }
 374     kc_con_details (RecCon fields)
 375         = do { fields' <- mapM kc_field fields
 376              ; return (RecCon fields') }
 377
 378     kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
 379                                            ; return (ConDeclField fld bty' d) }
 380
 381     kc_larg_ty bty = case new_or_data of
 382                         DataType -> kcHsSigType bty
 383                         NewType  -> kcHsLiftedSigType bty
 384         -- Can't allow an unlifted type for newtypes, because we're effectively
 385         -- going to remove the constructor while coercing it to a lifted type.
 386         -- And newtypes can't be bang'd
 387 kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
 388
 389 -- Kind check a family declaration or type family default declaration.
 390 --
 391 kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
 392              -> TyClDecl Name -> TcM (TyClDecl Name)
 393 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
 394   = kcTyClDeclBody decl $ \tvs' ->
 395     do { mapM_ unifyClassParmKinds tvs'
 396        ; return (decl {tcdTyVars = tvs',
 397                        tcdKind = kind `mplus` Just liftedTypeKind})
 398                        -- default result kind is '*'
 399        }
 400   where
 401     unifyClassParmKinds (L _ tv)
 402       | (n,k) <- hsTyVarNameKind tv
 403       , Just classParmKind <- lookup n classTyKinds
 404       = unifyKind k classParmKind
 405       | otherwise = return ()
 406     classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
 407
 408 kcFamilyDecl _ (TySynonym {})              -- type family defaults
 409   = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
 410 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
 411 \end{code}
 412
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsection{Type checking}
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
 422
 423 tcTyClDecl calc_isrec (L loc decl)
 424   = setSrcSpan loc $ tcAddDeclCtxt decl $
 425     tcTyClDecl1 NoParentTyCon calc_isrec decl
 426
 427   -- "type family" declarations
 428 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
 429 tcTyClDecl1 parent _calc_isrec
 430   (TyFamily {tcdFlavour = TypeFamily,
 431              tcdLName = L _ tc_name, tcdTyVars = tvs,
 432              tcdKind = Just kind}) -- NB: kind at latest added during kind checking
 433   = tcTyVarBndrs tvs  $ \ tvs' -> do
 434   { traceTc "type family:" (ppr tc_name)
 435
 436         -- Check that we don't use families without -XTypeFamilies
 437   ; idx_tys <- xoptM Opt_TypeFamilies
 438   ; checkTc idx_tys $ badFamInstDecl tc_name
 439
 440   ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
 441   ; return [ATyCon tycon]
 442   }
 443
 444   -- "data family" declaration
 445 tcTyClDecl1 parent _calc_isrec
 446   (TyFamily {tcdFlavour = DataFamily,
 447              tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
 448   = tcTyVarBndrs tvs  $ \ tvs' -> do
 449   { traceTc "data family:" (ppr tc_name)
 450   ; extra_tvs <- tcDataKindSig mb_kind
 451   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 452
 453
 454         -- Check that we don't use families without -XTypeFamilies
 455   ; idx_tys <- xoptM Opt_TypeFamilies
 456   ; checkTc idx_tys $ badFamInstDecl tc_name
 457
 458   ; tycon <- buildAlgTyCon tc_name final_tvs []
 459                DataFamilyTyCon Recursive True
 460                parent Nothing
 461   ; return [ATyCon tycon]
 462   }
 463
 464   -- "type"
 465 tcTyClDecl1 _parent _calc_isrec
 466   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
 467   = ASSERT( isNoParent _parent )
 468     tcTyVarBndrs tvs            $ \ tvs' -> do
 469     { traceTc "tcd1" (ppr tc_name)
 470     ; rhs_ty' <- tcHsKindedType rhs_ty
 471     ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
 472                              (typeKind rhs_ty') NoParentTyCon  Nothing
 473     ; return [ATyCon tycon] }
 474
 475   -- "newtype" and "data"
 476   -- NB: not used for newtype/data instances (whether associated or not)
 477 tcTyClDecl1 _parent calc_isrec
 478   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 479            tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
 480   = ASSERT( isNoParent _parent )
 481     tcTyVarBndrs tvs    $ \ tvs' -> do
 482   { extra_tvs <- tcDataKindSig mb_ksig
 483   ; let final_tvs = tvs' ++ extra_tvs
 484   ; stupid_theta <- tcHsKindedContext ctxt
 485   ; unbox_strict <- doptM Opt_UnboxStrictFields
 486   ; kind_signatures <- xoptM Opt_KindSignatures
 487   ; existential_ok <- xoptM Opt_ExistentialQuantification
 488   ; gadt_ok      <- xoptM Opt_GADTs
 489   ; is_boot      <- tcIsHsBoot  -- Are we compiling an hs-boot file?
 490   ; let ex_ok = existential_ok || gadt_ok       -- Data cons can have existential context
 491
 492         -- Check that we don't use kind signatures without Glasgow extensions
 493   ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
 494
 495   ; dataDeclChecks tc_name new_or_data stupid_theta cons
 496
 497   ; tycon <- fixM (\ tycon -> do
 498         { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
 499         ; data_cons <- tcConDecls unbox_strict ex_ok
 500                                   tycon (final_tvs, res_ty) cons
 501         ; tc_rhs <-
 502             if null cons && is_boot     -- In a hs-boot file, empty cons means
 503             then return AbstractTyCon   -- "don't know"; hence Abstract
 504             else case new_or_data of
 505                    DataType -> return (mkDataTyConRhs data_cons)
 506                    NewType  -> ASSERT( not (null data_cons) )
 507                                mkNewTyConRhs tc_name tycon (head data_cons)
 508         ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
 509             (not h98_syntax) NoParentTyCon Nothing
 510         })
 511   ; return [ATyCon tycon]
 512   }
 513   where
 514     is_rec   = calc_isrec tc_name
 515     h98_syntax = consUseH98Syntax cons
 516
 517 tcTyClDecl1 _parent calc_isrec
 518   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
 519               tcdCtxt = ctxt, tcdMeths = meths,
 520               tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
 521   = ASSERT( isNoParent _parent )
 522     tcTyVarBndrs tvs            $ \ tvs' -> do
 523   { ctxt' <- tcHsKindedContext ctxt
 524   ; fds' <- mapM (addLocM tc_fundep) fundeps
 525   ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
 526   ; clas <- fixM $ \ clas -> do
 527             { let       -- This little knot is just so we can get
 528                         -- hold of the name of the class TyCon, which we
 529                         -- need to look up its recursiveness
 530                     tycon_name = tyConName (classTyCon clas)
 531                     tc_isrec = calc_isrec tycon_name
 532             ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
 533             -- NB: 'ats' only contains "type family" and "data family"
 534             --     declarations as well as type family defaults
 535             ; buildClass False {- Must include unfoldings for selectors -}
 536                          class_name tvs' ctxt' fds' (concat atss')
 537                          sig_stuff tc_isrec }
 538
 539   ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
 540                      | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
 541                      , let gen_dm_tau = expectJust "tcTyClDecl1" $
 542                                         lookupNameEnv gen_dm_env (idName sel_id)
 543                      , let gen_dm_ty = mkSigmaTy tvs'
 544                                                  [mkClassPred clas (mkTyVarTys tvs')]
 545                                                  gen_dm_tau
 546                      ]
 547         class_ats = map ATyCon (classATs clas)
 548
 549   ; return (AClass clas : gen_dm_ids ++ class_ats )
 550       -- NB: Order is important due to the call to `mkGlobalThings' when
 551       --     tying the the type and class declaration type checking knot.
 552   }
 553   where
 554     tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
 555                                 ; tvs2' <- mapM tcLookupTyVar tvs2 ;
 556                                 ; return (tvs1', tvs2') }
 557
 558 tcTyClDecl1 _ _
 559   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
 560   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
 561
 562 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
 563
 564 dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
 565 dataDeclChecks tc_name new_or_data stupid_theta cons
 566   = do {   -- Check that we don't use GADT syntax in H98 world
 567          gadtSyntax_ok <- xoptM Opt_GADTSyntax
 568        ; let h98_syntax = consUseH98Syntax cons
 569        ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
 570
 571            -- Check that the stupid theta is empty for a GADT-style declaration
 572        ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
 573
 574         -- Check that a newtype has exactly one constructor
 575         -- Do this before checking for empty data decls, so that
 576         -- we don't suggest -XEmptyDataDecls for newtypes
 577       ; checkTc (new_or_data == DataType || isSingleton cons)
 578                 (newtypeConError tc_name (length cons))
 579
 580         -- Check that there's at least one condecl,
 581         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
 582       ; empty_data_decls <- xoptM Opt_EmptyDataDecls
 583       ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
 584       ; checkTc (not (null cons) || empty_data_decls || is_boot)
 585                 (emptyConDeclsErr tc_name) }
 586
 587 -----------------------------------
 588 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
 589            -> [LConDecl Name] -> TcM [DataCon]
 590 tcConDecls unbox ex_ok rep_tycon res_tmpl cons
 591   = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
 592
 593 tcConDecl :: Bool               -- True <=> -funbox-strict_fields
 594           -> Bool               -- True <=> -XExistentialQuantificaton or -XGADTs
 595           -> TyCon              -- Representation tycon
 596           -> ([TyVar], Type)    -- Return type template (with its template tyvars)
 597           -> ConDecl Name
 598           -> TcM DataCon
 599
 600 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl        -- Data types
 601           con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
 602                    , con_details = details, con_res = res_ty })
 603   = addErrCtxt (dataConCtxt name)       $
 604     tcTyVarBndrs tvs                    $ \ tvs' -> do
 605     { ctxt' <- tcHsKindedContext ctxt
 606     ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
 607               (badExistential name)
 608     ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
 609     ; let
 610         tc_datacon is_infix field_lbls btys
 611           = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
 612                ; buildDataCon (unLoc name) is_infix
 613                     stricts field_lbls
 614                     univ_tvs ex_tvs eq_preds ctxt' arg_tys
 615                     res_ty' rep_tycon }
 616                 -- NB:  we put data_tc, the type constructor gotten from the
 617                 --      constructor type signature into the data constructor;
 618                 --      that way checkValidDataCon can complain if it's wrong.
 619
 620     ; case details of
 621         PrefixCon btys     -> tc_datacon False [] btys
 622         InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
 623         RecCon fields      -> tc_datacon False field_names btys
 624                            where
 625                               field_names = map (unLoc . cd_fld_name) fields
 626                               btys        = map cd_fld_type fields
 627     }
 628
 629 -- Example
 630 --   data instance T (b,c) where
 631 --      TI :: forall e. e -> T (e,e)
 632 --
 633 -- The representation tycon looks like this:
 634 --   data :R7T b c where
 635 --      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
 636 -- In this case orig_res_ty = T (e,e)
 637
 638 tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
 639                                 -- data instance T [a] b c = ...
 640                                 --      gives template ([a,b,c], T [a] b c)
 641              -> [TyVar]         -- where MkT :: forall x y z. ...
 642              -> ResType Name
 643              -> TcM ([TyVar],           -- Universal
 644                      [TyVar],           -- Existential (distinct OccNames from univs)
 645                      [(TyVar,Type)],    -- Equality predicates
 646                      Type)              -- Typechecked return type
 647         -- We don't check that the TyCon given in the ResTy is
 648         -- the same as the parent tycon, becuase we are in the middle
 649         -- of a recursive knot; so it's postponed until checkValidDataCon
 650
 651 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
 652   = return (tmpl_tvs, dc_tvs, [], res_ty)
 653         -- In H98 syntax the dc_tvs are the existential ones
 654         --      data T a b c = forall d e. MkT ...
 655         -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs
 656
 657 tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
 658         -- E.g.  data T [a] b c where
 659         --         MkT :: forall x y z. T [(x,y)] z z
 660         -- Then we generate
 661         --      Univ tyvars     Eq-spec
 662         --          a              a~(x,y)
 663         --          b              b~z
 664         --          z
 665         -- Existentials are the leftover type vars: [x,y]
 666         -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
 667   = do  { res_ty' <- tcHsKindedType res_ty
 668         ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
 669
 670                 -- /Lazily/ figure out the univ_tvs etc
 671                 -- Each univ_tv is either a dc_tv or a tmpl_tv
 672               (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
 673               choose tmpl (univs, eqs)
 674                 | Just ty <- lookupTyVar subst tmpl
 675                 = case tcGetTyVar_maybe ty of
 676                     Just tv | not (tv `elem` univs)
 677                             -> (tv:univs,   eqs)
 678                     _other  -> (tmpl:univs, (tmpl,ty):eqs)
 679                 | otherwise = pprPanic "tcResultType" (ppr res_ty)
 680               ex_tvs = dc_tvs `minusList` univ_tvs
 681
 682         ; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
 683   where
 684         -- NB: tmpl_tvs and dc_tvs are distinct, but
 685         -- we want them to be *visibly* distinct, both for
 686         -- interface files and general confusion.  So rename
 687         -- the tc_tvs, since they are not used yet (no
 688         -- consequential renaming needed)
 689     (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
 690     init_occ_env       = initTidyOccEnv (map getOccName dc_tvs)
 691     tidy_one env tv    = (env', setTyVarName tv (tidyNameOcc name occ'))
 692               where
 693                  name = tyVarName tv
 694                  (env', occ') = tidyOccName env (getOccName name)
 695
 696 consUseH98Syntax :: [LConDecl a] -> Bool
 697 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
 698 consUseH98Syntax _                                             = True
 699                  -- All constructors have same shape
 700
 701 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
 702 conRepresentibleWithH98Syntax
 703     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
 704         = null tvs && null (unLoc ctxt)
 705 conRepresentibleWithH98Syntax
 706     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
 707         = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
 708     where -- Each type variable should be used exactly once in the
 709           -- result type, and the result type must just be the type
 710           -- constructor applied to type variables
 711           f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
 712               = (v2 `elem` vs) && f t1 (delete v2 vs)
 713           f (HsTyVar _) [] = True
 714           f _ _ = False
 715
 716 -------------------
 717 tcConArg :: Bool                -- True <=> -funbox-strict_fields
 718            -> LHsType Name
 719            -> TcM (TcType, HsBang)
 720 tcConArg unbox_strict bty
 721   = do  { arg_ty <- tcHsBangType bty
 722         ; let bang = getBangStrictness bty
 723         ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
 724         ; return (arg_ty, strict_mark) }
 725
 726 -- We attempt to unbox/unpack a strict field when either:
 727 --   (i)  The field is marked '!!', or
 728 --   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
 729 --
 730 -- We have turned off unboxing of newtypes because coercions make unboxing
 731 -- and reboxing more complicated
 732 chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
 733 chooseBoxingStrategy unbox_strict_fields arg_ty bang
 734   = case bang of
 735         HsNoBang                        -> HsNoBang
 736         HsUnpack                        -> can_unbox HsUnpackFailed arg_ty
 737         HsStrict | unbox_strict_fields  -> can_unbox HsStrict       arg_ty
 738                  | otherwise            -> HsStrict
 739         HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
 740                           -- Source code never has shtes
 741   where
 742     can_unbox :: HsBang -> TcType -> HsBang
 743     -- Returns   HsUnpack  if we can unpack arg_ty
 744     --           fail_bang if we know what arg_ty is but we can't unpack it
 745     --           HsStrict  if it's abstract, so we don't know whether or not we can unbox it
 746     can_unbox fail_bang arg_ty
 747        = case splitTyConApp_maybe arg_ty of
 748             Nothing -> fail_bang
 749
 750             Just (arg_tycon, tycon_args)
 751               | isAbstractTyCon arg_tycon -> HsStrict
 752                       -- See Note [Don't complain about UNPACK on abstract TyCons]
 753               | not (isRecursiveTyCon arg_tycon)        -- Note [Recusive unboxing]
 754               , isProductTyCon arg_tycon
 755                     -- We can unbox if the type is a chain of newtypes
 756                     -- with a product tycon at the end
 757               -> if isNewTyCon arg_tycon
 758                  then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
 759                  else HsUnpack
 760
 761               | otherwise -> fail_bang
 762 \end{code}
 763
 764 Note [Don't complain about UNPACK on abstract TyCons]
 765 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 766 We are going to complain about UnpackFailed, but if we say
 767    data T = MkT {-# UNPACK #-} !Wobble
 768 and Wobble is a newtype imported from a module that was compiled
 769 without optimisation, we don't want to complain. Because it might
 770 be fine when optimsation is on.  I think this happens when Haddock
 771 is working over (say) GHC souce files.
 772
 773 Note [Recursive unboxing]
 774 ~~~~~~~~~~~~~~~~~~~~~~~~~
 775 Be careful not to try to unbox this!
 776         data T = MkT !T Int
 777 But it's the *argument* type that matters. This is fine:
 778         data S = MkS S !Int
 779 because Int is non-recursive.
 780
 781
 782 %************************************************************************
 783 %*                                                                      *
 784                 Validity checking
 785 %*                                                                      *
 786 %************************************************************************
 787
 788 Validity checking is done once the mutually-recursive knot has been
 789 tied, so we can look at things freely.
 790
 791 \begin{code}
 792 checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
 793 checkClassCycleErrs tyclss
 794   | null cls_cycles
 795   = return ()
 796   | otherwise
 797   = do  { mapM_ recClsErr cls_cycles
 798         ; failM }       -- Give up now, because later checkValidTyCl
 799                         -- will loop if the synonym is recursive
 800   where
 801     cls_cycles = calcClassCycles tyclss
 802
 803 checkValidTyCl :: TyClDecl Name -> TcM ()
 804 -- We do the validity check over declarations, rather than TyThings
 805 -- only so that we can add a nice context with tcAddDeclCtxt
 806 checkValidTyCl decl
 807   = tcAddDeclCtxt decl $
 808     do  { thing <- tcLookupLocatedGlobal (tcdLName decl)
 809         ; traceTc "Validity of" (ppr thing)
 810         ; case thing of
 811             ATyCon tc -> checkValidTyCon tc
 812             AClass cl -> do { checkValidClass cl
 813                             ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
 814             AnId _    -> return ()  -- Generic default methods are checked
 815                                     -- with their parent class
 816             _         -> panic "checkValidTyCl"
 817         ; traceTc "Done validity of" (ppr thing)
 818         }
 819
 820 -------------------------
 821 -- For data types declared with record syntax, we require
 822 -- that each constructor that has a field 'f'
 823 --      (a) has the same result type
 824 --      (b) has the same type for 'f'
 825 -- module alpha conversion of the quantified type variables
 826 -- of the constructor.
 827 --
 828 -- Note that we allow existentials to match becuase the
 829 -- fields can never meet. E.g
 830 --      data T where
 831 --        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
 832 --        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
 833 -- Here we do not complain about f1,f2 because they are existential
 834
 835 checkValidTyCon :: TyCon -> TcM ()
 836 checkValidTyCon tc
 837   | isSynTyCon tc
 838   = case synTyConRhs tc of
 839       SynFamilyTyCon {} -> return ()
 840       SynonymTyCon ty   -> checkValidType syn_ctxt ty
 841   | otherwise
 842   = do  -- Check the context on the data decl
 843     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
 844
 845         -- Check arg types of data constructors
 846     mapM_ (checkValidDataCon tc) data_cons
 847
 848         -- Check that fields with the same name share a type
 849     mapM_ check_fields groups
 850
 851   where
 852     syn_ctxt  = TySynCtxt name
 853     name      = tyConName tc
 854     data_cons = tyConDataCons tc
 855
 856     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
 857     cmp_fld (f1,_) (f2,_) = f1 `compare` f2
 858     get_fields con = dataConFieldLabels con `zip` repeat con
 859         -- dataConFieldLabels may return the empty list, which is fine
 860
 861     -- See Note [GADT record selectors] in MkId.lhs
 862     -- We must check (a) that the named field has the same
 863     --                   type in each constructor
 864     --               (b) that those constructors have the same result type
 865     --
 866     -- However, the constructors may have differently named type variable
 867     -- and (worse) we don't know how the correspond to each other.  E.g.
 868     --     C1 :: forall a b. { f :: a, g :: b } -> T a b
 869     --     C2 :: forall d c. { f :: c, g :: c } -> T c d
 870     --
 871     -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
 872     -- result type against other candidates' types BOTH WAYS ROUND.
 873     -- If they magically agrees, take the substitution and
 874     -- apply them to the latter ones, and see if they match perfectly.
 875     check_fields ((label, con1) : other_fields)
 876         -- These fields all have the same name, but are from
 877         -- different constructors in the data type
 878         = recoverM (return ()) $ mapM_ checkOne other_fields
 879                 -- Check that all the fields in the group have the same type
 880                 -- NB: this check assumes that all the constructors of a given
 881                 -- data type use the same type variables
 882         where
 883         (tvs1, _, _, res1) = dataConSig con1
 884         ts1 = mkVarSet tvs1
 885         fty1 = dataConFieldType con1 label
 886
 887         checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
 888             = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
 889                  ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
 890             where
 891                 (tvs2, _, _, res2) = dataConSig con2
 892                 ts2 = mkVarSet tvs2
 893                 fty2 = dataConFieldType con2 label
 894     check_fields [] = panic "checkValidTyCon/check_fields []"
 895
 896 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
 897                  -> Type -> Type -> Type -> Type -> TcM ()
 898 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
 899   = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
 900         ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
 901   where
 902     mb_subst1 = tcMatchTy tvs1 res1 res2
 903     mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
 904
 905 -------------------------------
 906 checkValidDataCon :: TyCon -> DataCon -> TcM ()
 907 checkValidDataCon tc con
 908   = setSrcSpan (srcLocSpan (getSrcLoc con))     $
 909     addErrCtxt (dataConCtxt con)                $
 910     do  { traceTc "Validity of data con" (ppr con)
 911         ; let tc_tvs = tyConTyVars tc
 912               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
 913               actual_res_ty = dataConOrigResTy con
 914         ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
 915                                 res_ty_tmpl
 916                                 actual_res_ty))
 917                   (badDataConTyCon con res_ty_tmpl actual_res_ty)
 918         ; checkValidMonoType (dataConOrigResTy con)
 919                 -- Disallow MkT :: T (forall a. a->a)
 920                 -- Reason: it's really the argument of an equality constraint
 921         ; checkValidType ctxt (dataConUserType con)
 922         ; when (isNewTyCon tc) (checkNewDataCon con)
 923         ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
 924     }
 925   where
 926     ctxt = ConArgCtxt (dataConName con)
 927     check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
 928     check_bang _                   = return ()
 929
 930     cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
 931                            , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
 932
 933 -------------------------------
 934 checkNewDataCon :: DataCon -> TcM ()
 935 -- Checks for the data constructor of a newtype
 936 checkNewDataCon con
 937   = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
 938                 -- One argument
 939         ; checkTc (null eq_spec) (newtypePredError con)
 940                 -- Return type is (T a b c)
 941         ; checkTc (null ex_tvs && null theta) (newtypeExError con)
 942                 -- No existentials
 943         ; checkTc (not (any isBanged (dataConStrictMarks con)))
 944                   (newtypeStrictError con)
 945                 -- No strictness
 946     }
 947   where
 948     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
 949
 950 -------------------------------
 951 checkValidClass :: Class -> TcM ()
 952 checkValidClass cls
 953   = do  { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
 954         ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
 955         ; fundep_classes <- xoptM Opt_FunctionalDependencies
 956
 957         -- Check that the class is unary, unless GlaExs
 958         ; checkTc (notNull tyvars) (nullaryClassErr cls)
 959         ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
 960         ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
 961
 962         -- Check the super-classes
 963         ; checkValidTheta (ClassSCCtxt (className cls)) theta
 964
 965         -- Check the class operations
 966         ; mapM_ (check_op constrained_class_methods) op_stuff
 967
 968         -- Check that if the class has generic methods, then the
 969         -- class has only one parameter.  We can't do generic
 970         -- multi-parameter type classes!
 971         ; checkTc (unary || no_generics) (genericMultiParamErr cls)
 972         }
 973   where
 974     (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
 975     unary       = isSingleton tyvars
 976     no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 977
 978     check_op constrained_class_methods (sel_id, dm)
 979       = addErrCtxt (classOpCtxt sel_id tau) $ do
 980         { checkValidTheta SigmaCtxt (tail theta)
 981                 -- The 'tail' removes the initial (C a) from the
 982                 -- class itself, leaving just the method type
 983
 984         ; traceTc "class op type" (ppr op_ty <+> ppr tau)
 985         ; checkValidType (FunSigCtxt op_name) tau
 986
 987                 -- Check that the type mentions at least one of
 988                 -- the class type variables...or at least one reachable
 989                 -- from one of the class variables.  Example: tc223
 990                 --   class Error e => Game b mv e | b -> mv e where
 991                 --      newBoard :: MonadState b m => m ()
 992                 -- Here, MonadState has a fundep m->b, so newBoard is fine
 993         ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
 994         ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
 995                   (noClassTyVarErr cls sel_id)
 996
 997         ; case dm of
 998             GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
 999                                      ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
1000             _                  -> return ()
1001         }
1002         where
1003           op_name = idName sel_id
1004           op_ty   = idType sel_id
1005           (_,theta1,tau1) = tcSplitSigmaTy op_ty
1006           (_,theta2,tau2)  = tcSplitSigmaTy tau1
1007           (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
1008                       | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
1009                 -- Ugh!  The function might have a type like
1010                 --      op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
1011                 -- With -XConstrainedClassMethods, we want to allow this, even though the inner
1012                 -- forall has an (Eq a) constraint.  Whereas in general, each constraint
1013                 -- in the context of a for-all must mention at least one quantified
1014                 -- type variable.  What a mess!
1015 \end{code}
1016
1017
1018 %************************************************************************
1019 %*                                                                      *
1020                 Building record selectors
1021 %*                                                                      *
1022 %************************************************************************
1023
1024 \begin{code}
1025 mkDefaultMethodIds :: [TyThing] -> [Id]
1026 -- See Note [Default method Ids and Template Haskell]
1027 mkDefaultMethodIds things
1028   = [ mkExportedLocalId dm_name (idType sel_id)
1029     | AClass cls <- things
1030     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
1031 \end{code}
1032
1033 Note [Default method Ids and Template Haskell]
1034 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1035 Consider this (Trac #4169):
1036    class Numeric a where
1037      fromIntegerNum :: a
1038      fromIntegerNum = ...
1039
1040    ast :: Q [Dec]
1041    ast = [d| instance Numeric Int |]
1042
1043 When we typecheck 'ast' we have done the first pass over the class decl
1044 (in tcTyClDecls), but we have not yet typechecked the default-method
1045 declarations (becuase they can mention value declarations).  So we
1046 must bring the default method Ids into scope first (so they can be seen
1047 when typechecking the [d| .. |] quote, and typecheck them later.
1048
1049 \begin{code}
1050 mkRecSelBinds :: [TyCon] -> HsValBinds Name
1051 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
1052 --    This makes life easier, because the later type checking will add
1053 --    all necessary type abstractions and applications
1054 mkRecSelBinds tycons
1055   = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
1056   where
1057     (sigs, binds) = unzip rec_sels
1058     rec_sels = map mkRecSelBind [ (tc,fld)
1059                                 | tc <- tycons
1060                                 , fld <- tyConFields tc ]
1061
1062 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
1063 mkRecSelBind (tycon, sel_name)
1064   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
1065   where
1066     loc         = getSrcSpan tycon
1067     sel_id      = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
1068     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
1069
1070     -- Find a representative constructor, con1
1071     all_cons     = tyConDataCons tycon
1072     cons_w_field = [ con | con <- all_cons
1073                    , sel_name `elem` dataConFieldLabels con ]
1074     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
1075
1076     -- Selector type; Note [Polymorphic selectors]
1077     field_ty   = dataConFieldType con1 sel_name
1078     data_ty    = dataConOrigResTy con1
1079     data_tvs   = tyVarsOfType data_ty
1080     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
1081     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
1082     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
1083            | otherwise  = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
1084                           mkPhiTy (dataConStupidTheta con1) $   -- Urgh!
1085                           mkPhiTy field_theta               $   -- Urgh!
1086                           mkFunTy data_ty field_tau
1087
1088     -- Make the binding: sel (C2 { fld = x }) = x
1089     --                   sel (C7 { fld = x }) = x
1090     --    where cons_w_field = [C2,C7]
1091     sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
1092              | otherwise  = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
1093     mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
1094                                  (L loc (HsVar field_var))
1095     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
1096     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
1097     rec_field  = HsRecField { hsRecFieldId = sel_lname
1098                             , hsRecFieldArg = nlVarPat field_var
1099                             , hsRecPun = False }
1100     sel_lname = L loc sel_name
1101     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
1102
1103     -- Add catch-all default case unless the case is exhaustive
1104     -- We do this explicitly so that we get a nice error message that
1105     -- mentions this particular record selector
1106     deflt | not (any is_unused all_cons) = []
1107           | otherwise = [mkSimpleMatch [nlWildPat]
1108                             (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
1109                                      (nlHsLit msg_lit))]
1110
1111         -- Do not add a default case unless there are unmatched
1112         -- constructors.  We must take account of GADTs, else we
1113         -- get overlap warning messages from the pattern-match checker
1114     is_unused con = not (con `elem` cons_w_field
1115                          || dataConCannotMatch inst_tys con)
1116     inst_tys = tyConAppArgs data_ty
1117
1118     unit_rhs = mkLHsTupleExpr []
1119     msg_lit = HsStringPrim $ mkFastString $
1120               occNameString (getOccName sel_name)
1121
1122 ---------------
1123 tyConFields :: TyCon -> [FieldLabel]
1124 tyConFields tc
1125   | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
1126   | otherwise     = []
1127 \end{code}
1128
1129 Note [Polymorphic selectors]
1130 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1131 When a record has a polymorphic field, we pull the foralls out to the front.
1132    data T = MkT { f :: forall a. [a] -> a }
1133 Then f :: forall a. T -> [a] -> a
1134 NOT  f :: T -> forall a. [a] -> a
1135
1136 This is horrid.  It's only needed in deeply obscure cases, which I hate.
1137 The only case I know is test tc163, which is worth looking at.  It's far
1138 from clear that this test should succeed at all!
1139
1140 Note [Naughty record selectors]
1141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142 A "naughty" field is one for which we can't define a record
1143 selector, because an existential type variable would escape.  For example:
1144         data T = forall a. MkT { x,y::a }
1145 We obviously can't define
1146         x (MkT v _) = v
1147 Nevertheless we *do* put a RecSelId into the type environment
1148 so that if the user tries to use 'x' as a selector we can bleat
1149 helpfully, rather than saying unhelpfully that 'x' is not in scope.
1150 Hence the sel_naughty flag, to identify record selectors that don't really exist.
1151
1152 In general, a field is "naughty" if its type mentions a type variable that
1153 isn't in the result type of the constructor.  Note that this *allows*
1154 GADT record selectors (Note [GADT record selectors]) whose types may look
1155 like     sel :: T [a] -> a
1156
1157 For naughty selectors we make a dummy binding
1158    sel = ()
1159 for naughty selectors, so that the later type-check will add them to the
1160 environment, and they'll be exported.  The function is never called, because
1161 the tyepchecker spots the sel_naughty field.
1162
1163 Note [GADT record selectors]
1164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1165 For GADTs, we require that all constructors with a common field 'f' have the same
1166 result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
1167 E.g.
1168         data T where
1169           T1 { f :: Maybe a } :: T [a]
1170           T2 { f :: Maybe a, y :: b  } :: T [a]
1171
1172 and now the selector takes that result type as its argument:
1173    f :: forall a. T [a] -> Maybe a
1174
1175 Details: the "real" types of T1,T2 are:
1176    T1 :: forall r a.   (r~[a]) => a -> T r
1177    T2 :: forall r a b. (r~[a]) => a -> b -> T r
1178
1179 So the selector loooks like this:
1180    f :: forall a. T [a] -> Maybe a
1181    f (a:*) (t:T [a])
1182      = case t of
1183          T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
1184          T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
1185
1186 Note the forall'd tyvars of the selector are just the free tyvars
1187 of the result type; there may be other tyvars in the constructor's
1188 type (e.g. 'b' in T2).
1189
1190 Note the need for casts in the result!
1191
1192 Note [Selector running example]
1193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1194 It's OK to combine GADTs and type families.  Here's a running example:
1195
1196         data instance T [a] where
1197           T1 { fld :: b } :: T [Maybe b]
1198
1199 The representation type looks like this
1200         data :R7T a where
1201           T1 { fld :: b } :: :R7T (Maybe b)
1202
1203 and there's coercion from the family type to the representation type
1204         :CoR7T a :: T [a] ~ :R7T a
1205
1206 The selector we want for fld looks like this:
1207
1208         fld :: forall b. T [Maybe b] -> b
1209         fld = /\b. \(d::T [Maybe b]).
1210               case d `cast` :CoR7T (Maybe b) of
1211                 T1 (x::b) -> x
1212
1213 The scrutinee of the case has type :R7T (Maybe b), which can be
1214 gotten by appying the eq_spec to the univ_tvs of the data con.
1215
1216 %************************************************************************
1217 %*                                                                      *
1218                 Error messages
1219 %*                                                                      *
1220 %************************************************************************
1221
1222 \begin{code}
1223 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1224 resultTypeMisMatch field_name con1 con2
1225   = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1226                 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
1227           nest 2 $ ptext (sLit "but have different result types")]
1228
1229 fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1230 fieldTypeMisMatch field_name con1 con2
1231   = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1232          ptext (sLit "give different types for field"), quotes (ppr field_name)]
1233
1234 dataConCtxt :: Outputable a => a -> SDoc
1235 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
1236
1237 classOpCtxt :: Var -> Type -> SDoc
1238 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
1239                               nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
1240
1241 nullaryClassErr :: Class -> SDoc
1242 nullaryClassErr cls
1243   = ptext (sLit "No parameters for class")  <+> quotes (ppr cls)
1244
1245 classArityErr :: Class -> SDoc
1246 classArityErr cls
1247   = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
1248           parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
1249
1250 classFunDepsErr :: Class -> SDoc
1251 classFunDepsErr cls
1252   = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
1253           parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
1254
1255 noClassTyVarErr :: Class -> Var -> SDoc
1256 noClassTyVarErr clas op
1257   = sep [ptext (sLit "The class method") <+> quotes (ppr op),
1258          ptext (sLit "mentions none of the type variables of the class") <+>
1259                 ppr clas <+> hsep (map ppr (classTyVars clas))]
1260
1261 genericMultiParamErr :: Class -> SDoc
1262 genericMultiParamErr clas
1263   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
1264     ptext (sLit "cannot have generic methods")
1265
1266 recSynErr :: [LTyClDecl Name] -> TcRn ()
1267 recSynErr syn_decls
1268   = setSrcSpan (getLoc (head sorted_decls)) $
1269     addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
1270                  nest 2 (vcat (map ppr_decl sorted_decls))])
1271   where
1272     sorted_decls = sortLocated syn_decls
1273     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
1274
1275 recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
1276 recClsErr cls_decls
1277   = setSrcSpan (getLoc (head sorted_decls)) $
1278     addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
1279                  nest 2 (vcat (map ppr_decl sorted_decls))])
1280   where
1281     sorted_decls = sortLocated cls_decls
1282     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
1283
1284 sortLocated :: [Located a] -> [Located a]
1285 sortLocated things = sortLe le things
1286   where
1287     le (L l1 _) (L l2 _) = l1 <= l2
1288
1289 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
1290 badDataConTyCon data_con res_ty_tmpl actual_res_ty
1291   = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
1292                 ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
1293        2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
1294
1295 badGadtDecl :: Name -> SDoc
1296 badGadtDecl tc_name
1297   = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
1298          , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
1299
1300 badExistential :: Located Name -> SDoc
1301 badExistential con_name
1302   = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
1303                 ptext (sLit "has existential type variables, a context, or a specialised result type"))
1304        2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
1305
1306 badStupidTheta :: Name -> SDoc
1307 badStupidTheta tc_name
1308   = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
1309
1310 newtypeConError :: Name -> Int -> SDoc
1311 newtypeConError tycon n
1312   = sep [ptext (sLit "A newtype must have exactly one constructor,"),
1313          nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
1314
1315 newtypeExError :: DataCon -> SDoc
1316 newtypeExError con
1317   = sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
1318          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1319
1320 newtypeStrictError :: DataCon -> SDoc
1321 newtypeStrictError con
1322   = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
1323          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1324
1325 newtypePredError :: DataCon -> SDoc
1326 newtypePredError con
1327   = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
1328          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
1329
1330 newtypeFieldErr :: DataCon -> Int -> SDoc
1331 newtypeFieldErr con_name n_flds
1332   = sep [ptext (sLit "The constructor of a newtype must have exactly one field"),
1333          nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
1334
1335 badSigTyDecl :: Name -> SDoc
1336 badSigTyDecl tc_name
1337   = vcat [ ptext (sLit "Illegal kind signature") <+>
1338            quotes (ppr tc_name)
1339          , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
1340
1341 badFamInstDecl :: Outputable a => a -> SDoc
1342 badFamInstDecl tc_name
1343   = vcat [ ptext (sLit "Illegal family instance for") <+>
1344            quotes (ppr tc_name)
1345          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1346
1347 emptyConDeclsErr :: Name -> SDoc
1348 emptyConDeclsErr tycon
1349   = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
1350          nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]
1351 \end{code}