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          ( unifyKind, newKindVar, zonkKindEnv )
  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(..),
  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 FiniteMap
  46 import Digraph          ( stronglyConnComp, SCC(..) )
  47 import Name             ( Name, getSrcLoc, isTyVarName )
  48 import NameEnv
  49 import NameSet
  50 import Outputable
  51 import Maybes           ( mapMaybe )
  52 import ErrUtils         ( Message )
  53 import HsDecls          ( getClassDeclSysNames )
  54 import Generics         ( mkTyConGenInfo )
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Type checking for type and class declarations}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 The main function
  65 ~~~~~~~~~~~~~~~~~
  66 \begin{code}
  67 tcTyAndClassDecls :: RecTcEnv           -- Knot tying stuff
  68                   -> Module             -- Current module
  69                   -> [RenamedTyClDecl]
  70                   -> TcM TcEnv
  71
  72 tcTyAndClassDecls unf_env this_mod decls
  73   = sortByDependency decls              `thenTc` \ groups ->
  74     tcGroups unf_env this_mod groups
  75
  76 tcGroups unf_env this_mod []
  77   = tcGetEnv    `thenNF_Tc` \ env ->
  78     returnTc env
  79
  80 tcGroups unf_env this_mod (group:groups)
  81   = tcGroup unf_env this_mod group      `thenTc` \ env ->
  82     tcSetEnv env                        $
  83     tcGroups unf_env this_mod groups
  84 \end{code}
  85
  86 Dealing with a group
  87 ~~~~~~~~~~~~~~~~~~~~
  88 Consider a mutually-recursive group, binding
  89 a type constructor T and a class C.
  90
  91 Step 1:         getInitialKind
  92         Construct a KindEnv by binding T and C to a kind variable
  93
  94 Step 2:         kcTyClDecl
  95         In that environment, do a kind check
  96
  97 Step 3: Zonk the kinds
  98
  99 Step 4:         buildTyConOrClass
 100         Construct an environment binding T to a TyCon and C to a Class.
 101         a) Their kinds comes from zonking the relevant kind variable
 102         b) Their arity (for synonyms) comes direct from the decl
 103         c) The funcional dependencies come from the decl
 104         d) The rest comes a knot-tied binding of T and C, returned from Step 4
 105         e) The variances of the tycons in the group is calculated from
 106                 the knot-tied stuff
 107
 108 Step 5:         tcTyClDecl1
 109         In this environment, walk over the decls, constructing the TyCons and Classes.
 110         This uses in a strict way items (a)-(c) above, which is why they must
 111         be constructed in Step 4. Feed the results back to Step 4.
 112         For this step, pass the is-recursive flag as the wimp-out flag
 113         to tcTyClDecl1.
 114
 115
 116 Step 6:         Extend environment
 117         We extend the type environment with bindings not only for the TyCons and Classes,
 118         but also for their "implicit Ids" like data constructors and class selectors
 119
 120 Step 7:         checkValidTyCl
 121         For a recursive group only, check all the decls again, just
 122         to check all the side conditions on validity.  We could not
 123         do this before because we were in a mutually recursive knot.
 124
 125
 126 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 127 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 128
 129 \begin{code}
 130 tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv
 131 tcGroup unf_env this_mod scc
 132   = getDOptsTc                                                  `thenTc` \ dflags ->
 133         -- Step 1
 134     mapNF_Tc getInitialKind decls                               `thenNF_Tc` \ initial_kinds ->
 135
 136         -- Step 2
 137     tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)      `thenTc_`
 138
 139         -- Step 3
 140     zonkKindEnv initial_kinds                   `thenNF_Tc` \ final_kinds ->
 141
 142         -- Tie the knot
 143     traceTc (text "starting" <+> ppr final_kinds)               `thenTc_`
 144     fixTc ( \ ~(rec_details_list, _, _) ->
 145                 -- Step 4
 146         let
 147             kind_env    = mkNameEnv final_kinds
 148             rec_details = mkNameEnv rec_details_list
 149
 150             tyclss, all_tyclss :: [TyThing]
 151             tyclss = map (buildTyConOrClass dflags is_rec kind_env
 152                                                    rec_vrcs rec_details) decls
 153
 154                 -- Add the tycons that come from the classes
 155                 -- We want them in the environment because
 156                 -- they are mentioned in interface files
 157             all_tyclss  = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
 158                           ++ tyclss
 159
 160                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 161             rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
 162         in
 163                 -- Step 5
 164                 -- Extend the environment with the final
 165                 -- TyCons/Classes and check the decls
 166         tcExtendGlobalEnv all_tyclss                            $
 167         mapTc (tcTyClDecl1 unf_env) decls                       `thenTc` \ tycls_details ->
 168
 169                 -- Step 6
 170                 -- Extend the environment with implicit Ids
 171         tcExtendGlobalValEnv (implicitTyThingIds all_tyclss)    $
 172
 173                 -- Return results
 174         tcGetEnv                                `thenNF_Tc` \ env ->
 175         returnTc (tycls_details, tyclss, env)
 176     )                                           `thenTc` \ (_, tyclss, env) ->
 177
 178
 179         -- Step 7: Check validity
 180     traceTc (text "ready for validity check")   `thenTc_`
 181     tcSetEnv env (
 182         mapTc_ (checkValidTyCl this_mod) decls
 183     )                                           `thenTc_`
 184     traceTc (text "done")                       `thenTc_`
 185
 186     returnTc env
 187
 188   where
 189     is_rec = case scc of
 190                 AcyclicSCC _ -> NonRecursive
 191                 CyclicSCC _  -> Recursive
 192
 193     decls = case scc of
 194                 AcyclicSCC decl -> [decl]
 195                 CyclicSCC decls -> decls
 196
 197 tcTyClDecl1 unf_env decl
 198   | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
 199   | otherwise        = tcAddDeclCtxt decl (tcTyDecl     unf_env decl)
 200
 201 checkValidTyCl this_mod decl
 202   = tcLookup (tcdName decl)     `thenNF_Tc` \ (AGlobal thing) ->
 203     if not (isLocalThing this_mod thing) then
 204         -- Don't bother to check validity for non-local things
 205         returnTc ()
 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 -> NF_TcM (Name, TcKind)
 222 getInitialKind decl
 223  = kcHsTyVars (tyClDeclTyVars decl)     `thenNF_Tc` \ arg_kinds ->
 224    newKindVar                           `thenNF_Tc` \ result_kind  ->
 225    returnNF_Tc (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                `thenTc` \ rhs_kind ->
 256     unifyKind result_kind rhs_kind
 257
 258 kcTyClDecl (ForeignType {}) = returnTc ()
 259
 260 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
 261   = kcTyClDeclBody decl                 $ \ result_kind ->
 262     kcHsContext context                 `thenTc_`
 263     mapTc_ kc_con_decl con_decls
 264   where
 265     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 266       = kcHsTyVars ex_tvs               `thenNF_Tc` \ 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         `thenTc_`
 273     mapTc_ 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)     `thenNF_Tc` \ 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         :: DynFlags
 307         -> RecFlag -> NameEnv Kind
 308         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 309         -> RenamedTyClDecl -> TyThing
 310
 311 buildTyConOrClass dflags is_rec 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 dflags is_rec kenv rec_vrcs  rec_details
 323                   (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
 324                            tcdNCons = nconstrs, tcdSysNames = sys_names})
 325   = ATyCon tycon
 326   where
 327         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 328                            data_cons nconstrs sel_ids
 329                            flavour is_rec gen_info
 330
 331         gen_info | not (dopt Opt_Generics dflags) = Nothing
 332                  | otherwise = mkTyConGenInfo tycon sys_names
 333
 334         DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
 335
 336         tycon_kind = lookupNameEnv_NF kenv tycon_name
 337         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 338         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 339
 340         -- Watch out!  mkTyConApp asks whether the tycon is a NewType,
 341         -- so flavour has to be able to answer this question without consulting rec_details
 342         flavour = case data_or_new of
 343                     NewType  -> NewTyCon (mkNewTyConRep tycon)
 344                     DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
 345                              | otherwise                                -> DataTyCon
 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 dflags is_rec 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 dflags is_rec kenv rec_vrcs  rec_details
 357                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
 358                               tcdFDs = fundeps, tcdSysNames = name_list} )
 359   = AClass clas
 360   where
 361         (tycon_name, _, _, _) = getClassDeclSysNames name_list
 362         clas = mkClass class_name tyvars fds
 363                        sc_theta sc_sel_ids op_items
 364                        tycon
 365
 366         tycon = mkClassTyCon tycon_name class_kind tyvars
 367                              argvrcs dict_con
 368                              clas               -- Yes!  It's a dictionary
 369                              flavour
 370                              is_rec
 371                 -- A class can be recursive, and in the case of newtypes
 372                 -- this matters.  For example
 373                 --      class C a where { op :: C b => a -> b -> Int }
 374                 -- Because C has only one operation, it is represented by
 375                 -- a newtype, and it should be a *recursive* newtype.
 376                 -- [If we don't make it a recursive newtype, we'll expand the
 377                 -- newtype like a synonym, but that will lead toan inifinite type
 378
 379         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 380
 381         class_kind = lookupNameEnv_NF kenv class_name
 382         tyvars     = mkTyClTyVars class_kind tyvar_names
 383         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 384
 385         flavour = case dataConOrigArgTys dict_con of
 386                         -- The tyvars in the datacon are the same as in the class
 387                     [rep_ty] -> NewTyCon rep_ty
 388                     other    -> DataTyCon
 389
 390         -- We can find the functional dependencies right away,
 391         -- and it is vital to do so. Why?  Because in the next pass
 392         -- we check for ambiguity in all the type signatures, and we
 393         -- need the functional dependcies to be done by then
 394         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 395         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 396         lookup     = lookupNameEnv_NF tyvar_env
 397
 398 bogusVrcs = panic "Bogus tycon arg variances"
 399 \end{code}
 400
 401 \begin{code}
 402 mkNewTyConRep :: TyCon          -- The original type constructor
 403               -> Type           -- Chosen representation type
 404                                 -- (guaranteed not to be another newtype)
 405
 406 -- Find the representation type for this newtype TyCon
 407 --
 408 -- The non-recursive newtypes are easy, because they look transparent
 409 -- to splitTyConApp_maybe, but recursive ones really are represented as
 410 -- TyConApps (see TypeRep).
 411 --
 412 -- The trick is to to deal correctly with recursive newtypes
 413 -- such as      newtype T = MkT T
 414
 415 mkNewTyConRep tc
 416   = go [] tc
 417   where
 418         -- Invariant: tc is a NewTyCon
 419         --            tcs have been seen before
 420     go tcs tc
 421         | tc `elem` tcs = unitTy
 422         | otherwise
 423         = let
 424               rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
 425           in
 426           case splitTyConApp_maybe rep_ty of
 427                         Nothing -> rep_ty
 428                         Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
 429                                         | otherwise            -> go1 (tc:tcs) tc' tys
 430
 431     go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
 432 \end{code}
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection{Dependency analysis}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 Dependency analysis
 441 ~~~~~~~~~~~~~~~~~~~
 442 \begin{code}
 443 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
 444 sortByDependency decls
 445   = let         -- CHECK FOR CLASS CYCLES
 446         cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
 447         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 448     in
 449     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 450
 451     let         -- CHECK FOR SYNONYM CYCLES
 452         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 453         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 454
 455     in
 456     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 457
 458         -- DO THE MAIN DEPENDENCY ANALYSIS
 459     let
 460         decl_sccs  = stronglyConnComp edges
 461     in
 462     returnTc decl_sccs
 463   where
 464     tycl_decls = filter (not . isIfaceSigDecl) decls
 465     edges      = map mkEdges tycl_decls
 466
 467     is_syn_decl (d, _, _) = isSynDecl d
 468 \end{code}
 469
 470 Edges in Type/Class decls
 471 ~~~~~~~~~~~~~~~~~~~~~~~~~
 472
 473 \begin{code}
 474 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 475         -- Find the free non-tyvar vars
 476 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 477                where
 478                  add n fvs | isTyVarName n = fvs
 479                            | otherwise     = n : fvs
 480
 481 ----------------------------------------------------
 482 -- mk_cls_edges looks only at the context of class decls
 483 -- Its used when we are figuring out if there's a cycle in the
 484 -- superclass hierarchy
 485
 486 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 487
 488 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
 489 mkClassEdges other_decl                                        = Nothing
 490
 491 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 492 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection{Error management
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 \begin{code}
 503 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 504
 505 typeCycleErr syn_cycles
 506   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 507
 508 classCycleErr cls_cycles
 509   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 510
 511 pp_cycle str decls
 512   = hang (text str)
 513          4 (vcat (map pp_decl decls))
 514   where
 515     pp_decl decl
 516       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 517      where
 518         name = tyClDeclName decl
 519
 520 \end{code}