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
  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(..), getClassSelIds )
  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 )
  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     mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons)       `thenTc` \ (data_ids_s, binds) ->
 125
 126         -- Extend the global value environment with
 127         --      a) constructors
 128         --      b) record selectors
 129         --      c) class op selectors
 130
 131     tcSetEnv final_env                                          $
 132     tcExtendGlobalValEnv (concat data_ids_s)                    $
 133     tcExtendGlobalValEnv (concat (map getClassSelIds classes))  $
 134     tcGetEnv                    `thenNF_Tc` \ really_final_env ->
 135
 136     returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
 137
 138   where
 139     (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
 140
 141     tyvar_names = map de_rn tyvar_rn_names
 142     de_rn (RnName n) = n
 143
 144     combine do_a do_b
 145       = do_a `thenTc` \ (a1,a2) ->
 146         do_b `thenTc` \ (b1,b2) ->
 147         returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
 148 \end{code}
 149
 150 Dealing with one decl
 151 ~~~~~~~~~~~~~~~~~~~~~
 152 \begin{code}
 153 tcDecl  :: InstanceMapper
 154         -> Decl
 155         -> TcM s (Bag TyCon, Bag Class)
 156
 157 tcDecl inst_mapper (TyD decl)
 158   = tcTyDecl decl       `thenTc` \ tycon ->
 159     returnTc (unitBag tycon, emptyBag)
 160
 161 tcDecl inst_mapper (ClD decl)
 162   = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
 163     returnTc (emptyBag, unitBag clas)
 164 \end{code}
 165
 166 Dependency analysis
 167 ~~~~~~~~~~~~~~~~~~~
 168 \begin{code}
 169 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
 170 sortByDependency syn_decls cls_decls decls
 171   = let         -- CHECK FOR SYNONYM CYCLES
 172         syn_sccs   = findSCCs mk_edges syn_decls
 173         syn_cycles = [map fmt_decl (bagToList decls)
 174                         | CyclicSCC decls <- syn_sccs]
 175
 176     in
 177     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 178
 179     let         -- CHECK FOR CLASS CYCLES
 180         cls_sccs   = findSCCs mk_edges cls_decls
 181         cls_cycles = [map fmt_decl (bagToList decls)
 182                         | CyclicSCC decls <- cls_sccs]
 183
 184     in
 185     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 186
 187                 -- DO THE MAIN DEPENDENCY ANALYSIS
 188     let
 189         decl_sccs  = findSCCs mk_edges decls
 190         scc_bags   = map bag_acyclic decl_sccs
 191     in
 192     returnTc (scc_bags)
 193
 194   where
 195    bag_acyclic (AcyclicSCC scc) = unitBag scc
 196    bag_acyclic (CyclicSCC sccs) = sccs
 197
 198 fmt_decl decl
 199   = (ppr PprForUser name, getSrcLoc name)
 200   where
 201     name = get_name decl
 202     get_name (TyD (TyData _ name _ _ _ _ _))    = name
 203     get_name (TyD (TyNew  _ name _ _ _ _ _))    = name
 204     get_name (TyD (TySynonym name _ _ _))       = name
 205     get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
 206 \end{code}
 207
 208 Edges in Type/Class decls
 209 ~~~~~~~~~~~~~~~~~~~~~~~~~
 210 \begin{code}
 211 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
 212   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
 213 mk_edges (TyD (TyNew  ctxt name _ condecl _ _ _))
 214   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
 215 mk_edges (TyD (TySynonym name _ rhs _))
 216   = (uniqueOf name, set_to_bag (get_ty rhs))
 217 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
 218   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
 219
 220 get_ctxt ctxt
 221   = unionManyUniqSets (map (set_name.fst) ctxt)
 222
 223 get_cons cons
 224   = unionManyUniqSets (map get_con cons)
 225   where
 226     get_con (ConDecl _ btys _)
 227       = unionManyUniqSets (map get_bty btys)
 228     get_con (ConOpDecl bty1 _ bty2 _)
 229       = unionUniqSets (get_bty bty1) (get_bty bty2)
 230     get_con (NewConDecl _ ty _)
 231       = get_ty ty
 232     get_con (RecConDecl _ nbtys _)
 233       = unionManyUniqSets (map (get_bty.snd) nbtys)
 234
 235     get_bty (Banged ty)   = get_ty ty
 236     get_bty (Unbanged ty) = get_ty ty
 237
 238 get_ty (MonoTyVar tv)
 239   = emptyUniqSet
 240 get_ty (MonoTyApp name tys)
 241   = (if isRnTyCon name then set_name name else emptyUniqSet)
 242     `unionUniqSets` get_tys tys
 243 get_ty (MonoFunTy ty1 ty2)
 244   = unionUniqSets (get_ty ty1) (get_ty ty2)
 245 get_ty (MonoListTy ty)
 246   = get_ty ty                   -- careful when defining [] (,,) etc as
 247 get_ty (MonoTupleTy tys)        -- [ty] (ty,ty,ty) will not give edges!
 248   = get_tys tys
 249 get_ty other = panic "TcTyClsDecls:get_ty"
 250
 251 get_pty (HsForAllTy _ ctxt mty)
 252   = get_ctxt ctxt `unionUniqSets` get_ty mty
 253 get_pty other = panic "TcTyClsDecls:get_pty"
 254
 255 get_tys tys
 256   = unionManyUniqSets (map get_ty tys)
 257
 258 get_sigs sigs
 259   = unionManyUniqSets (map get_sig sigs)
 260   where
 261     get_sig (ClassOpSig _ ty _ _) = get_pty ty
 262     get_sig other = panic "TcTyClsDecls:get_sig"
 263
 264 set_name name = unitUniqSet (uniqueOf name)
 265
 266 set_to_bag set = listToBag (uniqSetToList set)
 267 \end{code}
 268
 269
 270 get_binders
 271 ~~~~~~~~~~~
 272 Extract *binding* names from type and class decls.  Type variables are
 273 bound in type, data, newtype and class declarations and the polytypes
 274 in the class op sigs.
 275
 276 Why do we need to grab all these type variables at once, including
 277 those locally-quantified type variables in class op signatures?
 278 Because we can only commit to the final kind of a type variable when
 279 we've completed the mutually recursive group. For example:
 280
 281 class C a where
 282    op :: D b => a -> b -> b
 283
 284 class D c where
 285    bop :: (Monad c) => ...
 286
 287 Here, the kind of the locally-polymorphic type variable "b"
 288 depends on *all the uses of class D*.  For example, the use of
 289 Monad c in bop's type signature means that D must have kind Type->Type.
 290
 291
 292 \begin{code}
 293 get_binders :: Bag Decl
 294             -> ([RnName],               -- TyVars;  no dups
 295                 [(RnName, Maybe Arity)],-- Tycons;  no dups; arities for synonyms
 296                 [RnName])               -- Classes; no dups
 297
 298 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
 299   where
 300     (tyvars, tycons, classes) = foldBag union3 get_binders1
 301                                         (emptyBag,emptyBag,emptyBag)
 302                                         decls
 303
 304     union3 (a1,a2,a3) (b1,b2,b3)
 305       = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
 306
 307 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
 308  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 309 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
 310  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 311 get_binders1 (TyD (TySynonym name tyvars _ _))
 312  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 313 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
 314  = (unitBag tyvar `unionBags` sigs_tvs sigs,
 315     emptyBag, unitBag name)
 316
 317 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 318   where
 319     sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
 320     pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs      -- tvs doesn't include the class tyvar
 321 \end{code}
 322
 323
 324 \begin{code}
 325 typeCycleErr syn_cycles sty
 326   = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
 327
 328 classCycleErr cls_cycles sty
 329   = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
 330
 331 pp_cycle sty str things
 332   = ppHang (ppStr str)
 333          4 (ppAboves (map pp_thing things))
 334   where
 335     pp_thing (pp_name, loc)
 336       = ppCat [pp_name, ppr sty loc]
 337 \end{code}