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