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