ghc/compiler/typecheck/TcTyClsDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[TcTyClsDecls]{Typecheck type and class declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcTyClsDecls (
  10         tcTyAndClassDecls1
  11     ) where
  12
  13 import Ubiq{-uitous-}
  14
  15 import HsSyn            ( TyDecl(..),  ConDecl(..), BangType(..),
  16                           ClassDecl(..), MonoType(..), PolyType(..),
  17                           Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
  18 import RnHsSyn          ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
  19                           RnName(..){-instance Uniquable-}
  20                         )
  21 import TcHsSyn          ( TcHsBinds(..), TcIdOcc(..) )
  22
  23 import TcMonad          hiding ( rnMtoTcM )
  24 import Inst             ( InstanceMapper(..) )
  25 import TcClassDcl       ( tcClassDecl1 )
  26 import TcEnv            ( tcExtendTyConEnv, tcExtendClassEnv,
  27                           tcExtendGlobalValEnv,
  28                           tcTyVarScope, tcGetEnv )
  29 import TcKind           ( TcKind, newKindVars )
  30 import TcTyDecls        ( tcTyDecl, mkDataBinds )
  31
  32 import Bag
  33 import Class            ( Class(..), classSelIds )
  34 import Digraph          ( findSCCs, SCC(..) )
  35 import Name             ( getSrcLoc )
  36 import PprStyle
  37 import Pretty
  38 import UniqSet          ( UniqSet(..), emptyUniqSet,
  39                           unitUniqSet, unionUniqSets,
  40                           unionManyUniqSets, uniqSetToList )
  41 import SrcLoc           ( SrcLoc )
  42 import TyCon            ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon )
  43 import Unique           ( Unique )
  44 import Util             ( panic, pprTrace )
  45
  46 \end{code}
  47
  48 The main function
  49 ~~~~~~~~~~~~~~~~~
  50 \begin{code}
  51 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
  52
  53 tcTyAndClassDecls1 :: InstanceMapper
  54                    -> Bag RenamedTyDecl -> Bag RenamedClassDecl
  55                    -> TcM s (TcEnv s, TcHsBinds s)
  56
  57 tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
  58   = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
  59     tcGroups inst_mapper groups
  60   where
  61     cls_decls = mapBag ClD rncls_decls
  62     ty_decls  = mapBag TyD rnty_decls
  63     syn_decls = filterBag is_syn_decl ty_decls
  64     decls     = ty_decls `unionBags` cls_decls
  65
  66     is_syn_decl (TyD (TySynonym _ _ _ _)) = True
  67     is_syn_decl _                         = False
  68
  69 tcGroups inst_mapper []
  70   = tcGetEnv            `thenNF_Tc` \ env ->
  71     returnTc (env, EmptyBinds)
  72
  73 tcGroups inst_mapper (group:groups)
  74   = tcGroup inst_mapper group   `thenTc` \ (new_env, binds1) ->
  75
  76         -- Extend the environment using the new tycons and classes
  77     tcSetEnv new_env $
  78
  79         -- Do the remaining groups
  80     tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) ->
  81
  82     returnTc (final_env, binds1 `ThenBinds` binds2)
  83 \end{code}
  84
  85 Dealing with a group
  86 ~~~~~~~~~~~~~~~~~~~~
  87 \begin{code}
  88 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s)
  89 tcGroup inst_mapper decls
  90   = --pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
  91
  92         -- TIE THE KNOT
  93     fixTc ( \ ~(tycons,classes,_) ->
  94
  95                 -- EXTEND TYPE AND CLASS ENVIRONMENTS
  96                 -- including their data constructors and class operations
  97                 -- NB: it's important that the tycons and classes come back in just
  98                 -- the same order from this fix as from get_binders, so that these
  99                 -- extend-env things work properly.  A bit UGH-ish.
 100       tcExtendTyConEnv tycon_names_w_arities tycons               $
 101       tcExtendClassEnv class_names classes                        $
 102
 103                 -- DEAL WITH TYPE VARIABLES
 104       tcTyVarScope tyvar_names                  ( \ tyvars ->
 105
 106                 -- DEAL WITH THE DEFINITIONS THEMSELVES
 107         foldBag combine (tcDecl inst_mapper)
 108                 (returnTc (emptyBag, emptyBag))
 109                 decls
 110       )                                         `thenTc` \ (tycon_bag,class_bag) ->
 111       let
 112         tycons = bagToList tycon_bag
 113         classes = bagToList class_bag
 114       in
 115
 116                 -- SNAFFLE ENV TO RETURN
 117       tcGetEnv                                  `thenNF_Tc` \ final_env ->
 118
 119       returnTc (tycons, classes, final_env)
 120     ) `thenTc` \ (tycons, classes, final_env) ->
 121
 122
 123         -- Create any necessary record selector Ids and their bindings
 124         -- "Necessary" includes data and newtype declarations
 125     mapAndUnzipTc mkDataBinds (filter (not.isSynTyCon) tycons)  `thenTc` \ (data_ids_s, binds) ->
 126
 127         -- Extend the global value environment with
 128         --      a) constructors
 129         --      b) record selectors
 130         --      c) class op selectors
 131
 132     tcSetEnv final_env                                          $
 133     tcExtendGlobalValEnv (concat data_ids_s)                    $
 134     tcExtendGlobalValEnv (concat (map classSelIds classes))  $
 135     tcGetEnv                    `thenNF_Tc` \ really_final_env ->
 136
 137     returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
 138
 139   where
 140     (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
 141
 142     tyvar_names = map de_rn tyvar_rn_names
 143     de_rn (RnName n) = n
 144
 145     combine do_a do_b
 146       = do_a `thenTc` \ (a1,a2) ->
 147         do_b `thenTc` \ (b1,b2) ->
 148         returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
 149 \end{code}
 150
 151 Dealing with one decl
 152 ~~~~~~~~~~~~~~~~~~~~~
 153 \begin{code}
 154 tcDecl  :: InstanceMapper
 155         -> Decl
 156         -> TcM s (Bag TyCon, Bag Class)
 157
 158 tcDecl inst_mapper (TyD decl)
 159   = tcTyDecl decl       `thenTc` \ tycon ->
 160     returnTc (unitBag tycon, emptyBag)
 161
 162 tcDecl inst_mapper (ClD decl)
 163   = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
 164     returnTc (emptyBag, unitBag clas)
 165 \end{code}
 166
 167 Dependency analysis
 168 ~~~~~~~~~~~~~~~~~~~
 169 \begin{code}
 170 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
 171 sortByDependency syn_decls cls_decls decls
 172   = let         -- CHECK FOR SYNONYM CYCLES
 173         syn_sccs   = findSCCs mk_edges syn_decls
 174         syn_cycles = [map fmt_decl (bagToList decls)
 175                         | CyclicSCC decls <- syn_sccs]
 176
 177     in
 178     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 179
 180     let         -- CHECK FOR CLASS CYCLES
 181         cls_sccs   = findSCCs mk_edges cls_decls
 182         cls_cycles = [map fmt_decl (bagToList decls)
 183                         | CyclicSCC decls <- cls_sccs]
 184
 185     in
 186     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 187
 188                 -- DO THE MAIN DEPENDENCY ANALYSIS
 189     let
 190         decl_sccs  = findSCCs mk_edges decls
 191         scc_bags   = map bag_acyclic decl_sccs
 192     in
 193     returnTc (scc_bags)
 194
 195   where
 196    bag_acyclic (AcyclicSCC scc) = unitBag scc
 197    bag_acyclic (CyclicSCC sccs) = sccs
 198
 199 fmt_decl decl
 200   = (ppr PprForUser name, getSrcLoc name)
 201   where
 202     name = get_name decl
 203     get_name (TyD (TyData _ name _ _ _ _ _))    = name
 204     get_name (TyD (TyNew  _ name _ _ _ _ _))    = name
 205     get_name (TyD (TySynonym name _ _ _))       = name
 206     get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
 207 \end{code}
 208
 209 Edges in Type/Class decls
 210 ~~~~~~~~~~~~~~~~~~~~~~~~~
 211 \begin{code}
 212 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
 213   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
 214 mk_edges (TyD (TyNew  ctxt name _ condecl _ _ _))
 215   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
 216 mk_edges (TyD (TySynonym name _ rhs _))
 217   = (uniqueOf name, set_to_bag (get_ty rhs))
 218 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
 219   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
 220
 221 get_ctxt ctxt
 222   = unionManyUniqSets (map (set_name.fst) ctxt)
 223
 224 get_cons cons
 225   = unionManyUniqSets (map get_con cons)
 226   where
 227     get_con (ConDecl _ btys _)
 228       = unionManyUniqSets (map get_bty btys)
 229     get_con (ConOpDecl bty1 _ bty2 _)
 230       = unionUniqSets (get_bty bty1) (get_bty bty2)
 231     get_con (NewConDecl _ ty _)
 232       = get_ty ty
 233     get_con (RecConDecl _ nbtys _)
 234       = unionManyUniqSets (map (get_bty.snd) nbtys)
 235
 236     get_bty (Banged ty)   = get_pty ty
 237     get_bty (Unbanged ty) = get_pty ty
 238
 239 get_ty (MonoTyVar tv)
 240   = emptyUniqSet
 241 get_ty (MonoTyApp name tys)
 242   = (if isRnTyCon name then set_name name else emptyUniqSet)
 243     `unionUniqSets` get_tys tys
 244 get_ty (MonoFunTy ty1 ty2)
 245   = unionUniqSets (get_ty ty1) (get_ty ty2)
 246 get_ty (MonoListTy ty)
 247   = get_ty ty                   -- careful when defining [] (,,) etc as
 248 get_ty (MonoTupleTy tys)        -- [ty] (ty,ty,ty) will not give edges!
 249   = get_tys tys
 250 get_ty other = panic "TcTyClsDecls:get_ty"
 251
 252 get_pty (HsForAllTy _ ctxt mty)
 253   = get_ctxt ctxt `unionUniqSets` get_ty mty
 254 get_pty other = panic "TcTyClsDecls:get_pty"
 255
 256 get_tys tys
 257   = unionManyUniqSets (map get_ty tys)
 258
 259 get_sigs sigs
 260   = unionManyUniqSets (map get_sig sigs)
 261   where
 262     get_sig (ClassOpSig _ ty _ _) = get_pty ty
 263     get_sig other = panic "TcTyClsDecls:get_sig"
 264
 265 set_name name = unitUniqSet (uniqueOf name)
 266
 267 set_to_bag set = listToBag (uniqSetToList set)
 268 \end{code}
 269
 270
 271 get_binders
 272 ~~~~~~~~~~~
 273 Extract *binding* names from type and class decls.  Type variables are
 274 bound in type, data, newtype and class declarations and the polytypes
 275 in the class op sigs.
 276
 277 Why do we need to grab all these type variables at once, including
 278 those locally-quantified type variables in class op signatures?
 279 Because we can only commit to the final kind of a type variable when
 280 we've completed the mutually recursive group. For example:
 281
 282 class C a where
 283    op :: D b => a -> b -> b
 284
 285 class D c where
 286    bop :: (Monad c) => ...
 287
 288 Here, the kind of the locally-polymorphic type variable "b"
 289 depends on *all the uses of class D*.  For example, the use of
 290 Monad c in bop's type signature means that D must have kind Type->Type.
 291
 292
 293 \begin{code}
 294 get_binders :: Bag Decl
 295             -> ([RnName],               -- TyVars;  no dups
 296                 [(RnName, Maybe Arity)],-- Tycons;  no dups; arities for synonyms
 297                 [RnName])               -- Classes; no dups
 298
 299 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
 300   where
 301     (tyvars, tycons, classes) = foldBag union3 get_binders1
 302                                         (emptyBag,emptyBag,emptyBag)
 303                                         decls
 304
 305     union3 (a1,a2,a3) (b1,b2,b3)
 306       = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
 307
 308 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
 309  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 310 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
 311  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 312 get_binders1 (TyD (TySynonym name tyvars _ _))
 313  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 314 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
 315  = (unitBag tyvar `unionBags` sigs_tvs sigs,
 316     emptyBag, unitBag name)
 317
 318 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 319   where
 320     sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
 321     pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs      -- tvs doesn't include the class tyvar
 322 \end{code}
 323
 324
 325 \begin{code}
 326 typeCycleErr syn_cycles sty
 327   = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
 328
 329 classCycleErr cls_cycles sty
 330   = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
 331
 332 pp_cycle sty str things
 333   = ppHang (ppStr str)
 334          4 (ppAboves (map pp_thing things))
 335   where
 336     pp_thing (pp_name, loc)
 337       = ppCat [pp_name, ppr sty loc]
 338 \end{code}