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,
  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   = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
  86
  87         -- TIE THE KNOT
  88     fixTc ( \ ~(tycons,classes,_) ->
  89
  90                 -- EXTEND TYPE AND CLASS ENVIRONMENTS
  91                 -- including their data constructors and class operations
  92                 -- NB: it's important that the tycons and classes come back in just
  93                 -- the same order from this fix as from get_binders, so that these
  94                 -- extend-env things work properly.  A bit UGH-ish.
  95       tcExtendTyConEnv tycon_names_w_arities tycons               $
  96       tcExtendClassEnv class_names classes                        $
  97       tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
  98       tcExtendGlobalValEnv (concat (map getClassSelIds classes))  $
  99
 100                 -- SNAFFLE ENV TO RETURN
 101       tcGetEnv                                  `thenNF_Tc` \ final_env ->
 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` \ (tycons,classes) ->
 111
 112       returnTc (bagToList tycons, bagToList classes, final_env)
 113     ) `thenTc` \ (_, _, final_env) ->
 114     returnTc final_env
 115
 116   where
 117     (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
 118
 119     combine do_a do_b
 120       = do_a `thenTc` \ (a1,a2) ->
 121         do_b `thenTc` \ (b1,b2) ->
 122         returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
 123 \end{code}
 124
 125 Dealing with one decl
 126 ~~~~~~~~~~~~~~~~~~~~~
 127 \begin{code}
 128 tcDecl  :: InstanceMapper
 129         -> Decl
 130         -> TcM s (Bag TyCon, Bag Class)
 131
 132 tcDecl inst_mapper (TyD decl)
 133   = tcTyDecl decl       `thenTc` \ tycon ->
 134     returnTc (unitBag tycon, emptyBag)
 135
 136 tcDecl inst_mapper (ClD decl)
 137   = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
 138     returnTc (emptyBag, unitBag clas)
 139 \end{code}
 140
 141 Dependency analysis
 142 ~~~~~~~~~~~~~~~~~~~
 143 \begin{code}
 144 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
 145 sortByDependency syn_decls cls_decls decls
 146   = let         -- CHECK FOR SYNONYM CYCLES
 147         syn_sccs   = findSCCs mk_edges syn_decls
 148         syn_cycles = [map fmt_decl (bagToList decls)
 149                         | CyclicSCC decls <- syn_sccs]
 150
 151     in
 152     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 153
 154     let         -- CHECK FOR CLASS CYCLES
 155         cls_sccs   = findSCCs mk_edges cls_decls
 156         cls_cycles = [map fmt_decl (bagToList decls)
 157                         | CyclicSCC decls <- cls_sccs]
 158
 159     in
 160     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 161
 162                 -- DO THE MAIN DEPENDENCY ANALYSIS
 163     let
 164         decl_sccs  = findSCCs mk_edges decls
 165         scc_bags   = map bag_acyclic decl_sccs
 166     in
 167     returnTc (scc_bags)
 168
 169   where
 170    bag_acyclic (AcyclicSCC scc) = unitBag scc
 171    bag_acyclic (CyclicSCC sccs) = sccs
 172
 173 fmt_decl (TyD (TySynonym name _ _ _))       = (ppr PprForUser name, getSrcLoc name)
 174 fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
 175 \end{code}
 176
 177 Edges in Type/Class decls
 178 ~~~~~~~~~~~~~~~~~~~~~~~~~
 179 \begin{code}
 180 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
 181   = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
 182 mk_edges (TyD (TyNew  ctxt name _ condecl _ _ _))
 183   = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
 184 mk_edges (TyD (TySynonym name _ rhs _))
 185   = (getItsUnique name, set_to_bag (get_ty rhs))
 186 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
 187   = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
 188
 189 get_ctxt ctxt
 190   = unionManyUniqSets (map (set_name.fst) ctxt)
 191
 192 get_cons cons
 193   = unionManyUniqSets (map get_con cons)
 194   where
 195     get_con (ConDecl _ btys _)
 196       = unionManyUniqSets (map get_bty btys)
 197     get_con (ConOpDecl bty1 _ bty2 _)
 198       = unionUniqSets (get_bty bty1) (get_bty bty2)
 199     get_con (NewConDecl _ ty _)
 200       = get_ty ty
 201     get_con (RecConDecl _ nbtys _)
 202       = unionManyUniqSets (map (get_bty.snd) nbtys)
 203
 204     get_bty (Banged ty)   = get_ty ty
 205     get_bty (Unbanged ty) = get_ty ty
 206
 207 get_ty (MonoTyVar tv)
 208   = emptyUniqSet
 209 get_ty (MonoTyApp name tys)
 210   = (if isTyConName name then set_name name else emptyUniqSet)
 211     `unionUniqSets` get_tys tys
 212 get_ty (MonoFunTy ty1 ty2)
 213   = unionUniqSets (get_ty ty1) (get_ty ty2)
 214 get_ty (MonoListTy ty)
 215   = get_ty ty                   -- careful when defining [] (,,) etc as
 216 get_ty (MonoTupleTy tys)        -- [ty] (ty,ty,ty) will not give edges!
 217   = get_tys tys
 218 get_ty other = panic "TcTyClsDecls:get_ty"
 219
 220 get_pty (HsForAllTy _ ctxt mty)
 221   = get_ctxt ctxt `unionUniqSets` get_ty mty
 222 get_pty other = panic "TcTyClsDecls:get_pty"
 223
 224 get_tys tys
 225   = unionManyUniqSets (map get_ty tys)
 226
 227 get_sigs sigs
 228   = unionManyUniqSets (map get_sig sigs)
 229   where
 230     get_sig (ClassOpSig _ ty _ _) = get_pty ty
 231     get_sig other = panic "TcTyClsDecls:get_sig"
 232
 233 set_name name = singletonUniqSet (getItsUnique name)
 234
 235 set_to_bag set = listToBag (uniqSetToList set)
 236 \end{code}
 237
 238
 239 get_binders
 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, Maybe Arity)],  -- Tycons;  no dups; arities for synonyms
 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,Nothing), emptyBag)
 278 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
 279  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 280 get_binders1 (TyD (TySynonym name tyvars _ _))
 281  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 282 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
 283  = (unitBag tyvar `unionBags` sigs_tvs sigs,
 284     emptyBag, unitBag name)
 285
 286 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 287   where
 288     sig_tvs (ClassOpSig _ ty  _ _) = pty_tvs ty
 289     pty_tvs (HsForAllTy tvs _ _)   = listToBag tvs      -- tvs doesn't include the class tyvar
 290 \end{code}
 291
 292
 293 \begin{code}
 294 typeCycleErr syn_cycles sty
 295   = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
 296
 297 classCycleErr cls_cycles sty
 298   = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
 299
 300 pp_cycle sty str things
 301   = ppHang (ppStr str)
 302          4 (ppAboves (map pp_thing things))
 303   where
 304     pp_thing (pp_name, loc)
 305       = ppCat [pp_name, ppr sty loc]
 306 \end{code}