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