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 IMP_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 )
  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)
  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
  72
  73 tcGroups inst_mapper (group:groups)
  74   = tcGroup inst_mapper group   `thenTc` \ new_env ->
  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
  81 \end{code}
  82
  83 Dealing with a group
  84 ~~~~~~~~~~~~~~~~~~~~
  85 \begin{code}
  86 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
  87 tcGroup inst_mapper decls
  88   = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
  89
  90         -- TIE THE KNOT
  91     fixTc ( \ ~(tycons,classes,_) ->
  92
  93                 -- EXTEND TYPE AND CLASS ENVIRONMENTS
  94                 -- NB: it's important that the tycons and classes come back in just
  95                 -- the same order from this fix as from get_binders, so that these
  96                 -- extend-env things work properly.  A bit UGH-ish.
  97       tcExtendTyConEnv tycon_names_w_arities tycons               $
  98       tcExtendClassEnv class_names classes                        $
  99
 100                 -- DEAL WITH TYPE VARIABLES
 101       tcTyVarScope tyvar_names                  ( \ tyvars ->
 102
 103                 -- DEAL WITH THE DEFINITIONS THEMSELVES
 104         foldBag combine (tcDecl inst_mapper)
 105                 (returnTc (emptyBag, emptyBag))
 106                 decls
 107       )                                         `thenTc` \ (tycon_bag,class_bag) ->
 108       let
 109         tycons = bagToList tycon_bag
 110         classes = bagToList class_bag
 111       in
 112
 113                 -- SNAFFLE ENV TO RETURN
 114       tcGetEnv                                  `thenNF_Tc` \ final_env ->
 115
 116       returnTc (tycons, classes, final_env)
 117     ) `thenTc` \ (_, _, final_env) ->
 118
 119     returnTc final_env
 120
 121   where
 122     (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
 123
 124     tyvar_names = map de_rn tyvar_rn_names
 125     de_rn (RnName n) = n
 126
 127     combine do_a do_b
 128       = do_a `thenTc` \ (a1,a2) ->
 129         do_b `thenTc` \ (b1,b2) ->
 130         returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
 131 \end{code}
 132
 133 Dealing with one decl
 134 ~~~~~~~~~~~~~~~~~~~~~
 135 \begin{code}
 136 tcDecl  :: InstanceMapper
 137         -> Decl
 138         -> TcM s (Bag TyCon, Bag Class)
 139
 140 tcDecl inst_mapper (TyD decl)
 141   = tcTyDecl decl       `thenTc` \ tycon ->
 142     returnTc (unitBag tycon, emptyBag)
 143
 144 tcDecl inst_mapper (ClD decl)
 145   = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
 146     returnTc (emptyBag, unitBag clas)
 147 \end{code}
 148
 149 Dependency analysis
 150 ~~~~~~~~~~~~~~~~~~~
 151 \begin{code}
 152 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
 153 sortByDependency syn_decls cls_decls decls
 154   = let         -- CHECK FOR SYNONYM CYCLES
 155         syn_sccs   = findSCCs mk_edges syn_decls
 156         syn_cycles = [map fmt_decl (bagToList decls)
 157                         | CyclicSCC decls <- syn_sccs]
 158
 159     in
 160     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 161
 162     let         -- CHECK FOR CLASS CYCLES
 163         cls_sccs   = findSCCs mk_edges cls_decls
 164         cls_cycles = [map fmt_decl (bagToList decls)
 165                         | CyclicSCC decls <- cls_sccs]
 166
 167     in
 168     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 169
 170                 -- DO THE MAIN DEPENDENCY ANALYSIS
 171     let
 172         decl_sccs  = findSCCs mk_edges decls
 173         scc_bags   = map bag_acyclic decl_sccs
 174     in
 175     returnTc (scc_bags)
 176
 177   where
 178    bag_acyclic (AcyclicSCC scc) = unitBag scc
 179    bag_acyclic (CyclicSCC sccs) = sccs
 180
 181 fmt_decl decl
 182   = (ppr PprForUser name, getSrcLoc name)
 183   where
 184     name = get_name decl
 185     get_name (TyD (TyData _ name _ _ _ _ _))    = name
 186     get_name (TyD (TyNew  _ name _ _ _ _ _))    = name
 187     get_name (TyD (TySynonym name _ _ _))       = name
 188     get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
 189 \end{code}
 190
 191 Edges in Type/Class decls
 192 ~~~~~~~~~~~~~~~~~~~~~~~~~
 193 \begin{code}
 194 mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
 195   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs))
 196 mk_edges (TyD (TyNew  ctxt name _ condecl derivs _ _))
 197   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl  `unionUniqSets` get_deriv derivs))
 198 mk_edges (TyD (TySynonym name _ rhs _))
 199   = (uniqueOf name, set_to_bag (get_ty rhs))
 200 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
 201   = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
 202
 203 get_ctxt ctxt
 204   = unionManyUniqSets (map (set_name.fst) ctxt)
 205
 206 get_deriv Nothing     = emptyUniqSet
 207 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 208
 209 get_cons cons
 210   = unionManyUniqSets (map get_con cons)
 211   where
 212     get_con (ConDecl _ btys _)
 213       = unionManyUniqSets (map get_bty btys)
 214     get_con (ConOpDecl bty1 _ bty2 _)
 215       = unionUniqSets (get_bty bty1) (get_bty bty2)
 216     get_con (NewConDecl _ ty _)
 217       = get_ty ty
 218     get_con (RecConDecl _ nbtys _)
 219       = unionManyUniqSets (map (get_bty.snd) nbtys)
 220
 221     get_bty (Banged ty)   = get_pty ty
 222     get_bty (Unbanged ty) = get_pty ty
 223
 224 get_ty (MonoTyVar tv)
 225   = emptyUniqSet
 226 get_ty (MonoTyApp name tys)
 227   = (if isRnTyCon name then set_name name else emptyUniqSet)
 228     `unionUniqSets` get_tys tys
 229 get_ty (MonoFunTy ty1 ty2)
 230   = unionUniqSets (get_ty ty1) (get_ty ty2)
 231 get_ty (MonoListTy ty)
 232   = get_ty ty                   -- careful when defining [] (,,) etc as
 233 get_ty (MonoTupleTy tys)        -- [ty] (ty,ty,ty) will not give edges!
 234   = get_tys tys
 235 get_ty other = panic "TcTyClsDecls:get_ty"
 236
 237 get_pty (HsForAllTy _ ctxt mty)
 238   = get_ctxt ctxt `unionUniqSets` get_ty mty
 239 get_pty other = panic "TcTyClsDecls:get_pty"
 240
 241 get_tys tys
 242   = unionManyUniqSets (map get_ty tys)
 243
 244 get_sigs sigs
 245   = unionManyUniqSets (map get_sig sigs)
 246   where
 247     get_sig (ClassOpSig _ ty _ _) = get_pty ty
 248     get_sig other = panic "TcTyClsDecls:get_sig"
 249
 250 set_name name = unitUniqSet (uniqueOf name)
 251
 252 set_to_bag set = listToBag (uniqSetToList set)
 253 \end{code}
 254
 255
 256 get_binders
 257 ~~~~~~~~~~~
 258 Extract *binding* names from type and class decls.  Type variables are
 259 bound in type, data, newtype and class declarations and the polytypes
 260 in the class op sigs.
 261
 262 Why do we need to grab all these type variables at once, including
 263 those locally-quantified type variables in class op signatures?
 264 Because we can only commit to the final kind of a type variable when
 265 we've completed the mutually recursive group. For example:
 266
 267 class C a where
 268    op :: D b => a -> b -> b
 269
 270 class D c where
 271    bop :: (Monad c) => ...
 272
 273 Here, the kind of the locally-polymorphic type variable "b"
 274 depends on *all the uses of class D*.  For example, the use of
 275 Monad c in bop's type signature means that D must have kind Type->Type.
 276
 277
 278 \begin{code}
 279 get_binders :: Bag Decl
 280             -> ([RnName],               -- TyVars;  no dups
 281                 [(RnName, Maybe Arity)],-- Tycons;  no dups; arities for synonyms
 282                 [RnName])               -- Classes; no dups
 283
 284 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
 285   where
 286     (tyvars, tycons, classes) = foldBag union3 get_binders1
 287                                         (emptyBag,emptyBag,emptyBag)
 288                                         decls
 289
 290     union3 (a1,a2,a3) (b1,b2,b3)
 291       = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
 292
 293 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
 294  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 295 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
 296  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 297 get_binders1 (TyD (TySynonym name tyvars _ _))
 298  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 299 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
 300  = (unitBag tyvar `unionBags` sigs_tvs sigs,
 301     emptyBag, unitBag name)
 302
 303 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 304   where
 305     sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
 306     pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs      -- tvs doesn't include the class tyvar
 307 \end{code}
 308
 309
 310 \begin{code}
 311 typeCycleErr syn_cycles sty
 312   = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
 313
 314 classCycleErr cls_cycles sty
 315   = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
 316
 317 pp_cycle sty str things
 318   = ppHang (ppStr str)
 319          4 (ppAboves (map pp_thing things))
 320   where
 321     pp_thing (pp_name, loc)
 322       = ppCat [pp_name, ppr sty loc]
 323 \end{code}