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