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