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