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