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 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          ( RenamedTyDecl, RenamedClassDecl, RenamedHsDecl )
  20 import TcHsSyn          ( TcHsBinds )
  21 import BasicTypes       ( RecFlag(..) )
  22
  23 import TcMonad
  24 import Inst             ( InstanceMapper )
  25 import TcClassDcl       ( tcClassDecl1 )
  26 import TcEnv            ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
  27 import TcKind           ( TcKind, newKindVar, newKindVars, tcDefaultKind, kindToTcKind )
  28 import TcTyDecls        ( tcTyDecl, mkDataBinds )
  29 import TcMonoType       ( tcTyVarScope )
  30
  31 import TyCon            ( tyConKind, tyConArity, isSynTyCon )
  32 import Class            ( Class, classBigSig )
  33 import TyVar            ( 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, Arity )
  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 SYNONYM CYCLES
 161         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 162         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 163
 164     in
 165     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 166
 167     let         -- CHECK FOR CLASS CYCLES
 168         cls_sccs   = stronglyConnComp (filter is_cls_decl edges)
 169         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 170
 171     in
 172     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 173
 174                 -- DO THE MAIN DEPENDENCY ANALYSIS
 175     let
 176         decl_sccs  = stronglyConnComp (filter is_ty_cls_decl edges)
 177     in
 178     returnTc decl_sccs
 179
 180   where
 181     edges = mapMaybe mk_edges decls
 182
 183 bag_acyclic (AcyclicSCC scc) = unitBag scc
 184 bag_acyclic (CyclicSCC sccs) = listToBag sccs
 185
 186 is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
 187 is_syn_decl _                               = False
 188
 189 is_ty_cls_decl (TyD _, _, _) = True
 190 is_ty_cls_decl (ClD _, _, _) = True
 191 is_ty_cls_decl other         = False
 192
 193 is_cls_decl (ClD _, _, _) = True
 194 is_cls_decl other         = False
 195 \end{code}
 196
 197 Edges in Type/Class decls
 198 ~~~~~~~~~~~~~~~~~~~~~~~~~
 199 \begin{code}
 200 mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
 201   = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 202                                          get_cons condecls `unionUniqSets`
 203                                          get_deriv derivs))
 204
 205 mk_edges decl@(TyD (TySynonym name _ rhs _))
 206   = Just (decl, uniqueOf name, uniqSetToList (get_ty rhs))
 207
 208 mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
 209   = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 210                                          get_sigs sigs))
 211
 212 mk_edges other_decl = Nothing
 213
 214 get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
 215
 216 get_deriv Nothing     = emptyUniqSet
 217 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 218
 219 get_cons cons = unionManyUniqSets (map get_con cons)
 220
 221 get_con (ConDecl _ ctxt details _)
 222   = get_ctxt ctxt `unionUniqSets` get_con_details details
 223
 224 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 225 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
 226 get_con_details (NewCon ty)          =  get_ty ty
 227 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 228
 229 get_bty (Banged ty)   = get_ty ty
 230 get_bty (Unbanged ty) = get_ty ty
 231
 232 get_ty (MonoTyVar name)
 233   = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
 234 get_ty (MonoTyApp ty1 ty2)
 235   = unionUniqSets (get_ty ty1) (get_ty ty2)
 236 get_ty (MonoFunTy ty1 ty2)
 237   = unionUniqSets (get_ty ty1) (get_ty ty2)
 238 get_ty (MonoListTy tc ty)
 239   = set_name tc `unionUniqSets` get_ty ty
 240 get_ty (MonoTupleTy tc tys)
 241   = set_name tc `unionUniqSets` get_tys tys
 242 get_ty (HsForAllTy _ ctxt mty)
 243   = get_ctxt ctxt `unionUniqSets` get_ty mty
 244 get_ty other = panic "TcTyClsDecls:get_ty"
 245
 246 get_tys tys
 247   = unionManyUniqSets (map get_ty tys)
 248
 249 get_sigs sigs
 250   = unionManyUniqSets (map get_sig sigs)
 251   where
 252     get_sig (ClassOpSig _ _ ty _) = get_ty ty
 253     get_sig other = panic "TcTyClsDecls:get_sig"
 254
 255 set_name name = unitUniqSet (uniqueOf name)
 256
 257 set_to_bag set = listToBag (uniqSetToList set)
 258 \end{code}
 259
 260
 261 get_binders
 262 ~~~~~~~~~~~
 263 Extract *binding* names from type and class decls.  Type variables are
 264 bound in type, data, newtype and class declarations and the polytypes
 265 in the class op sigs.
 266
 267 Why do we need to grab all these type variables at once, including
 268 those locally-quantified type variables in class op signatures?
 269 Because we can only commit to the final kind of a type variable when
 270 we've completed the mutually recursive group. For example:
 271
 272 class C a where
 273    op :: D b => a -> b -> b
 274
 275 class D c where
 276    bop :: (Monad c) => ...
 277
 278 Here, the kind of the locally-polymorphic type variable "b"
 279 depends on *all the uses of class D*.  For example, the use of
 280 Monad c in bop's type signature means that D must have kind Type->Type.
 281
 282
 283 \begin{code}
 284 get_binders :: [RenamedHsDecl]
 285             -> ([HsTyVar Name],         -- TyVars;  no dups
 286                 [(Name, Maybe Arity)],  -- Tycons;  no dups; arities for synonyms
 287                 [(Name, Arity)])        -- Classes; no dups; with their arities
 288
 289 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
 290   where
 291     (tyvars, tycons, classes) = foldr (union3 . get_binders1)
 292                                       (emptyBag,emptyBag,emptyBag)
 293                                       decls
 294
 295     union3 (a1,a2,a3) (b1,b2,b3)
 296       = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
 297
 298 get_binders1 (TyD (TyData _ _ name tyvars _ _ _ _))
 299  = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
 300 get_binders1 (TyD (TySynonym name tyvars _ _))
 301  = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
 302 get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
 303  = (listToBag tyvars `unionBags` sigs_tvs sigs,
 304     emptyBag, unitBag (name, length tyvars))
 305
 306 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
 307   where
 308     sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
 309     pty_tvs (HsForAllTy tvs _ _)  = listToBag tvs       -- tvs doesn't include the class tyvar
 310     pty_tvs other                 = emptyBag
 311 \end{code}
 312
 313
 314 \begin{code}
 315 typeCycleErr syn_cycles
 316   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 317
 318 classCycleErr cls_cycles
 319   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 320
 321 pp_cycle str decls
 322   = hang (text str)
 323          4 (vcat (map pp_decl decls))
 324   where
 325     pp_decl decl
 326       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 327      where
 328         name = hsDeclName decl
 329 \end{code}