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