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