ghc/compiler/typecheck/TcTyClsDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcTyClsDecls]{Typecheck type and class declarations}
   5
   6 \begin{code}
   7 module TcTyClsDecls (
   8         tcTyAndClassDecls1
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( HsDecl(..), TyDecl(..), ClassDecl(..),
  14                           HsType(..), HsTyVar,
  15                           ConDecl(..), ConDetails(..), BangType(..),
  16                           Sig(..),
  17                           hsDeclName
  18                         )
  19 import RnHsSyn          ( RenamedHsDecl )
  20 import RnEnv            ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these
  21 import BasicTypes       ( RecFlag(..), Arity )
  22
  23 import TcMonad
  24 import Inst             ( InstanceMapper )
  25 import TcClassDcl       ( tcClassDecl1 )
  26 import TcEnv            ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
  27 import TcType           ( TcKind, newKindVar, newKindVars, kindToTcKind )
  28 import TcTyDecls        ( tcTyDecl )
  29 import TcMonoType       ( tcTyVarScope )
  30
  31 import TyCon            ( tyConKind, tyConArity, isSynTyCon )
  32 import Class            ( Class, classBigSig )
  33 import Var              ( tyVarKind )
  34 import Bag
  35 import Digraph          ( stronglyConnComp, SCC(..) )
  36 import Name             ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
  37 import Outputable
  38 import Maybes           ( mapMaybe )
  39 import UniqSet          ( UniqSet, emptyUniqSet,
  40                           unitUniqSet, unionUniqSets,
  41                           unionManyUniqSets, uniqSetToList )
  42 import SrcLoc           ( SrcLoc )
  43 import TyCon            ( TyCon )
  44 import Unique           ( Unique, Uniquable(..) )
  45 import Util             ( panic{-, pprTrace-} )
  46
  47 \end{code}
  48
  49 The main function
  50 ~~~~~~~~~~~~~~~~~
  51 \begin{code}
  52 tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper  -- Knot tying stuff
  53                    -> [RenamedHsDecl]
  54                    -> TcM s (TcEnv s)
  55
  56 tcTyAndClassDecls1 unf_env inst_mapper decls
  57   = sortByDependency decls              `thenTc` \ groups ->
  58     tcGroups unf_env inst_mapper groups
  59
  60 tcGroups unf_env inst_mapper []
  61   = tcGetEnv    `thenNF_Tc` \ env ->
  62     returnTc env
  63
  64 tcGroups unf_env inst_mapper (group:groups)
  65   = tcGroup unf_env inst_mapper group   `thenTc` \ (group_tycons, group_classes) ->
  66
  67         -- Extend the environment using the new tycons and classes
  68     tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon),
  69                                        if isSynTyCon tycon then Just (tyConArity tycon) else Nothing,
  70                                        tycon))
  71                      | tycon <- group_tycons]    $
  72
  73     tcExtendClassEnv [(getName clas, (classKind clas, clas))
  74                      | clas <- group_classes]    $
  75
  76
  77         -- Do the remaining groups
  78     tcGroups unf_env inst_mapper groups
  79   where
  80     classKind clas = map (kindToTcKind . tyVarKind) tyvars
  81                    where
  82                      (tyvars, _, _, _, _) = classBigSig clas
  83 \end{code}
  84
  85 Dealing with a group
  86 ~~~~~~~~~~~~~~~~~~~~
  87
  88 Notice the uses of @zipLazy@, which makes sure
  89 that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
  90
  91
  92 \begin{code}
  93 tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class])
  94 tcGroup unf_env inst_mapper scc
  95   =     -- TIE THE KNOT
  96     fixTc ( \ ~(rec_tycons, rec_classes) ->
  97
  98                 -- EXTEND TYPE AND CLASS ENVIRONMENTS
  99       let
 100         mk_tycon_bind (name, arity) = newKindVar        `thenNF_Tc` \ kind ->
 101                                       returnNF_Tc (name, (kind, arity, find name rec_tycons))
 102
 103         mk_class_bind (name, arity) = newKindVars arity  `thenNF_Tc` \ kinds ->
 104                                       returnNF_Tc (name, (kinds, find name rec_classes))
 105
 106         find name []             = pprPanic "tcGroup" (ppr name)
 107         find name (thing:things) | name == getName thing = thing
 108                                  | otherwise             = find name things
 109
 110       in
 111       mapNF_Tc mk_tycon_bind tycon_names_w_arities    `thenNF_Tc` \ tycon_binds ->
 112       mapNF_Tc mk_class_bind class_names_w_arities    `thenNF_Tc` \ class_binds ->
 113       tcExtendTyConEnv tycon_binds        $
 114       tcExtendClassEnv class_binds        $
 115
 116                 -- DEAL WITH TYPE VARIABLES
 117       tcTyVarScope tyvar_names                  ( \ tyvars ->
 118
 119                 -- DEAL WITH THE DEFINITIONS THEMSELVES
 120         foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls
 121       )                                         `thenTc` \ (tycons, classes) ->
 122
 123       returnTc (tycons, classes)
 124     )
 125   where
 126     is_rec_group = case scc of
 127                         AcyclicSCC _ -> NonRecursive
 128                         CyclicSCC _  -> Recursive
 129
 130     decls = case scc of
 131                 AcyclicSCC decl -> [decl]
 132                 CyclicSCC decls -> decls
 133
 134     (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls
 135 \end{code}
 136
 137 Dealing with one decl
 138 ~~~~~~~~~~~~~~~~~~~~~
 139 \begin{code}
 140 tcDecl  :: RecFlag                      -- True => recursive group
 141         -> GlobalValueEnv -> InstanceMapper
 142         -> ([TyCon], [Class])           -- Accumulating parameter
 143         -> RenamedHsDecl
 144         -> TcM s ([TyCon], [Class])
 145
 146 tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl)
 147   = tcTyDecl is_rec_group decl  `thenTc` \ tycon ->
 148     returnTc (tycon:tycons, classes)
 149
 150 tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl)
 151   = tcClassDecl1 unf_env inst_mapper decl   `thenTc` \ clas ->
 152     returnTc (tycons, clas:classes)
 153 \end{code}
 154
 155 Dependency analysis
 156 ~~~~~~~~~~~~~~~~~~~
 157 \begin{code}
 158 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl]
 159 sortByDependency decls
 160   = let         -- CHECK FOR CLASS CYCLES
 161         cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges decls)
 162         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 163     in
 164     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 165
 166     let         -- CHECK FOR SYNONYM CYCLES
 167         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 168         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 169
 170     in
 171     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 172
 173         -- DO THE MAIN DEPENDENCY ANALYSIS
 174     let
 175         decl_sccs  = stronglyConnComp edges
 176     in
 177     returnTc decl_sccs
 178   where
 179     edges = mapMaybe mk_edges decls
 180
 181 is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
 182 is_syn_decl _                               = False
 183
 184 is_cls_decl (ClD _, _, _) = True
 185 is_cls_decl other         = False
 186 \end{code}
 187
 188 Edges in Type/Class decls
 189 ~~~~~~~~~~~~~~~~~~~~~~~~~
 190 \begin{code}
 191 -- mk_cls_edges looks only at the context of class decls
 192 -- Its used when we are figuring out if there's a cycle in the
 193 -- superclass hierarchy
 194
 195 mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
 196
 197 mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _))
 198   = Just (decl, getUnique name, map (getUnique . fst) ctxt)
 199 mk_cls_edges other_decl
 200   = Nothing
 201
 202
 203 mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
 204
 205 mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
 206   = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 207                                          get_cons condecls `unionUniqSets`
 208                                          get_deriv derivs))
 209
 210 mk_edges decl@(TyD (TySynonym name _ rhs _))
 211   = Just (decl, getUnique name, uniqSetToList (get_ty rhs))
 212
 213 mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
 214   = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 215                                          get_sigs sigs))
 216
 217 mk_edges other_decl = Nothing
 218
 219 get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
 220
 221 get_deriv Nothing     = emptyUniqSet
 222 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 223
 224 get_cons cons = unionManyUniqSets (map get_con cons)
 225
 226 get_con (ConDecl _ _ ctxt details _)
 227   = get_ctxt ctxt `unionUniqSets` get_con_details details
 228
 229 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 230 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
 231 get_con_details (NewCon ty)          =  get_ty ty
 232 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 233
 234 get_bty (Banged ty)   = get_ty ty
 235 get_bty (Unbanged ty) = get_ty ty
 236
 237 get_ty (MonoTyVar name)
 238   = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
 239 get_ty (MonoTyApp ty1 ty2)
 240   = unionUniqSets (get_ty ty1) (get_ty ty2)
 241 get_ty (MonoFunTy ty1 ty2)
 242   = unionUniqSets (get_ty ty1) (get_ty ty2)
 243 get_ty (MonoListTy ty)
 244   = set_name listTyCon_name `unionUniqSets` get_ty ty
 245 get_ty (MonoTupleTy tys boxed)
 246   = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
 247 get_ty (HsForAllTy _ ctxt mty)
 248   = get_ctxt ctxt `unionUniqSets` get_ty mty
 249 get_ty other = panic "TcTyClsDecls:get_ty"
 250
 251 get_tys tys
 252   = unionManyUniqSets (map get_ty tys)
 253
 254 get_sigs sigs
 255   = unionManyUniqSets (map get_sig sigs)
 256   where
 257     get_sig (ClassOpSig _ _ ty _) = get_ty ty
 258     get_sig other = panic "TcTyClsDecls:get_sig"
 259
 260 set_name name = unitUniqSet (getUnique name)
 261
 262 set_to_bag set = listToBag (uniqSetToList set)
 263 \end{code}
 264
 265
 266 get_binders
 267 ~~~~~~~~~~~
 268 Extract *binding* names from type and class decls.  Type variables are
 269 bound in type, data, newtype and class declarations,
 270         *and* the polytypes in the class op sigs.
 271         *and* the existentially quantified contexts in datacon decls
 272
 273 Why do we need to grab all these type variables at once, including
 274 those locally-quantified type variables in class op signatures?
 275
 276         [Incidentally, this only works because the names are all unique by now.]
 277
 278 Because we can only commit to the final kind of a type variable when
 279 we've completed the mutually recursive group. For example:
 280
 281 class C a where
 282    op :: D b => a -> b -> b
 283
 284 class D c where
 285    bop :: (Monad c) => ...
 286
 287 Here, the kind of the locally-polymorphic type variable "b"
 288 depends on *all the uses of class D*.  For example, the use of
 289 Monad c in bop's type signature means that D must have kind Type->Type.
 290
 291
 292 \begin{code}
 293 get_binders :: [RenamedHsDecl]
 294             -> ([HsTyVar Name],         -- TyVars;  no dups
 295                 [(Name, Maybe Arity)],  -- Tycons;  no dups; arities for synonyms
 296                 [(Name, Arity)])        -- Classes; no dups; with their arities
 297
 298 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
 299   where
 300     (tyvars, tycons, classes) = foldr (union3 . get_binders1)
 301                                       (emptyBag,emptyBag,emptyBag)
 302                                       decls
 303
 304     union3 (a1,a2,a3) (b1,b2,b3)
 305       = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
 306
 307 get_binders1 (TyD (TySynonym name tyvars _ _))
 308  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 309 get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _))
 310  = (listToBag tyvars `unionBags` cons_tvs condecls,
 311     unitBag (name,Nothing), emptyBag)
 312 get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
 313  = (listToBag tyvars `unionBags` sigs_tvs sigs,
 314     emptyBag, unitBag (name, length tyvars))
 315
 316 cons_tvs condecls = unionManyBags (map con_tvs condecls)
 317   where
 318     con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs
 319
 320 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 321   where
 322     sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
 323     pty_tvs (HsForAllTy tvs _ _)  = listToBag tvs       -- tvs doesn't include the class tyvar
 324     pty_tvs other                 = emptyBag
 325 \end{code}
 326
 327
 328 \begin{code}
 329 typeCycleErr syn_cycles
 330   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 331
 332 classCycleErr cls_cycles
 333   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 334
 335 pp_cycle str decls
 336   = hang (text str)
 337          4 (vcat (map pp_decl decls))
 338   where
 339     pp_decl decl
 340       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 341      where
 342         name = hsDeclName decl
 343 \end{code}