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