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