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