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(..), DataConDetails(..), visibleDataCons,
  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 (visibleDataCons 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,
 331                            tcdTyVars = tyvar_names, tcdSysNames = sys_names})
 332   = ATyCon tycon
 333   where
 334         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 335                            data_cons 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_nullary data_cons -> EnumTyCon
 352                              | otherwise             -> DataTyCon
 353
 354         all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
 355         all_nullary other           = False     -- Safe choice for unknown data types
 356                         -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
 357                         -- but that looks at the *representation* arity, and that in turn
 358                         -- depends on deciding whether to unpack the args, and that
 359                         -- depends on whether it's a data type or a newtype --- so
 360                         -- in the recursive case we can get a loop.  This version is simple!
 361
 362 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 363                   (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
 364   = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
 365
 366 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 367                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
 368                               tcdFDs = fundeps, tcdSysNames = name_list} )
 369   = AClass clas
 370   where
 371         (tycon_name, _, _, _) = getClassDeclSysNames name_list
 372         clas = mkClass class_name tyvars fds
 373                        sc_theta sc_sel_ids op_items
 374                        tycon
 375
 376         tycon = mkClassTyCon tycon_name class_kind tyvars
 377                              argvrcs dict_con
 378                              clas               -- Yes!  It's a dictionary
 379                              flavour
 380                              is_rec
 381                 -- A class can be recursive, and in the case of newtypes
 382                 -- this matters.  For example
 383                 --      class C a where { op :: C b => a -> b -> Int }
 384                 -- Because C has only one operation, it is represented by
 385                 -- a newtype, and it should be a *recursive* newtype.
 386                 -- [If we don't make it a recursive newtype, we'll expand the
 387                 -- newtype like a synonym, but that will lead toan inifinite type
 388
 389         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 390
 391         class_kind = lookupNameEnv_NF kenv class_name
 392         tyvars     = mkTyClTyVars class_kind tyvar_names
 393         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 394
 395         flavour = case dataConOrigArgTys dict_con of
 396                         -- The tyvars in the datacon are the same as in the class
 397                     [rep_ty] -> NewTyCon rep_ty
 398                     other    -> DataTyCon
 399
 400         -- We can find the functional dependencies right away,
 401         -- and it is vital to do so. Why?  Because in the next pass
 402         -- we check for ambiguity in all the type signatures, and we
 403         -- need the functional dependcies to be done by then
 404         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 405         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 406         lookup     = lookupNameEnv_NF tyvar_env
 407
 408 bogusVrcs = panic "Bogus tycon arg variances"
 409 \end{code}
 410
 411 \begin{code}
 412 mkNewTyConRep :: TyCon          -- The original type constructor
 413               -> Type           -- Chosen representation type
 414                                 -- (guaranteed not to be another newtype)
 415
 416 -- Find the representation type for this newtype TyCon
 417 --
 418 -- The non-recursive newtypes are easy, because they look transparent
 419 -- to splitTyConApp_maybe, but recursive ones really are represented as
 420 -- TyConApps (see TypeRep).
 421 --
 422 -- The trick is to to deal correctly with recursive newtypes
 423 -- such as      newtype T = MkT T
 424
 425 mkNewTyConRep tc
 426   = go [] tc
 427   where
 428         -- Invariant: tc is a NewTyCon
 429         --            tcs have been seen before
 430     go tcs tc
 431         | tc `elem` tcs = unitTy
 432         | otherwise
 433         = let
 434               rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
 435           in
 436           case splitTyConApp_maybe rep_ty of
 437                         Nothing -> rep_ty
 438                         Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
 439                                         | otherwise            -> go1 (tc:tcs) tc' tys
 440
 441     go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
 442 \end{code}
 443
 444 %************************************************************************
 445 %*                                                                      *
 446 \subsection{Dependency analysis}
 447 %*                                                                      *
 448 %************************************************************************
 449
 450 Dependency analysis
 451 ~~~~~~~~~~~~~~~~~~~
 452 \begin{code}
 453 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
 454 sortByDependency decls
 455   = let         -- CHECK FOR CLASS CYCLES
 456         cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
 457         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 458     in
 459     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 460
 461     let         -- CHECK FOR SYNONYM CYCLES
 462         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 463         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 464
 465     in
 466     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 467
 468         -- DO THE MAIN DEPENDENCY ANALYSIS
 469     let
 470         decl_sccs  = stronglyConnComp edges
 471     in
 472     returnTc decl_sccs
 473   where
 474     tycl_decls = filter (not . isIfaceSigDecl) decls
 475     edges      = map mkEdges tycl_decls
 476
 477     is_syn_decl (d, _, _) = isSynDecl d
 478 \end{code}
 479
 480 Edges in Type/Class decls
 481 ~~~~~~~~~~~~~~~~~~~~~~~~~
 482
 483 \begin{code}
 484 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 485         -- Find the free non-tyvar vars
 486 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 487                where
 488                  add n fvs | isTyVarName n = fvs
 489                            | otherwise     = n : fvs
 490
 491 ----------------------------------------------------
 492 -- mk_cls_edges looks only at the context of class decls
 493 -- Its used when we are figuring out if there's a cycle in the
 494 -- superclass hierarchy
 495
 496 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 497
 498 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
 499 mkClassEdges other_decl                                        = Nothing
 500
 501 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 502 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 503 \end{code}
 504
 505
 506 %************************************************************************
 507 %*                                                                      *
 508 \subsection{Error management
 509 %*                                                                      *
 510 %************************************************************************
 511
 512 \begin{code}
 513 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 514
 515 typeCycleErr syn_cycles
 516   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 517
 518 classCycleErr cls_cycles
 519   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 520
 521 pp_cycle str decls
 522   = hang (text str)
 523          4 (vcat (map pp_decl decls))
 524   where
 525     pp_decl decl
 526       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 527      where
 528         name = tyClDeclName decl
 529
 530 \end{code}