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