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