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