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