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(..),
  14                           ConDecl(..),   Sig(..), HsPred(..),
  15                           tyClDeclName, hsTyVarNames, tyClDeclTyVars,
  16                           isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
  17                         )
  18 import RnHsSyn          ( RenamedTyClDecl, tyClDeclFVs )
  19 import RnEnv            ( lookupSysName )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  21 import HscTypes         ( implicitTyThings )
  22
  23 import TcRnMonad
  24 import TcEnv            ( TcTyThing(..), TyThing(..), TyThingDetails(..),
  25                           tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
  26                           isLocalThing )
  27 import TcTyDecls        ( tcTyDecl, kcConDetails )
  28 import TcClassDcl       ( tcClassDecl1 )
  29 import TcInstDcls       ( tcAddDeclCtxt )
  30 import TcMonoType       ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
  31 import TcMType          ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
  32 import TcUnify          ( unifyKind )
  33 import TcType           ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
  34 import Type             ( splitTyConApp_maybe )
  35 import Variance         ( calcTyConArgVrcs )
  36 import Class            ( Class, mkClass, classTyCon )
  37 import TyCon            ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
  38                           tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
  39                           mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon
  40                         )
  41 import TysWiredIn       ( unitTy )
  42 import Subst            ( substTyWith )
  43 import DataCon          ( dataConOrigArgTys )
  44 import Var              ( varName )
  45 import OccName          ( mkClassTyConOcc )
  46 import FiniteMap
  47 import Digraph          ( stronglyConnComp, SCC(..) )
  48 import Name             ( Name )
  49 import NameEnv
  50 import NameSet
  51 import Outputable
  52 import Maybes           ( mapMaybe, orElse, catMaybes )
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{Type checking for type and class declarations}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 The main function
  63 ~~~~~~~~~~~~~~~~~
  64 \begin{code}
  65 tcTyAndClassDecls :: [RenamedTyClDecl]
  66                   -> TcM TcGblEnv       -- Returns extended environment
  67
  68 tcTyAndClassDecls decls
  69   = do { edge_map <- mkEdgeMap tc_decls ;
  70          let { edges = mkEdges edge_map tc_decls } ;
  71          tcGroups edge_map (stronglyConnComp edges) }
  72   where
  73     tc_decls = filter isTypeOrClassDecl decls
  74
  75 tcGroups edge_map [] = getGblEnv
  76
  77 tcGroups edge_map (group:groups)
  78   = tcGroup edge_map group      `thenM` \ env ->
  79     setGblEnv env               $
  80     tcGroups edge_map groups
  81 \end{code}
  82
  83 Dealing with a group
  84 ~~~~~~~~~~~~~~~~~~~~
  85 Consider a mutually-recursive group, binding
  86 a type constructor T and a class C.
  87
  88 Step 1:         getInitialKind
  89         Construct a KindEnv by binding T and C to a kind variable
  90
  91 Step 2:         kcTyClDecl
  92         In that environment, do a kind check
  93
  94 Step 3: Zonk the kinds
  95
  96 Step 4:         buildTyConOrClass
  97         Construct an environment binding T to a TyCon and C to a Class.
  98         a) Their kinds comes from zonking the relevant kind variable
  99         b) Their arity (for synonyms) comes direct from the decl
 100         c) The funcional dependencies come from the decl
 101         d) The rest comes a knot-tied binding of T and C, returned from Step 4
 102         e) The variances of the tycons in the group is calculated from
 103                 the knot-tied stuff
 104
 105 Step 5:         tcTyClDecl1
 106         In this environment, walk over the decls, constructing the TyCons and Classes.
 107         This uses in a strict way items (a)-(c) above, which is why they must
 108         be constructed in Step 4. Feed the results back to Step 4.
 109         For this step, pass the is-recursive flag as the wimp-out flag
 110         to tcTyClDecl1.
 111
 112
 113 Step 6:         Extend environment
 114         We extend the type environment with bindings not only for the TyCons and Classes,
 115         but also for their "implicit Ids" like data constructors and class selectors
 116
 117 Step 7:         checkValidTyCl
 118         For a recursive group only, check all the decls again, just
 119         to check all the side conditions on validity.  We could not
 120         do this before because we were in a mutually recursive knot.
 121
 122
 123 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 124 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 125
 126 \begin{code}
 127 tcGroup :: EdgeMap -> SCC RenamedTyClDecl
 128         -> TcM TcGblEnv         -- Input env extended by types and classes
 129                                 -- and their implicit Ids,DataCons
 130
 131 tcGroup edge_map scc
 132   =     -- Step 1
 133     mappM getInitialKind decls          `thenM` \ initial_kinds ->
 134
 135         -- Step 2
 136     tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls)      `thenM_`
 137
 138         -- Step 3
 139     zonkKindEnv initial_kinds           `thenM` \ final_kinds ->
 140
 141         -- Check for loops; if any are found, bale out now
 142         -- because the compiler itself will loop otherwise!
 143     checkNoErrs (checkLoops edge_map scc)       `thenM` \ is_rec_tycon ->
 144
 145         -- Tie the knot
 146     traceTc (text "starting" <+> ppr final_kinds)               `thenM_`
 147     fixM ( \ ~(rec_details_list, _, _) ->
 148                 -- Step 4
 149         let
 150             kind_env    = mkNameEnv final_kinds
 151             rec_details = mkNameEnv rec_details_list
 152
 153                 -- Calculate variances, and feed into buildTyConOrClass
 154             rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss]
 155
 156             build_one = buildTyConOrClass is_rec_tycon kind_env
 157                                           rec_vrcs rec_details
 158             tyclss = map build_one decls
 159
 160         in
 161                 -- Step 5
 162                 -- Extend the environment with the final
 163                 -- TyCons/Classes and check the decls
 164         tcExtendGlobalEnv tyclss        $
 165         mappM tcTyClDecl1 decls         `thenM` \ tycls_details ->
 166
 167                 -- Return results
 168         getGblEnv                               `thenM` \ env ->
 169         returnM (tycls_details, env, tyclss)
 170     )                                           `thenM` \ (_, env, tyclss) ->
 171
 172         -- Step 7: Check validity
 173     setGblEnv env                               $
 174
 175     traceTc (text "ready for validity check")   `thenM_`
 176     getModule                                   `thenM` \ mod ->
 177     mappM_ (checkValidTyCl mod) decls           `thenM_`
 178     traceTc (text "done")                       `thenM_`
 179
 180     let         -- Add the tycons that come from the classes
 181                 -- We want them in the environment because
 182                 -- they are mentioned in interface files
 183         implicit_things = implicitTyThings tyclss
 184     in
 185     traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things))    `thenM_`
 186     tcExtendGlobalEnv implicit_things getGblEnv
 187
 188   where
 189     decls = case scc of
 190                 AcyclicSCC decl -> [decl]
 191                 CyclicSCC decls -> decls
 192
 193 tcTyClDecl1 decl
 194   | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
 195   | otherwise        = tcAddDeclCtxt decl (tcTyDecl     decl)
 196
 197 -- We do the validity check over declarations, rather than TyThings
 198 -- only so that we can add a nice context with tcAddDeclCtxt
 199 checkValidTyCl this_mod decl
 200   = tcLookupGlobal (tcdName decl)       `thenM` \ thing ->
 201     if not (isLocalThing this_mod thing) then
 202         -- Don't bother to check validity for non-local things
 203         returnM ()
 204     else
 205     tcAddDeclCtxt decl $
 206     case thing of
 207         ATyCon tc -> checkValidTyCon tc
 208         AClass cl -> checkValidClass cl
 209 \end{code}
 210
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{Step 1: Initial environment}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
 220 getInitialKind decl
 221  = kcHsTyVars (tyClDeclTyVars decl)     `thenM` \ arg_kinds ->
 222    newKindVar                           `thenM` \ result_kind  ->
 223    returnM (tcdName decl, mk_kind arg_kinds result_kind)
 224
 225 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{Step 2: Kind checking}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 We need to kind check all types in the mutually recursive group
 236 before we know the kind of the type variables.  For example:
 237
 238 class C a where
 239    op :: D b => a -> b -> b
 240
 241 class D c where
 242    bop :: (Monad c) => ...
 243
 244 Here, the kind of the locally-polymorphic type variable "b"
 245 depends on *all the uses of class D*.  For example, the use of
 246 Monad c in bop's type signature means that D must have kind Type->Type.
 247
 248 \begin{code}
 249 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 250
 251 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
 252   = kcTyClDeclBody decl         $ \ result_kind ->
 253     kcHsType rhs                `thenM` \ rhs_kind ->
 254     unifyKind result_kind rhs_kind
 255
 256 kcTyClDecl (ForeignType {}) = returnM ()
 257
 258 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
 259   = kcTyClDeclBody decl                 $ \ result_kind ->
 260     kcHsContext context                 `thenM_`
 261     mappM_ kc_con_decl (visibleDataCons con_decls)
 262   where
 263     kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
 264       = kcHsTyVars ex_tvs               `thenM` \ kind_env ->
 265         tcExtendKindEnv kind_env        $
 266         kcConDetails new_or_data ex_ctxt details
 267
 268 kcTyClDecl decl@(ClassDecl {tcdCtxt = context,  tcdSigs = class_sigs})
 269   = kcTyClDeclBody decl         $ \ result_kind ->
 270     kcHsContext context         `thenM_`
 271     mappM_ kc_sig (filter isClassOpSig class_sigs)
 272   where
 273     kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
 274
 275 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
 276 -- Extend the env with bindings for the tyvars, taken from
 277 -- the kind of the tycon/class.  Give it to the thing inside, and
 278 -- check the result kind matches
 279 kcTyClDeclBody decl thing_inside
 280   = tcAddDeclCtxt decl          $
 281     tcLookup (tcdName decl)     `thenM` \ thing ->
 282     let
 283         kind = case thing of
 284                   AGlobal (ATyCon tc) -> tyConKind tc
 285                   AGlobal (AClass cl) -> tyConKind (classTyCon cl)
 286                   AThing kind         -> kind
 287                 -- For some odd reason, a class doesn't include its kind
 288
 289         (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
 290     in
 291     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 292 \end{code}
 293
 294
 295
 296 %************************************************************************
 297 %*                                                                      *
 298 \subsection{Step 4: Building the tycon/class}
 299 %*                                                                      *
 300 %************************************************************************
 301
 302 \begin{code}
 303 buildTyConOrClass
 304         :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
 305         -> NameEnv Kind
 306         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 307         -> RenamedTyClDecl -> TyThing
 308
 309 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
 310     (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
 311   = ATyCon tycon
 312   where
 313         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 314         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 315         arity               = length tyvar_names
 316         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 317         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 318         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 319
 320 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
 321     (TyData {tcdND = data_or_new, tcdName = tycon_name,
 322              tcdTyVars = tyvar_names})
 323   = ATyCon tycon
 324   where
 325         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 326                            data_cons sel_ids flavour
 327                            (rec_tycon tycon_name flavour) gen_info
 328
 329         DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
 330
 331         tycon_kind = lookupNameEnv_NF kenv tycon_name
 332         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 333         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 334
 335         -- Watch out!  mkTyConApp asks whether the tycon is a NewType,
 336         -- so flavour has to be able to answer this question without consulting rec_details
 337         flavour = case data_or_new of
 338                     NewType  -> NewTyCon (mkNewTyConRep tycon)
 339                     DataType | all_nullary data_cons -> EnumTyCon
 340                              | otherwise             -> DataTyCon
 341
 342         all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
 343         all_nullary other           = False     -- Safe choice for unknown data types
 344                         -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
 345                         -- but that looks at the *representation* arity, and that in turn
 346                         -- depends on deciding whether to unpack the args, and that
 347                         -- depends on whether it's a data type or a newtype --- so
 348                         -- in the recursive case we can get a loop.  This version is simple!
 349
 350 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
 351   (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
 352   = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
 353
 354 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
 355   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
 356   = AClass clas
 357   where
 358         clas = mkClass class_name tyvars fds
 359                        sc_theta sc_sel_ids op_items
 360                        tycon
 361
 362         tycon = mkClassTyCon tycon_name class_kind tyvars
 363                              argvrcs dict_con
 364                              clas               -- Yes!  It's a dictionary
 365                              flavour
 366                              (rec_tycon class_name flavour)
 367                 -- A class can be recursive, and in the case of newtypes
 368                 -- this matters.  For example
 369                 --      class C a where { op :: C b => a -> b -> Int }
 370                 -- Because C has only one operation, it is represented by
 371                 -- a newtype, and it should be a *recursive* newtype.
 372                 -- [If we don't make it a recursive newtype, we'll expand the
 373                 -- newtype like a synonym, but that will lead toan inifinite type
 374
 375         ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
 376                 = lookupNameEnv_NF rec_details class_name
 377
 378         class_kind = lookupNameEnv_NF kenv class_name
 379         tyvars     = mkTyClTyVars class_kind tyvar_names
 380         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 381
 382         flavour = case dataConOrigArgTys dict_con of
 383                         -- The tyvars in the datacon are the same as in the class
 384                     [rep_ty] -> NewTyCon rep_ty
 385                     other    -> DataTyCon
 386
 387         -- We can find the functional dependencies right away,
 388         -- and it is vital to do so. Why?  Because in the next pass
 389         -- we check for ambiguity in all the type signatures, and we
 390         -- need the functional dependcies to be done by then
 391         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 392         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 393         lookup     = lookupNameEnv_NF tyvar_env
 394
 395 bogusVrcs = panic "Bogus tycon arg variances"
 396 \end{code}
 397
 398 \begin{code}
 399 mkNewTyConRep :: TyCon          -- The original type constructor
 400               -> Type           -- Chosen representation type
 401                                 -- (guaranteed not to be another newtype)
 402
 403 -- Find the representation type for this newtype TyCon
 404 -- Remember that the representation type is the ultimate representation
 405 -- type, looking through other newtypes.
 406 --
 407 -- The non-recursive newtypes are easy, because they look transparent
 408 -- to splitTyConApp_maybe, but recursive ones really are represented as
 409 -- TyConApps (see TypeRep).
 410 --
 411 -- The trick is to to deal correctly with recursive newtypes
 412 -- such as      newtype T = MkT T
 413
 414 -- a newtype with no data constructors -- appears in External Core programs
 415 mkNewTyConRep tc | (null (tyConDataCons tc)) = unitTy
 416 mkNewTyConRep tc
 417   = go [] tc
 418   where
 419         -- Invariant: tc is a NewTyCon
 420         --            tcs have been seen before
 421     go tcs tc
 422         | tc `elem` tcs = unitTy
 423         | otherwise
 424         = let
 425               rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
 426           in
 427           case splitTyConApp_maybe rep_ty of
 428                         Nothing -> rep_ty
 429                         Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
 430                                         | otherwise            -> go1 (tc:tcs) tc' tys
 431
 432     go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection{Dependency analysis}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 Dependency analysis
 442 ~~~~~~~~~~~~~~~~~~~
 443 \begin{code}
 444 checkLoops :: EdgeMap -> SCC RenamedTyClDecl
 445            -> TcM (Name -> AlgTyConFlavour -> RecFlag)
 446 -- Check for illegal loops in a single strongly-connected component
 447 --      a) type synonyms
 448 --      b) superclass hierarchy
 449 --
 450 -- Also return a function that says which tycons are recursive.
 451 -- Remember:
 452 --      a newtype is recursive if it is part of a recursive
 453 --      group consisting only of newtype and synonyms
 454
 455 checkLoops edge_map (AcyclicSCC _)
 456   = returnM (\ _ _ -> NonRecursive)
 457
 458 checkLoops edge_map (CyclicSCC decls)
 459   = let         -- CHECK FOR CLASS CYCLES
 460         cls_edges  = mapMaybe mkClassEdges decls
 461         cls_cycles = findCycles cls_edges
 462     in
 463     mapM_ (cycleErr "class") cls_cycles         `thenM_`
 464
 465     let         -- CHECK FOR SYNONYM CYCLES
 466         syn_edges  = mkEdges edge_map (filter isSynDecl decls)
 467         syn_cycles = findCycles syn_edges
 468     in
 469     mapM_ (cycleErr "type synonym") syn_cycles  `thenM_`
 470
 471     let         -- CHECK FOR NEWTYPE CYCLES
 472         newtype_edges  = mkEdges edge_map (filter is_nt_cycle_decl decls)
 473         newtype_cycles = findCycles newtype_edges
 474         rec_newtypes   = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
 475
 476         rec_tycon name (NewTyCon _)
 477           | name `elemNameSet` rec_newtypes = Recursive
 478           | otherwise                       = NonRecursive
 479         rec_tycon name other_flavour = Recursive
 480     in
 481     returnM rec_tycon
 482
 483 ----------------------------------------------------
 484 -- A class with one op and no superclasses, or vice versa,
 485 --              is treated just like a newtype.
 486 -- It's a bit unclean that this test is repeated in buildTyConOrClass
 487 is_nt_cycle_decl (TySynonym {})                              = True
 488 is_nt_cycle_decl (TyData {tcdND = NewType})                  = True
 489 is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
 490 is_nt_cycle_decl other                                       = False
 491
 492 ----------------------------------------------------
 493 findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
 494
 495 ----------------------------------------------------
 496 --              Building edges for SCC analysis
 497 --
 498 -- When building the edges, we treat the 'main name' of the declaration as the
 499 -- key for the node, but when dealing with External Core we may come across
 500 -- references to one of the implicit names for the declaration.  For example:
 501 --      class Eq a where ....
 502 --      data :TSig a = :TSig (:TEq a) ....
 503 -- The first decl is sucked in from an interface file; the second
 504 -- is in an External Core file, generated from a class decl for Sig.
 505 -- We have to recognise that the reference to :TEq represents a
 506 -- dependency on the class Eq declaration, else the SCC stuff won't work right.
 507 --
 508 -- This complication can only happen when consuming an External Core file
 509 --
 510 -- Solution: keep an "EdgeMap" (bad name) that maps :TEq -> Eq.
 511 -- Don't worry about data constructors, because we're only building
 512 -- SCCs for type and class declarations here.  So the tiresome mapping
 513 -- is need only to map   [class tycon -> class]
 514
 515 type EdgeMap = NameEnv Name
 516
 517 mkEdgeMap :: [RenamedTyClDecl] -> TcM EdgeMap
 518 mkEdgeMap decls = do { mb_pairs <- mapM mk_mb_pair decls ;
 519                        return (mkNameEnv (catMaybes mb_pairs)) }
 520                 where
 521                   mk_mb_pair (ClassDecl { tcdName = cls_name })
 522                         = do { tc_name <- lookupSysName cls_name mkClassTyConOcc ;
 523                                return (Just (tc_name, cls_name)) }
 524                   mk_mb_pair other = return Nothing
 525
 526 mkEdges :: EdgeMap -> [RenamedTyClDecl] -> [(RenamedTyClDecl, Name, [Name])]
 527 -- We use the EdgeMap to map any implicit names to
 528 -- the 'main name' for the declaration
 529 mkEdges edge_map decls
 530   = [ (decl, tyClDeclName decl, get_refs decl) | decl <- decls ]
 531   where
 532     get_refs decl = [ lookupNameEnv edge_map n `orElse` n
 533                     | n <- nameSetToList (tyClDeclFVs decl) ]
 534
 535 ----------------------------------------------------
 536 -- mk_cls_edges looks only at the context of class decls
 537 -- Its used when we are figuring out if there's a cycle in the
 538 -- superclass hierarchy
 539
 540 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 541 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
 542 mkClassEdges other_decl                                        = Nothing
 543 \end{code}
 544
 545
 546 %************************************************************************
 547 %*                                                                      *
 548 \subsection{Error management
 549 %*                                                                      *
 550 %************************************************************************
 551
 552 \begin{code}
 553 cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
 554
 555 cycleErr kind_of_decl decls
 556   = addErrAt loc (ppr_cycle kind_of_decl decls)
 557   where
 558     loc = tcdLoc (head decls)
 559
 560 ppr_cycle kind_of_decl decls
 561   = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
 562          4 (vcat (map pp_decl decls))
 563   where
 564     pp_decl decl = hsep [quotes (ppr (tcdName decl)),
 565                          ptext SLIT("at"), ppr (tcdLoc decl)]
 566 \end{code}