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