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