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