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