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