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            ( HsDecl(..), TyClDecl(..),
  14                           HsType(..), HsTyVarBndr,
  15                           ConDecl(..), ConDetails(..), BangType(..),
  16                           Sig(..), HsPred(..), HsTupCon(..),
  17                           tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
  18                         )
  19 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..), Arity )
  21
  22 import TcMonad
  23 import TcEnv            ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
  24                           tcExtendTypeEnv, tcExtendKindEnv, tcLookupTy
  25                         )
  26 import TcTyDecls        ( tcTyDecl1, kcConDetails, mkNewTyConRep )
  27 import TcClassDcl       ( tcClassDecl1 )
  28 import TcMonoType       ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
  29 import TcType           ( TcKind, newKindVar, newKindVars, zonkKindEnv )
  30
  31 import TcUnify          ( unifyKind )
  32 import Type             ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
  33 import Variance         ( calcTyConArgVrcs )
  34 import Class            ( Class, mkClass, classTyCon )
  35 import TyCon            ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon )
  36 import DataCon          ( isNullaryDataCon )
  37 import Var              ( TyVar, tyVarKind, varName )
  38 import VarEnv
  39 import FiniteMap
  40 import Bag
  41 import Digraph          ( stronglyConnComp, SCC(..) )
  42 import Name             ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
  43                           mkNameEnv, lookupNameEnv_NF
  44                         )
  45 import Outputable
  46 import Maybes           ( mapMaybe, catMaybes )
  47 import UniqSet          ( UniqSet, emptyUniqSet,
  48                           unitUniqSet, unionUniqSets,
  49                           unionManyUniqSets, uniqSetToList )
  50 import ErrUtils         ( Message )
  51 import Unique           ( Unique, Uniquable(..) )
  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 :: ValueEnv           -- Knot tying stuff
  65                   -> [RenamedHsDecl]
  66                   -> TcM s TcEnv
  67
  68 tcTyAndClassDecls unf_env decls
  69   = sortByDependency decls              `thenTc` \ groups ->
  70     tcGroups unf_env groups
  71
  72 tcGroups unf_env []
  73   = tcGetEnv    `thenNF_Tc` \ env ->
  74     returnTc env
  75
  76 tcGroups unf_env (group:groups)
  77   = tcGroup unf_env group       `thenTc` \ env ->
  78     tcSetEnv env                        $
  79     tcGroups unf_env groups
  80 \end{code}
  81
  82 Dealing with a group
  83 ~~~~~~~~~~~~~~~~~~~~
  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.
 109         Feed the results back to Step 4.
 110
 111 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 112 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 113
 114 \begin{code}
 115 tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM s TcEnv
 116 tcGroup unf_env scc
 117   =     -- Step 1
 118     mapNF_Tc getInitialKind decls                               `thenNF_Tc` \ initial_kinds ->
 119
 120         -- Step 2
 121     tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)      `thenTc_`
 122
 123         -- Step 3
 124     zonkKindEnv initial_kinds                   `thenNF_Tc` \ final_kinds ->
 125
 126         -- Tie the knot
 127     fixTc ( \ ~(rec_details_list,  _) ->
 128                 -- Step 4
 129         let
 130             kind_env    = mkNameEnv final_kinds
 131             rec_details = mkNameEnv rec_details_list
 132
 133             tyclss, all_tyclss :: [(Name, TyThing)]
 134             tyclss      = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
 135
 136                 -- Add the tycons that come from the classes
 137                 -- We want them in the environment because
 138                 -- they are mentioned in interface files
 139             all_tyclss  = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
 140                                                             let tycon = classTyCon clas
 141                           ] ++ tyclss
 142
 143                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 144             rec_vrcs    = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
 145         in
 146                 -- Step 5
 147         tcExtendTypeEnv all_tyclss              $
 148         mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
 149         tcGetEnv                                `thenNF_Tc` \ env ->
 150         returnTc (tycls_details, env)
 151     )                                                           `thenTc` \ (_, env) ->
 152     returnTc env
 153   where
 154     is_rec = case scc of
 155                 AcyclicSCC _ -> NonRecursive
 156                 CyclicSCC _  -> Recursive
 157
 158     decls = case scc of
 159                 AcyclicSCC decl -> [decl]
 160                 CyclicSCC decls -> decls
 161
 162 tcTyClDecl1  :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
 163
 164 tcTyClDecl1 unf_env decl
 165   | isClassDecl decl = tcClassDecl1 unf_env decl
 166   | otherwise        = tcTyDecl1 decl
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Step 1: Initial environment}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 getInitialKind :: RenamedTyClDecl -> NF_TcM s (Name, TcKind)
 178 getInitialKind (TySynonym name tyvars _ _)
 179  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 180    newKindVar           `thenNF_Tc` \ result_kind  ->
 181    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 182
 183 getInitialKind (TyData _ _ name tyvars _ _ _ _ _)
 184  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 185    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 186
 187 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
 188  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 189    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 190
 191 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 192 \end{code}
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Step 2: Kind checking}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 We need to kind check all types in the mutually recursive group
 202 before we know the kind of the type variables.  For example:
 203
 204 class C a where
 205    op :: D b => a -> b -> b
 206
 207 class D c where
 208    bop :: (Monad c) => ...
 209
 210 Here, the kind of the locally-polymorphic type variable "b"
 211 depends on *all the uses of class D*.  For example, the use of
 212 Monad c in bop's type signature means that D must have kind Type->Type.
 213
 214 \begin{code}
 215 kcTyClDecl :: RenamedTyClDecl -> TcM s ()
 216
 217 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
 218   = tcAddDeclCtxt decl                  $
 219     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 220     kcHsType rhs                        `thenTc` \ rhs_kind ->
 221     unifyKind result_kind rhs_kind
 222
 223 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc)
 224   = tcAddDeclCtxt decl                  $
 225     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 226     kcHsContext context                 `thenTc_`
 227     mapTc_ kc_con_decl con_decls
 228   where
 229     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 230       = tcAddSrcLoc loc                 $
 231         kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 232         tcExtendKindEnv kind_env        $
 233         kcConDetails ex_ctxt details
 234
 235 kcTyClDecl decl@(ClassDecl context class_name
 236                            hs_tyvars fundeps class_sigs
 237                            _ _ _ _ _ _ loc)
 238   = tcAddDeclCtxt decl                  $
 239     kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
 240     kcHsContext context                 `thenTc_`
 241     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 242   where
 243     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 244
 245 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]    -- Kind of the tycon/cls and its tyvars
 246                -> (Kind -> TcM s a)             -- Thing inside
 247                -> TcM s a
 248 -- Extend the env with bindings for the tyvars, taken from
 249 -- the kind of the tycon/class.  Give it to the thing inside, and
 250 -- check the result kind matches
 251 kcTyClDeclBody tc_name hs_tyvars thing_inside
 252   = tcLookupTy tc_name          `thenNF_Tc` \ tc ->
 253     let
 254         (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) (tyThingKind tc)
 255     in
 256     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 257 \end{code}
 258
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection{Step 4: Building the tycon/class}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 buildTyConOrClass
 268         :: RecFlag -> NameEnv Kind
 269         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 270         -> RenamedTyClDecl -> (Name, TyThing)
 271         -- Can't fail; the only reason it's in the monad
 272         -- is so it can zonk the kinds
 273
 274 buildTyConOrClass is_rec kenv rec_vrcs rec_details
 275                   (TySynonym tycon_name tyvar_names rhs src_loc)
 276   = (tycon_name, ATyCon tycon)
 277   where
 278         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 279         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 280         arity               = length tyvar_names
 281         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 282         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 283         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 284
 285 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
 286                   (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc)
 287   = (tycon_name, ATyCon tycon)
 288   where
 289         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 290                            data_cons nconstrs
 291                            derived_classes
 292                            flavour is_rec
 293
 294         DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
 295
 296         tycon_kind = lookupNameEnv_NF kenv tycon_name
 297         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 298         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 299
 300         flavour = case data_or_new of
 301                         NewType -> NewTyCon (mkNewTyConRep tycon)
 302                         DataType | all isNullaryDataCon data_cons -> EnumTyCon
 303                                  | otherwise                      -> DataTyCon
 304
 305 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
 306                   (ClassDecl context class_name
 307                              tyvar_names fundeps class_sigs def_methods pragmas
 308                              tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
 309   = (class_name, AClass clas)
 310   where
 311         clas = mkClass class_name tyvars fds
 312                        sc_theta sc_sel_ids op_items
 313                        tycon
 314
 315         tycon = mkClassTyCon tycon_name class_kind tyvars
 316                              argvrcs dict_con
 317                              clas               -- Yes!  It's a dictionary
 318                              flavour
 319
 320         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 321
 322         class_kind = lookupNameEnv_NF kenv class_name
 323         tyvars     = mkTyClTyVars class_kind tyvar_names
 324         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 325         n_fields   = length sc_sel_ids + length op_items
 326
 327         flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
 328                 | otherwise     = DataTyCon
 329
 330         -- We can find the functional dependencies right away,
 331         -- and it is vital to do so. Why?  Because in the next pass
 332         -- we check for ambiguity in all the type signatures, and we
 333         -- need the functional dependcies to be done by then
 334         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 335         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 336         lookup     = lookupNameEnv_NF tyvar_env
 337
 338 bogusVrcs = panic "Bogus tycon arg variances"
 339 \end{code}
 340
 341
 342 %************************************************************************
 343 %*                                                                      *
 344 \subsection{Dependency analysis}
 345 %*                                                                      *
 346 %************************************************************************
 347
 348 Dependency analysis
 349 ~~~~~~~~~~~~~~~~~~~
 350 \begin{code}
 351 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl]
 352 sortByDependency decls
 353   = let         -- CHECK FOR CLASS CYCLES
 354         cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
 355         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 356     in
 357     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 358
 359     let         -- CHECK FOR SYNONYM CYCLES
 360         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 361         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 362
 363     in
 364     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 365
 366         -- DO THE MAIN DEPENDENCY ANALYSIS
 367     let
 368         decl_sccs  = stronglyConnComp edges
 369     in
 370     returnTc decl_sccs
 371   where
 372     tycl_decls = [d | TyClD d <- decls]
 373     edges      = map mk_edges tycl_decls
 374
 375     is_syn_decl (d, _, _) = isSynDecl d
 376 \end{code}
 377
 378 Edges in Type/Class decls
 379 ~~~~~~~~~~~~~~~~~~~~~~~~~
 380
 381 \begin{code}
 382 ----------------------------------------------------
 383 -- mk_cls_edges looks only at the context of class decls
 384 -- Its used when we are figuring out if there's a cycle in the
 385 -- superclass hierarchy
 386
 387 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 388
 389 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
 390   = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 391 mk_cls_edges other_decl
 392   = Nothing
 393
 394 ----------------------------------------------------
 395 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 396
 397 mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
 398   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 399                                          get_cons condecls `unionUniqSets`
 400                                          get_deriv derivs))
 401
 402 mk_edges decl@(TySynonym name _ rhs _)
 403   = (decl, getUnique name, uniqSetToList (get_ty rhs))
 404
 405 mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
 406   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 407                                          get_sigs sigs))
 408
 409
 410 ----------------------------------------------------
 411 get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
 412 get_clas (HsPClass clas _) = Just clas
 413 get_clas _                 = Nothing
 414
 415 ----------------------------------------------------
 416 get_deriv Nothing     = emptyUniqSet
 417 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 418
 419 ----------------------------------------------------
 420 get_cons cons = unionManyUniqSets (map get_con cons)
 421
 422 ----------------------------------------------------
 423 get_con (ConDecl _ _ _ ctxt details _)
 424   = get_ctxt ctxt `unionUniqSets` get_con_details details
 425
 426 ----------------------------------------------------
 427 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 428 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
 429 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 430
 431 ----------------------------------------------------
 432 get_bty bty = get_ty (getBangType bty)
 433
 434 ----------------------------------------------------
 435 get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
 436                       | otherwise                  = set_name name
 437 get_ty (HsAppTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 438 get_ty (HsFunTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 439 get_ty (HsListTy ty)                  = set_name listTyCon_name `unionUniqSets` get_ty ty
 440 get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
 441 get_ty (HsUsgTy _ ty)                 = get_ty ty
 442 get_ty (HsUsgForAllTy _ ty)           = get_ty ty
 443 get_ty (HsForAllTy _ ctxt mty)        = get_ctxt ctxt `unionUniqSets` get_ty mty
 444 get_ty (HsPredTy (HsPClass name _))   = set_name name
 445 get_ty (HsPredTy (HsPIParam _ _))     = emptyUniqSet    -- I think
 446
 447 ----------------------------------------------------
 448 get_tys tys = unionManyUniqSets (map get_ty tys)
 449
 450 ----------------------------------------------------
 451 get_sigs sigs
 452   = unionManyUniqSets (map get_sig sigs)
 453   where
 454     get_sig (ClassOpSig _ _ ty _) = get_ty ty
 455     get_sig (FixSig _)            = emptyUniqSet
 456     get_sig other = panic "TcTyClsDecls:get_sig"
 457
 458 ----------------------------------------------------
 459 set_name name = unitUniqSet (getUnique name)
 460 set_to_bag set = listToBag (uniqSetToList set)
 461 \end{code}
 462
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsection{Error management
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 tcAddDeclCtxt decl thing_inside
 472   = tcAddSrcLoc loc     $
 473     tcAddErrCtxt ctxt   $
 474     thing_inside
 475   where
 476      (name, loc, thing)
 477         = case decl of
 478             (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
 479             (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
 480             (TyData NewType  _ name _ _ _ _ _ loc)   -> (name, loc, "data type")
 481             (TyData DataType _ name _ _ _ _ _ loc)   -> (name, loc, "newtype")
 482
 483      ctxt = hsep [ptext SLIT("In the"), text thing,
 484                   ptext SLIT("declaration for"), quotes (ppr name)]
 485 \end{code}
 486
 487 \begin{code}
 488 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 489
 490 typeCycleErr syn_cycles
 491   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 492
 493 classCycleErr cls_cycles
 494   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 495
 496 pp_cycle str decls
 497   = hang (text str)
 498          4 (vcat (map pp_decl decls))
 499   where
 500     pp_decl decl
 501       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 502      where
 503         name = tyClDeclName decl
 504 \end{code}