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(..), HsTyVarBndr,
  15                           ConDecl(..), ConDetails(..), BangType(..),
  16                           Sig(..), HsPred(..), HsTupCon(..),
  17                           tyClDeclName, isClassDecl, isSynDecl
  18                         )
  19 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..), Arity )
  21
  22 import TcMonad
  23 import TcClassDcl       ( kcClassDecl, tcClassDecl1 )
  24 import TcEnv            ( ValueEnv, TcTyThing(..),
  25                           tcExtendTypeEnv, getEnvAllTyCons
  26                         )
  27 import TcTyDecls        ( tcTyDecl, kcTyDecl )
  28 import TcMonoType       ( kcHsTyVar )
  29 import TcType           ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
  30
  31 import Type             ( mkArrowKind, boxedTypeKind )
  32
  33 import Class            ( Class )
  34 import Var              ( TyVar, tyVarKind )
  35 import FiniteMap
  36 import Bag
  37 import VarSet
  38 import Digraph          ( stronglyConnComp, SCC(..) )
  39 import Name             ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
  40 import Outputable
  41 import Maybes           ( mapMaybe, catMaybes, expectJust )
  42 import UniqSet          ( UniqSet, emptyUniqSet,
  43                           unitUniqSet, unionUniqSets,
  44                           unionManyUniqSets, uniqSetToList )
  45 import ErrUtils         ( Message )
  46 import SrcLoc           ( SrcLoc )
  47 import TyCon            ( TyCon, ArgVrcs )
  48 import Variance         ( calcTyConArgVrcs )
  49 import Unique           ( Unique, Uniquable(..) )
  50 import UniqFM           ( listToUFM, lookupUFM )
  51 \end{code}
  52
  53 The main function
  54 ~~~~~~~~~~~~~~~~~
  55 \begin{code}
  56 tcTyAndClassDecls :: ValueEnv           -- Knot tying stuff
  57                   -> [RenamedHsDecl]
  58                   -> TcM s TcEnv
  59
  60 tcTyAndClassDecls unf_env decls
  61   = sortByDependency decls              `thenTc` \ groups ->
  62     tcGroups unf_env groups
  63
  64 tcGroups unf_env []
  65   = tcGetEnv    `thenNF_Tc` \ env ->
  66     returnTc env
  67
  68 tcGroups unf_env (group:groups)
  69   = tcGroup unf_env group       `thenTc` \ env ->
  70     tcSetEnv env                        $
  71     tcGroups unf_env groups
  72 \end{code}
  73
  74 Dealing with a group
  75 ~~~~~~~~~~~~~~~~~~~~
  76
  77 The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to
  78 @TcTyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
  79
  80 \begin{code}
  81 tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM s TcEnv
  82 tcGroup unf_env scc
  83   =     -- Do kind checking
  84     mapNF_Tc getTyBinding1 decls                        `thenNF_Tc` \ ty_env_stuff1 ->
  85     tcExtendTypeEnv ty_env_stuff1 (mapTc kcDecl decls)  `thenTc_`
  86
  87         -- Tie the knot
  88 --  traceTc (ppr (map fst ty_env_stuff1))               `thenTc_`
  89     fixTc ( \ ~(rec_tyclss,  _) ->
  90         let
  91             rec_env    = listToUFM rec_tyclss
  92             rec_tycons = getEnvAllTyCons rec_tyclss
  93             rec_vrcs   = calcTyConArgVrcs rec_tycons
  94         in
  95
  96                 -- Do type checking
  97         mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1  `thenNF_Tc` \ ty_env_stuff2 ->
  98         tcExtendTypeEnv ty_env_stuff2                           $
  99         mapTc (tcDecl is_rec_group unf_env rec_vrcs) decls      `thenTc` \ tyclss ->
 100
 101         tcGetEnv                                                `thenTc` \ env ->
 102         returnTc (tyclss, env)
 103     )                                                           `thenTc` \ (_, env) ->
 104 --  traceTc (text "done" <+> ppr (map fst ty_env_stuff1))       `thenTc_`
 105     returnTc env
 106   where
 107     is_rec_group = case scc of
 108                         AcyclicSCC _ -> NonRecursive
 109                         CyclicSCC _  -> Recursive
 110
 111     decls = case scc of
 112                 AcyclicSCC decl -> [decl]
 113                 CyclicSCC decls -> decls
 114 \end{code}
 115
 116 Dealing with one decl
 117 ~~~~~~~~~~~~~~~~~~~~~
 118 \begin{code}
 119 kcDecl decl
 120   = tcAddDeclCtxt decl          $
 121     if isClassDecl decl then
 122         kcClassDecl decl
 123     else
 124         kcTyDecl    decl
 125
 126 tcDecl  :: RecFlag                      -- True => recursive group
 127          -> ValueEnv -> FiniteMap Name ArgVrcs
 128          -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
 129
 130 tcDecl is_rec_group unf_env vrcs_env decl
 131   = tcAddDeclCtxt decl          $
 132     if isClassDecl decl then
 133         tcClassDecl1 unf_env vrcs_env decl
 134     else
 135         tcTyDecl is_rec_group vrcs_env 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     [April 00: looks as if we've dropped this subtlety; I'm not sure when]
 181
 182 \begin{code}
 183 getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, TcTyThing))
 184 getTyBinding1 (TySynonym name tyvars _ _)
 185  = mapNF_Tc kcHsTyVar tyvars            `thenNF_Tc` \ arg_kinds ->
 186    newKindVar                           `thenNF_Tc` \ result_kind  ->
 187    returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds,
 188                        ASynTyCon (pprPanic "ATyCon: syn" (ppr name)) (length tyvars)))
 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                        ADataTyCon (error "ATyCon: data")))
 194
 195 getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
 196  = mapNF_Tc kcHsTyVar tyvars            `thenNF_Tc` \ arg_kinds ->
 197    returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
 198                        AClass (pprPanic "AClass" (ppr name)) (length tyvars)))
 199
 200 -- Zonk the kind to its final form, and lookup the
 201 -- recursive tycon/class
 202 getTyBinding2 rec_env (name, (tc_kind, thing))
 203   = zonkTcKindToKind tc_kind            `thenNF_Tc` \ kind ->
 204     returnNF_Tc (name, (kind, mk_thing thing (lookupUFM rec_env name)))
 205   where
 206     mk_thing (ADataTyCon _)      ~(Just (ADataTyCon tc))  = ADataTyCon tc
 207     mk_thing (ASynTyCon _ arity) ~(Just (ASynTyCon tc _)) = ASynTyCon tc arity
 208     mk_thing (AClass _ arity)    ~(Just (AClass cls _))   = AClass cls arity
 209 \end{code}
 210
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{Dependency analysis}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 Dependency analysis
 219 ~~~~~~~~~~~~~~~~~~~
 220 \begin{code}
 221 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl]
 222 sortByDependency decls
 223   = let         -- CHECK FOR CLASS CYCLES
 224         cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
 225         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 226     in
 227     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 228
 229     let         -- CHECK FOR SYNONYM CYCLES
 230         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 231         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 232
 233     in
 234     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 235
 236         -- DO THE MAIN DEPENDENCY ANALYSIS
 237     let
 238         decl_sccs  = stronglyConnComp edges
 239     in
 240     returnTc decl_sccs
 241   where
 242     tycl_decls = [d | TyClD d <- decls]
 243     edges      = map mk_edges tycl_decls
 244
 245     is_syn_decl (d, _, _) = isSynDecl d
 246 \end{code}
 247
 248 Edges in Type/Class decls
 249 ~~~~~~~~~~~~~~~~~~~~~~~~~
 250
 251 \begin{code}
 252 ----------------------------------------------------
 253 -- mk_cls_edges looks only at the context of class decls
 254 -- Its used when we are figuring out if there's a cycle in the
 255 -- superclass hierarchy
 256
 257 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 258
 259 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
 260   = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 261 mk_cls_edges other_decl
 262   = Nothing
 263
 264 ----------------------------------------------------
 265 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 266
 267 mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
 268   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 269                                          get_cons condecls `unionUniqSets`
 270                                          get_deriv derivs))
 271
 272 mk_edges decl@(TySynonym name _ rhs _)
 273   = (decl, getUnique name, uniqSetToList (get_ty rhs))
 274
 275 mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
 276   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 277                                          get_sigs sigs))
 278
 279
 280 ----------------------------------------------------
 281 get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
 282 get_clas (HsPClass clas _) = Just clas
 283 get_clas _                 = Nothing
 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 get_bty (Unpacked ty) = get_ty ty
 306
 307 ----------------------------------------------------
 308 get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
 309                       | otherwise                  = set_name name
 310 get_ty (HsAppTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 311 get_ty (HsFunTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 312 get_ty (HsListTy ty)                  = set_name listTyCon_name `unionUniqSets` get_ty ty
 313 get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
 314 get_ty (HsUsgTy _ ty)                 = get_ty ty
 315 get_ty (HsUsgForAllTy _ ty)           = get_ty ty
 316 get_ty (HsForAllTy _ ctxt mty)        = get_ctxt ctxt `unionUniqSets` get_ty mty
 317 get_ty (HsPredTy (HsPClass name _))   = set_name name
 318 get_ty (HsPredTy (HsPIParam _ _))     = emptyUniqSet    -- I think
 319
 320 ----------------------------------------------------
 321 get_tys tys = unionManyUniqSets (map get_ty tys)
 322
 323 ----------------------------------------------------
 324 get_sigs sigs
 325   = unionManyUniqSets (map get_sig sigs)
 326   where
 327     get_sig (ClassOpSig _ _ _ ty _) = get_ty ty
 328     get_sig (FixSig _)              = emptyUniqSet
 329     get_sig other = panic "TcTyClsDecls:get_sig"
 330
 331 ----------------------------------------------------
 332 set_name name = unitUniqSet (getUnique name)
 333 set_to_bag set = listToBag (uniqSetToList set)
 334 \end{code}
 335
 336
 337 \begin{code}
 338 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 339
 340 typeCycleErr syn_cycles
 341   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 342
 343 classCycleErr cls_cycles
 344   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 345
 346 pp_cycle str decls
 347   = hang (text str)
 348          4 (vcat (map pp_decl decls))
 349   where
 350     pp_decl decl
 351       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 352      where
 353         name = tyClDeclName decl
 354 \end{code}