ghc/compiler/typecheck/TcTyClsDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcTyClsDecls]{Typecheck type and class declarations}
   5
   6 \begin{code}
   7 module TcTyClsDecls (
   8         tcTyAndClassDecls
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
  14                           ConDecl(..),   Sig(..), BangType(..), HsBang(..), NewOrData(..),
  15                           tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl,
  16                           LTyClDecl, tcdName, LHsTyVarBndr
  17                         )
  18 import BasicTypes       ( RecFlag(..), StrictnessMark(..) )
  19 import HscTypes         ( implicitTyThings, lookupFixity )
  20 import BuildTyCl        ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
  21                           mkDataTyConRhs, mkNewTyConRhs )
  22 import TcRnMonad
  23 import TcEnv            ( TcTyThing(..), TyThing(..),
  24                           tcLookupLocated, tcLookupLocatedGlobal,
  25                           tcExtendGlobalEnv, tcExtendKindEnv,
  26                           tcExtendRecEnv, tcLookupTyVar )
  27 import TcTyDecls        ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
  28 import TcClassDcl       ( tcClassSigs, tcAddDeclCtxt )
  29 import TcHsType         ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcHsType,
  30                           kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
  31 import TcMType          ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
  32                           UserTypeCtxt(..), SourceTyCtxt(..) )
  33 import TcUnify          ( unifyKind )
  34 import TcType           ( TcKind, ThetaType, TcType, tyVarsOfType,
  35                           mkArrowKind, liftedTypeKind,
  36                           tcSplitSigmaTy, tcEqType )
  37 import Type             ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
  38 import FieldLabel       ( fieldLabelName, fieldLabelType )
  39 import Generics         ( validGenericMethodType, canDoGenerics )
  40 import Class            ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
  41 import TyCon            ( TyCon, ArgVrcs,
  42                           tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
  43                           tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
  44 import DataCon          ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
  45 import Var              ( TyVar, idType, idName )
  46 import VarSet           ( elemVarSet )
  47 import Name             ( Name )
  48 import Outputable
  49 import Util             ( zipLazy, isSingleton, notNull )
  50 import List             ( partition )
  51 import SrcLoc           ( Located(..), unLoc, getLoc )
  52 import ListSetOps       ( equivClasses )
  53 import Digraph          ( SCC(..) )
  54 import CmdLineOpts      ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) )
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Type checking for type and class declarations}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 Dealing with a group
  65 ~~~~~~~~~~~~~~~~~~~~
  66 Consider a mutually-recursive group, binding
  67 a type constructor T and a class C.
  68
  69 Step 1:         getInitialKind
  70         Construct a KindEnv by binding T and C to a kind variable
  71
  72 Step 2:         kcTyClDecl
  73         In that environment, do a kind check
  74
  75 Step 3: Zonk the kinds
  76
  77 Step 4:         buildTyConOrClass
  78         Construct an environment binding T to a TyCon and C to a Class.
  79         a) Their kinds comes from zonking the relevant kind variable
  80         b) Their arity (for synonyms) comes direct from the decl
  81         c) The funcional dependencies come from the decl
  82         d) The rest comes a knot-tied binding of T and C, returned from Step 4
  83         e) The variances of the tycons in the group is calculated from
  84                 the knot-tied stuff
  85
  86 Step 5:         tcTyClDecl1
  87         In this environment, walk over the decls, constructing the TyCons and Classes.
  88         This uses in a strict way items (a)-(c) above, which is why they must
  89         be constructed in Step 4. Feed the results back to Step 4.
  90         For this step, pass the is-recursive flag as the wimp-out flag
  91         to tcTyClDecl1.
  92
  93
  94 Step 6:         Extend environment
  95         We extend the type environment with bindings not only for the TyCons and Classes,
  96         but also for their "implicit Ids" like data constructors and class selectors
  97
  98 Step 7:         checkValidTyCl
  99         For a recursive group only, check all the decls again, just
 100         to check all the side conditions on validity.  We could not
 101         do this before because we were in a mutually recursive knot.
 102
 103
 104 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 105 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 106
 107 \begin{code}
 108 tcTyAndClassDecls :: [LTyClDecl Name]
 109                    -> TcM TcGblEnv      -- Input env extended by types and classes
 110                                         -- and their implicit Ids,DataCons
 111 tcTyAndClassDecls decls
 112   = do  {       -- First check for cyclic type synonysm or classes
 113                 -- See notes with checkCycleErrs
 114           checkCycleErrs decls
 115
 116         ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
 117           do    { let { -- Calculate variances and rec-flag
 118                       ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
 119
 120                         -- Extend the global env with the knot-tied results
 121                         -- for data types and classes
 122                         --
 123                         -- We must populate the environment with the loop-tied T's right
 124                         -- away, because the kind checker may "fault in" some type
 125                         -- constructors that recursively mention T
 126                 ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss }
 127                 ; tcExtendRecEnv gbl_things $ do
 128
 129                         -- Kind-check the declarations
 130                 { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
 131
 132                 ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
 133                       ; calc_rec  = calcRecFlags     rec_alg_tyclss
 134                       ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
 135                         -- Type-check the type synonyms, and extend the envt
 136                 ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
 137                 ; tcExtendGlobalEnv syn_tycons $ do
 138
 139                         -- Type-check the data types and classes
 140                 { alg_tyclss <- mappM tc_decl kc_alg_decls
 141                 ; return (syn_tycons, alg_tyclss)
 142             }}})
 143         -- Finished with knot-tying now
 144         -- Extend the environment with the finished things
 145         ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
 146
 147         -- Perform the validity check
 148         { traceTc (text "ready for validity check")
 149         ; mappM_ (addLocM checkValidTyCl) decls
 150         ; traceTc (text "done")
 151
 152         -- Add the implicit things;
 153         -- we want them in the environment because
 154         -- they may be mentioned in interface files
 155         ; let { implicit_things = concatMap implicitTyThings alg_tyclss }
 156         ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things))
 157         ; tcExtendGlobalEnv implicit_things getGblEnv
 158     }}
 159
 160 mkGlobalThings :: [LTyClDecl Name]      -- The decls
 161                -> [TyThing]             -- Knot-tied, in 1-1 correspondence with the decls
 162                -> [(Name,TyThing)]
 163 -- Driven by the Decls, and treating the TyThings lazily
 164 -- make a TypeEnv for the new things
 165 mkGlobalThings decls things
 166   = map mk_thing (decls `zipLazy` things)
 167   where
 168     mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
 169          = (name, AClass cl)
 170     mk_thing (L _ decl, ~(ATyCon tc))
 171          = (tcdName decl, ATyCon tc)
 172 \end{code}
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177                 Kind checking
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 We need to kind check all types in the mutually recursive group
 182 before we know the kind of the type variables.  For example:
 183
 184 class C a where
 185    op :: D b => a -> b -> b
 186
 187 class D c where
 188    bop :: (Monad c) => ...
 189
 190 Here, the kind of the locally-polymorphic type variable "b"
 191 depends on *all the uses of class D*.  For example, the use of
 192 Monad c in bop's type signature means that D must have kind Type->Type.
 193
 194 However type synonyms work differently.  They can have kinds which don't
 195 just involve (->) and *:
 196         type R = Int#           -- Kind #
 197         type S a = Array# a     -- Kind * -> #
 198         type T a b = (# a,b #)  -- Kind * -> * -> (# a,b #)
 199 So we must infer their kinds from their right-hand sides *first* and then
 200 use them, whereas for the mutually recursive data types D we bring into
 201 scope kind bindings D -> k, where k is a kind variable, and do inference.
 202
 203 \begin{code}
 204 kcTyClDecls syn_decls alg_decls
 205   = do  {       -- First extend the kind env with each data
 206                 -- type and class, mapping them to a type variable
 207           alg_kinds <- mappM getInitialKind alg_decls
 208         ; tcExtendKindEnv alg_kinds $ do
 209
 210                 -- Now kind-check the type synonyms, in dependency order
 211                 -- We do these differently to data type and classes,
 212                 -- because a type synonym can be an unboxed type
 213                 --      type Foo = Int#
 214                 -- and a kind variable can't unify with UnboxedTypeKind
 215                 -- So we infer their kinds in dependency order
 216         { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
 217         ; tcExtendKindEnv syn_kinds $  do
 218
 219                 -- Now kind-check the data type and class declarations,
 220                 -- returning kind-annotated decls
 221         { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls
 222
 223         ; return (kc_syn_decls, kc_alg_decls) }}}
 224
 225 ------------------------------------------------------------------------
 226 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
 227
 228 getInitialKind decl
 229  = newKindVar                   `thenM` \ kind  ->
 230    returnM (unLoc (tcdLName (unLoc decl)), kind)
 231
 232 ----------------
 233 kcSynDecls :: [SCC (LTyClDecl Name)]
 234            -> TcM ([LTyClDecl Name],    -- Kind-annotated decls
 235                    [(Name,TcKind)])     -- Kind bindings
 236 kcSynDecls []
 237   = return ([], [])
 238 kcSynDecls (group : groups)
 239   = do  { (decl,  nk)  <- kcSynDecl group
 240         ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
 241         ; return (decl:decls, nk:nks) }
 242
 243 ----------------
 244 kcSynDecl :: SCC (LTyClDecl Name)
 245            -> TcM (LTyClDecl Name,      -- Kind-annotated decls
 246                    (Name,TcKind))       -- Kind bindings
 247 kcSynDecl (AcyclicSCC ldecl@(L loc decl))
 248   = tcAddDeclCtxt decl  $
 249     kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
 250     do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
 251                         <+> brackets (ppr k_tvs))
 252        ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
 253        ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
 254        ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
 255        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
 256                  (unLoc (tcdLName decl), tc_kind)) })
 257
 258 kcSynDecl (CyclicSCC decls)
 259   = do { recSynErr decls; failM }       -- Fail here to avoid error cascade
 260                                         -- of out-of-scope tycons
 261
 262 ------------------------------------------------------------------------
 263 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
 264         -- Not used for type synonyms (see kcSynDecl)
 265
 266 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 267   = kcTyClDeclBody decl $ \ tvs' ->
 268     do  { ctxt' <- kcHsContext ctxt
 269         ; cons' <- mappM (wrapLocM kc_con_decl) cons
 270         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
 271   where
 272     kc_con_decl (ConDecl name ex_tvs ex_ctxt details)
 273       = kcHsTyVars ex_tvs               $ \ ex_tvs' ->
 274         do { ex_ctxt' <- kcHsContext ex_ctxt
 275            ; details' <- kc_con_details details
 276            ; return (ConDecl name ex_tvs' ex_ctxt' details')}
 277
 278     kc_con_details (PrefixCon btys)
 279         = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
 280     kc_con_details (InfixCon bty1 bty2)
 281         = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
 282     kc_con_details (RecCon fields)
 283         = do { fields' <- mappM kc_field fields; return (RecCon fields') }
 284
 285     kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
 286
 287     kc_larg_ty = wrapLocM kc_arg_ty
 288
 289     kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') }
 290     kc_arg_ty_body = case new_or_data of
 291                          DataType -> kcHsSigType
 292                          NewType  -> kcHsLiftedSigType
 293             -- Can't allow an unlifted type for newtypes, because we're effectively
 294             -- going to remove the constructor while coercing it to a lifted type.
 295
 296 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
 297   = kcTyClDeclBody decl $ \ tvs' ->
 298     do  { ctxt' <- kcHsContext ctxt
 299         ; sigs' <- mappM (wrapLocM kc_sig) sigs
 300         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
 301   where
 302     kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
 303                                 ; return (Sig nm op_ty') }
 304     kc_sig other_sig          = return other_sig
 305
 306 kcTyClDecl decl@(ForeignType {})
 307   = return decl
 308
 309 kcTyClDeclBody :: TyClDecl Name
 310                -> ([LHsTyVarBndr Name] -> TcM a)
 311                -> TcM a
 312   -- Extend the env with bindings for the tyvars, taken from
 313   -- the kind of the tycon/class.  Give it to the thing inside, and
 314   -- check the result kind matches
 315 kcTyClDeclBody decl thing_inside
 316   = tcAddDeclCtxt decl          $
 317     kcHsTyVars (tyClDeclTyVars decl)    $ \ kinded_tvs ->
 318     do  { tc_ty_thing <- tcLookupLocated (tcdLName decl)
 319         ; let tc_kind = case tc_ty_thing of { AThing k -> k }
 320         ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind)
 321                                    liftedTypeKind kinded_tvs)
 322         ; thing_inside kinded_tvs }
 323
 324 kindedTyVarKind (L _ (KindedTyVar _ k)) = k
 325 \end{code}
 326
 327
 328 %************************************************************************
 329 %*                                                                      *
 330 \subsection{Type checking}
 331 %*                                                                      *
 332 %************************************************************************
 333
 334 \begin{code}
 335 tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
 336 tcSynDecls calc_vrcs [] = return []
 337 tcSynDecls calc_vrcs (decl : decls)
 338   = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
 339        ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
 340        ; return (syn_tc : syn_tcs) }
 341
 342 tcSynDecl calc_vrcs
 343   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
 344   = tcTyVarBndrs tvs            $ \ tvs' -> do
 345     { traceTc (text "tcd1" <+> ppr tc_name)
 346     ; rhs_ty' <- tcHsKindedType rhs_ty
 347     ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }
 348
 349 --------------------
 350 tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
 351            -> TyClDecl Name -> TcM TyThing
 352
 353 tcTyClDecl calc_vrcs calc_isrec decl
 354   = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
 355
 356 tcTyClDecl1 calc_vrcs calc_isrec
 357   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 358            tcdLName = L _ tc_name, tcdCons = cons})
 359   = tcTyVarBndrs tvs            $ \ tvs' -> do
 360   { ctxt'        <- tcHsKindedContext ctxt
 361   ; want_generic <- doptM Opt_Generics
 362   ; tycon <- fixM (\ tycon -> do
 363         { data_cons <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
 364         ; let tc_rhs = case new_or_data of
 365                         DataType -> mkDataTyConRhs data_cons
 366                         NewType  -> ASSERT( isSingleton data_cons )
 367                                     mkNewTyConRhs (head data_cons)
 368         ; buildAlgTyCon tc_name tvs' ctxt'
 369                         tc_rhs arg_vrcs is_rec
 370                         (want_generic && canDoGenerics data_cons)
 371         })
 372   ; return (ATyCon tycon)
 373   }
 374   where
 375     arg_vrcs = calc_vrcs tc_name
 376     is_rec   = calc_isrec tc_name
 377
 378 tcTyClDecl1 calc_vrcs calc_isrec
 379   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
 380               tcdCtxt = ctxt, tcdMeths = meths,
 381               tcdFDs = fundeps, tcdSigs = sigs} )
 382   = tcTyVarBndrs tvs            $ \ tvs' -> do
 383   { ctxt' <- tcHsKindedContext ctxt
 384   ; fds' <- mappM (addLocM tc_fundep) fundeps
 385   ; sig_stuff <- tcClassSigs class_name sigs meths
 386   ; clas <- fixM (\ clas ->
 387                 let     -- This little knot is just so we can get
 388                         -- hold of the name of the class TyCon, which we
 389                         -- need to look up its recursiveness and variance
 390                     tycon_name = tyConName (classTyCon clas)
 391                     tc_isrec = calc_isrec tycon_name
 392                     tc_vrcs  = calc_vrcs  tycon_name
 393                 in
 394                 buildClass class_name tvs' ctxt' fds'
 395                            sig_stuff tc_isrec tc_vrcs)
 396   ; return (AClass clas) }
 397   where
 398     tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
 399                                 ; tvs2' <- mappM tcLookupTyVar tvs2 ;
 400                                 ; return (tvs1', tvs2') }
 401
 402
 403 tcTyClDecl1 calc_vrcs calc_isrec
 404   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
 405   = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
 406
 407 -----------------------------------
 408 tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType
 409           -> ConDecl Name -> TcM DataCon
 410
 411 tcConDecl new_or_data tycon tyvars ctxt
 412            (ConDecl name ex_tvs ex_ctxt details)
 413   = tcTyVarBndrs ex_tvs         $ \ ex_tvs' -> do
 414     { ex_ctxt' <- tcHsKindedContext ex_ctxt
 415     ; unbox_strict <- doptM Opt_UnboxStrictFields
 416     ; let
 417         tc_datacon is_infix field_lbls btys
 418           = do { let { ubtys = map unLoc btys }
 419                ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
 420                ; buildDataCon (unLoc name) is_infix
 421                     (argStrictness unbox_strict tycon ubtys arg_tys)
 422                     (map unLoc field_lbls)
 423                     tyvars ctxt ex_tvs' ex_ctxt'
 424                     arg_tys tycon }
 425     ; case details of
 426         PrefixCon btys     -> tc_datacon False [] btys
 427         InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
 428         RecCon fields      -> do { checkTc (null ex_tvs') (exRecConErr name)
 429                                  ; let { (field_names, btys) = unzip fields }
 430                                  ; tc_datacon False field_names btys } }
 431
 432 argStrictness :: Bool           -- True <=> -funbox-strict_fields
 433               -> TyCon -> [BangType Name]
 434               -> [TcType] -> [StrictnessMark]
 435 argStrictness unbox_strict tycon btys arg_tys
 436  = zipWith (chooseBoxingStrategy unbox_strict tycon)
 437            arg_tys
 438            (map getBangStrictness btys ++ repeat HsNoBang)
 439
 440 -- We attempt to unbox/unpack a strict field when either:
 441 --   (i)  The field is marked '!!', or
 442 --   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
 443
 444 chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
 445 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
 446   = case bang of
 447         HsNoBang                                    -> NotMarkedStrict
 448         HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
 449         HsUnbox  | can_unbox                        -> MarkedUnboxed
 450         other                                       -> MarkedStrict
 451   where
 452     can_unbox = case splitTyConApp_maybe arg_ty of
 453                    Nothing             -> False
 454                    Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
 455                                           isProductTyCon arg_tycon
 456 \end{code}
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Dependency analysis}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 Validity checking is done once the mutually-recursive knot has been
 465 tied, so we can look at things freely.
 466
 467 \begin{code}
 468 checkCycleErrs :: [LTyClDecl Name] -> TcM ()
 469 checkCycleErrs tyclss
 470   | null cls_cycles
 471   = return ()
 472   | otherwise
 473   = do  { mappM_ recClsErr cls_cycles
 474         ; failM }       -- Give up now, because later checkValidTyCl
 475                         -- will loop if the synonym is recursive
 476   where
 477     cls_cycles = calcClassCycles tyclss
 478
 479 checkValidTyCl :: TyClDecl Name -> TcM ()
 480 -- We do the validity check over declarations, rather than TyThings
 481 -- only so that we can add a nice context with tcAddDeclCtxt
 482 checkValidTyCl decl
 483   = tcAddDeclCtxt decl $
 484     do  { thing <- tcLookupLocatedGlobal (tcdLName decl)
 485         ; traceTc (text "Validity of" <+> ppr thing)
 486         ; case thing of
 487             ATyCon tc -> checkValidTyCon tc
 488             AClass cl -> checkValidClass cl
 489         ; traceTc (text "Done validity of" <+> ppr thing)
 490         }
 491
 492 -------------------------
 493 checkValidTyCon :: TyCon -> TcM ()
 494 checkValidTyCon tc
 495   | isSynTyCon tc
 496   = checkValidType syn_ctxt syn_rhs
 497   | otherwise
 498   =     -- Check the context on the data decl
 499     checkValidTheta (DataTyCtxt name) (tyConTheta tc)   `thenM_`
 500
 501         -- Check arg types of data constructors
 502     mappM_ checkValidDataCon data_cons                  `thenM_`
 503
 504         -- Check that fields with the same name share a type
 505     mappM_ check_fields groups
 506
 507   where
 508     syn_ctxt     = TySynCtxt name
 509     name         = tyConName tc
 510     (_, syn_rhs) = getSynTyConDefn tc
 511     data_cons    = tyConDataCons tc
 512
 513     fields = [field | con <- data_cons, field <- dataConFieldLabels con]
 514     groups = equivClasses cmp_name fields
 515     cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
 516
 517     check_fields fields@(first_field_label : other_fields)
 518         -- These fields all have the same name, but are from
 519         -- different constructors in the data type
 520         =       -- Check that all the fields in the group have the same type
 521                 -- NB: this check assumes that all the constructors of a given
 522                 -- data type use the same type variables
 523           checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
 524         where
 525             field_ty   = fieldLabelType first_field_label
 526             field_name = fieldLabelName first_field_label
 527             other_tys  = map fieldLabelType other_fields
 528
 529 -------------------------------
 530 checkValidDataCon :: DataCon -> TcM ()
 531 checkValidDataCon con
 532   = addErrCtxt (dataConCtxt con) (
 533       checkValidType ctxt (idType (dataConWrapId con))  `thenM_`
 534                 -- This checks the argument types and
 535                 -- ambiguity of the existential context (if any)
 536       checkFreeness ex_tvs ex_theta)
 537   where
 538     ctxt = ConArgCtxt (dataConName con)
 539     (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
 540
 541
 542 -------------------------------
 543 checkValidClass :: Class -> TcM ()
 544 checkValidClass cls
 545   = do  {       -- CHECK ARITY 1 FOR HASKELL 1.4
 546           gla_exts <- doptM Opt_GlasgowExts
 547
 548         -- Check that the class is unary, unless GlaExs
 549         ; checkTc (notNull tyvars) (nullaryClassErr cls)
 550         ; checkTc (gla_exts || unary) (classArityErr cls)
 551
 552         -- Check the super-classes
 553         ; checkValidTheta (ClassSCCtxt (className cls)) theta
 554
 555         -- Check the class operations
 556         ; mappM_ check_op op_stuff
 557
 558         -- Check that if the class has generic methods, then the
 559         -- class has only one parameter.  We can't do generic
 560         -- multi-parameter type classes!
 561         ; checkTc (unary || no_generics) (genericMultiParamErr cls)
 562         }
 563   where
 564     (tyvars, theta, _, op_stuff) = classBigSig cls
 565     unary       = isSingleton tyvars
 566     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 567
 568     check_op (sel_id, dm)
 569       = addErrCtxt (classOpCtxt sel_id tau) $ do
 570         { checkValidTheta SigmaCtxt (tail theta)
 571                 -- The 'tail' removes the initial (C a) from the
 572                 -- class itself, leaving just the method type
 573
 574         ; checkValidType (FunSigCtxt op_name) tau
 575
 576                 -- Check that the type mentions at least one of
 577                 -- the class type variables
 578         ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
 579                   (noClassTyVarErr cls sel_id)
 580
 581                 -- Check that for a generic method, the type of
 582                 -- the method is sufficiently simple
 583         ; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
 584                   (badGenericMethodType op_name op_ty)
 585         }
 586         where
 587           op_name = idName sel_id
 588           op_ty   = idType sel_id
 589           (_,theta,tau) = tcSplitSigmaTy op_ty
 590
 591
 592
 593 ---------------------------------------------------------------------
 594 fieldTypeMisMatch field_name
 595   = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
 596
 597 dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
 598                        nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
 599   where
 600     (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
 601     ex_part | null ex_tvs = empty
 602             | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
 603         -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
 604         --      data T a = Eq a => T a a
 605         -- So we make sure to print it
 606
 607     fields = dataConFieldLabels con
 608     arg_part | null fields = sep (map pprParendType arg_tys)
 609              | otherwise   = braces (sep (punctuate comma
 610                              [ ppr n <+> dcolon <+> ppr ty
 611                              | (n,ty) <- fields `zip` arg_tys]))
 612
 613 classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
 614                               nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
 615
 616 nullaryClassErr cls
 617   = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
 618
 619 classArityErr cls
 620   = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
 621           parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 622
 623 noClassTyVarErr clas op
 624   = sep [ptext SLIT("The class method") <+> quotes (ppr op),
 625          ptext SLIT("mentions none of the type variables of the class") <+>
 626                 ppr clas <+> hsep (map ppr (classTyVars clas))]
 627
 628 genericMultiParamErr clas
 629   = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
 630     ptext SLIT("cannot have generic methods")
 631
 632 badGenericMethodType op op_ty
 633   = hang (ptext SLIT("Generic method type is too complex"))
 634        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 635                 ptext SLIT("You can only use type variables, arrows, and tuples")])
 636
 637 recSynErr syn_decls
 638   = addSrcSpan (getLoc (head syn_decls)) $
 639     addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
 640                  nest 2 (vcat (map ppr_decl syn_decls))])
 641   where
 642     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
 643
 644 recClsErr cls_decls
 645   = addSrcSpan (getLoc (head cls_decls)) $
 646     addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
 647                  nest 2 (vcat (map ppr_decl cls_decls))])
 648   where
 649     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
 650
 651 exRecConErr name
 652   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 653     $$
 654     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 655 \end{code}