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