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