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         tcTyAndClassDecls
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( HsDecl(..), TyClDecl(..),
  14                           HsType(..), HsTyVar,
  15                           ConDecl(..), ConDetails(..), BangType(..),
  16                           Sig(..),
  17                           tyClDeclName, isClassDecl, isSynDecl
  18                         )
  19 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..), Arity )
  21
  22 import TcMonad
  23 import Inst             ( InstanceMapper )
  24 import TcClassDcl       ( kcClassDecl, tcClassDecl1 )
  25 import TcEnv            ( ValueEnv, TcTyThing(..),
  26                           tcExtendTypeEnv, getAllEnvTyCons
  27                         )
  28 import TcTyDecls        ( tcTyDecl, kcTyDecl )
  29 import TcMonoType       ( kcHsTyVar )
  30 import TcType           ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
  31
  32 import Type             ( mkArrowKind, boxedTypeKind, mkDictTy )
  33
  34 import Class            ( Class, classBigSig )
  35 import Var              ( TyVar, tyVarKind )
  36 import FiniteMap
  37 import Bag
  38 import VarSet
  39 import Digraph          ( stronglyConnComp, SCC(..) )
  40 import Name             ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
  41 import Outputable
  42 import Maybes           ( mapMaybe, expectJust )
  43 import UniqSet          ( UniqSet, emptyUniqSet,
  44                           unitUniqSet, unionUniqSets,
  45                           unionManyUniqSets, uniqSetToList )
  46 import ErrUtils         ( Message )
  47 import SrcLoc           ( SrcLoc )
  48 import TyCon            ( TyCon, ArgVrcs )
  49 import Variance         ( calcTyConArgVrcs )
  50 import Unique           ( Unique, Uniquable(..) )
  51 import UniqFM           ( listToUFM, lookupUFM )
  52 \end{code}
  53
  54 The main function
  55 ~~~~~~~~~~~~~~~~~
  56 \begin{code}
  57 tcTyAndClassDecls :: ValueEnv -> InstanceMapper -- Knot tying stuff
  58                   -> [RenamedHsDecl]
  59                   -> TcM s TcEnv
  60
  61 tcTyAndClassDecls unf_env inst_mapper decls
  62   = sortByDependency decls              `thenTc` \ groups ->
  63     tcGroups unf_env inst_mapper groups
  64
  65 tcGroups unf_env inst_mapper []
  66   = tcGetEnv    `thenNF_Tc` \ env ->
  67     returnTc env
  68
  69 tcGroups unf_env inst_mapper (group:groups)
  70   = tcGroup unf_env inst_mapper group   `thenTc` \ env ->
  71     tcSetEnv env                        $
  72     tcGroups unf_env inst_mapper groups
  73 \end{code}
  74
  75 Dealing with a group
  76 ~~~~~~~~~~~~~~~~~~~~
  77
  78 The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to
  79 @TcTyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
  80
  81 \begin{code}
  82 tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv
  83 tcGroup unf_env inst_mapper scc
  84   =     -- Do kind checking
  85     mapNF_Tc getTyBinding1 decls                        `thenNF_Tc` \ ty_env_stuff1 ->
  86     tcExtendTypeEnv ty_env_stuff1 (mapTc kcDecl decls)  `thenTc_`
  87
  88         -- Tie the knot
  89 --  traceTc (ppr (map fst ty_env_stuff1))               `thenTc_`
  90     fixTc ( \ ~(rec_tyclss, rec_vrcs, _) ->
  91         let
  92             rec_env = listToUFM rec_tyclss
  93         in
  94
  95                 -- Do type checking
  96         mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1  `thenNF_Tc` \ ty_env_stuff2 ->
  97         tcExtendTypeEnv ty_env_stuff2                           $
  98         mapTc (tcDecl is_rec_group unf_env inst_mapper rec_vrcs) decls
  99                                                                 `thenTc` \ tyclss ->
 100
 101         tcGetEnv                                                `thenTc` \ env ->
 102         let
 103             tycons = getAllEnvTyCons env
 104             vrcs   = calcTyConArgVrcs tycons
 105         in
 106
 107         returnTc (tyclss, vrcs, env)
 108     )                                                           `thenTc` \ (_, _, env) ->
 109 --  traceTc (text "done" <+> ppr (map fst ty_env_stuff1))       `thenTc_`
 110     returnTc env
 111   where
 112     is_rec_group = case scc of
 113                         AcyclicSCC _ -> NonRecursive
 114                         CyclicSCC _  -> Recursive
 115
 116     decls = case scc of
 117                 AcyclicSCC decl -> [decl]
 118                 CyclicSCC decls -> decls
 119 \end{code}
 120
 121 Dealing with one decl
 122 ~~~~~~~~~~~~~~~~~~~~~
 123 \begin{code}
 124 kcDecl decl
 125   = tcAddDeclCtxt decl          $
 126     if isClassDecl decl then
 127         kcClassDecl decl
 128     else
 129         kcTyDecl    decl
 130
 131 tcDecl  :: RecFlag                      -- True => recursive group
 132          -> ValueEnv -> InstanceMapper -> FiniteMap Name ArgVrcs
 133          -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
 134
 135 tcDecl is_rec_group unf_env inst_mapper vrcs_env decl
 136   = tcAddDeclCtxt decl          $
 137 --  traceTc (text "Starting" <+> ppr name)      `thenTc_`
 138     if isClassDecl decl then
 139         tcClassDecl1 unf_env inst_mapper vrcs_env decl  `thenTc` \ clas ->
 140 --      traceTc (text "Finished" <+> ppr name)          `thenTc_`
 141         returnTc (getName clas, AClass clas)
 142     else
 143         tcTyDecl is_rec_group vrcs_env decl     `thenTc` \ tycon ->
 144 --      traceTc (text "Finished" <+> ppr name)  `thenTc_`
 145         returnTc (getName tycon, ATyCon tycon)
 146
 147   where
 148     name = tyClDeclName decl
 149
 150
 151 tcAddDeclCtxt decl thing_inside
 152   = tcAddSrcLoc loc     $
 153     tcAddErrCtxt ctxt   $
 154     thing_inside
 155   where
 156      (name, loc, thing)
 157         = case decl of
 158             (ClassDecl _ name _ _ _ _ _ _ _ loc) -> (name, loc, "class")
 159             (TySynonym name _ _ loc)             -> (name, loc, "type synonym")
 160             (TyData NewType  _ name _ _ _ _ loc) -> (name, loc, "data type")
 161             (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype")
 162
 163      ctxt = hsep [ptext SLIT("In the"), text thing,
 164                   ptext SLIT("declaration for"), quotes (ppr name)]
 165 \end{code}
 166
 167
 168 getTyBinders
 169 ~~~~~~~~~~~
 170 Extract *binding* names from type and class decls.  Type variables are
 171 bound in type, data, newtype and class declarations,
 172         *and* the polytypes in the class op sigs.
 173         *and* the existentially quantified contexts in datacon decls
 174
 175 Why do we need to grab all these type variables at once, including
 176 those locally-quantified type variables in class op signatures?
 177
 178         [Incidentally, this only works because the names are all unique by now.]
 179
 180 Because we can only commit to the final kind of a type variable when
 181 we've completed the mutually recursive group. For example:
 182
 183 class C a where
 184    op :: D b => a -> b -> b
 185
 186 class D c where
 187    bop :: (Monad c) => ...
 188
 189 Here, the kind of the locally-polymorphic type variable "b"
 190 depends on *all the uses of class D*.  For example, the use of
 191 Monad c in bop's type signature means that D must have kind Type->Type.
 192
 193
 194 \begin{code}
 195 getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, TcTyThing))
 196 getTyBinding1 (TySynonym name tyvars _ _)
 197  = mapNF_Tc kcHsTyVar tyvars            `thenNF_Tc` \ arg_kinds ->
 198    newKindVar                           `thenNF_Tc` \ result_kind  ->
 199    returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds,
 200                        Just (length tyvars),
 201                        ATyCon (pprPanic "ATyCon: syn" (ppr name))))
 202
 203 getTyBinding1 (TyData _ _ name tyvars _ _ _ _)
 204  = mapNF_Tc kcHsTyVar tyvars            `thenNF_Tc` \ arg_kinds ->
 205    returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
 206                        Nothing,
 207                        ATyCon (error "ATyCon: data")))
 208
 209 getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _)
 210  = mapNF_Tc kcHsTyVar tyvars            `thenNF_Tc` \ arg_kinds ->
 211    returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
 212                        Just (length tyvars),
 213                        AClass (error "AClass")))
 214
 215 -- Zonk the kind to its final form, and lookup the
 216 -- recursive tycon/class
 217 getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing))
 218   = zonkTcKindToKind tc_kind            `thenNF_Tc` \ kind ->
 219     returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name)))
 220   where
 221     mk_thing (ATyCon _) ~(Just (ATyCon tc))  = ATyCon tc
 222     mk_thing (AClass _) ~(Just (AClass cls)) = AClass cls
 223 \end{code}
 224
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection{Dependency analysis}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 Dependency analysis
 233 ~~~~~~~~~~~~~~~~~~~
 234 \begin{code}
 235 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl]
 236 sortByDependency decls
 237   = let         -- CHECK FOR CLASS CYCLES
 238         cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
 239         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 240     in
 241     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 242
 243     let         -- CHECK FOR SYNONYM CYCLES
 244         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 245         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 246
 247     in
 248     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 249
 250         -- DO THE MAIN DEPENDENCY ANALYSIS
 251     let
 252         decl_sccs  = stronglyConnComp edges
 253     in
 254     returnTc decl_sccs
 255   where
 256     tycl_decls = [d | TyClD d <- decls]
 257     edges      = map mk_edges tycl_decls
 258
 259     is_syn_decl (d, _, _) = isSynDecl d
 260     is_cls_decl (d, _, _) = isClassDecl d
 261 \end{code}
 262
 263 Edges in Type/Class decls
 264 ~~~~~~~~~~~~~~~~~~~~~~~~~
 265
 266 \begin{code}
 267 ----------------------------------------------------
 268 -- mk_cls_edges looks only at the context of class decls
 269 -- Its used when we are figuring out if there's a cycle in the
 270 -- superclass hierarchy
 271
 272 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 273
 274 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _)
 275   = Just (decl, getUnique name, map (getUnique . fst) ctxt)
 276 mk_cls_edges other_decl
 277   = Nothing
 278
 279 ----------------------------------------------------
 280 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 281
 282 mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
 283   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 284                                          get_cons condecls `unionUniqSets`
 285                                          get_deriv derivs))
 286
 287 mk_edges decl@(TySynonym name _ rhs _)
 288   = (decl, getUnique name, uniqSetToList (get_ty rhs))
 289
 290 mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _ _)
 291   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 292                                          get_sigs sigs))
 293
 294
 295 ----------------------------------------------------
 296 get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
 297
 298 ----------------------------------------------------
 299 get_deriv Nothing     = emptyUniqSet
 300 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 301
 302 ----------------------------------------------------
 303 get_cons cons = unionManyUniqSets (map get_con cons)
 304
 305 ----------------------------------------------------
 306 get_con (ConDecl _ _ ctxt details _)
 307   = get_ctxt ctxt `unionUniqSets` get_con_details details
 308
 309 ----------------------------------------------------
 310 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 311 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
 312 get_con_details (NewCon ty _)        = get_ty ty
 313 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 314
 315 ----------------------------------------------------
 316 get_bty (Banged ty)   = get_ty ty
 317 get_bty (Unbanged ty) = get_ty ty
 318 get_bty (Unpacked ty) = get_ty ty
 319
 320 ----------------------------------------------------
 321 get_ty (MonoTyVar name)
 322   = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
 323 get_ty (MonoTyApp ty1 ty2)
 324   = unionUniqSets (get_ty ty1) (get_ty ty2)
 325 get_ty (MonoFunTy ty1 ty2)
 326   = unionUniqSets (get_ty ty1) (get_ty ty2)
 327 get_ty (MonoListTy ty)
 328   = set_name listTyCon_name `unionUniqSets` get_ty ty
 329 get_ty (MonoTupleTy tys boxed)
 330   = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
 331 get_ty (MonoUsgTy _ ty)
 332   = get_ty ty
 333 get_ty (MonoUsgForAllTy _ ty)
 334   = get_ty ty
 335 get_ty (HsForAllTy _ ctxt mty)
 336   = get_ctxt ctxt `unionUniqSets` get_ty mty
 337 get_ty (MonoDictTy name _)
 338   = set_name name
 339
 340 ----------------------------------------------------
 341 get_tys tys
 342   = unionManyUniqSets (map get_ty tys)
 343
 344 ----------------------------------------------------
 345 get_sigs sigs
 346   = unionManyUniqSets (map get_sig sigs)
 347   where
 348     get_sig (ClassOpSig _ _ ty _) = get_ty ty
 349     get_sig (FixSig _)            = emptyUniqSet
 350     get_sig other = panic "TcTyClsDecls:get_sig"
 351
 352 ----------------------------------------------------
 353 set_name name = unitUniqSet (getUnique name)
 354 set_to_bag set = listToBag (uniqSetToList set)
 355 \end{code}
 356
 357
 358 \begin{code}
 359 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 360
 361 typeCycleErr syn_cycles
 362   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 363
 364 classCycleErr cls_cycles
 365   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 366
 367 pp_cycle str decls
 368   = hang (text str)
 369          4 (vcat (map pp_decl decls))
 370   where
 371     pp_decl decl
 372       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 373      where
 374         name = tyClDeclName decl
 375 \end{code}
 376
 377
 378
 379