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