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(..),
  16                           Sig(..), HsPred(..), HsTupCon(..),
  17                           tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
  18                         )
  19 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  21
  22 import TcMonad
  23 import TcEnv            ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
  24                           tcExtendTypeEnv, tcExtendKindEnv, tcLookupTy
  25                         )
  26 import TcTyDecls        ( tcTyDecl1, kcConDetails, mkNewTyConRep )
  27 import TcClassDcl       ( tcClassDecl1 )
  28 import TcMonoType       ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
  29 import TcType           ( TcKind, newKindVar, zonkKindEnv )
  30
  31 import TcUnify          ( unifyKind )
  32 import TcInstDcls       ( tcAddDeclCtxt )
  33 import Type             ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
  34 import Variance         ( calcTyConArgVrcs )
  35 import Class            ( Class, mkClass, classTyCon )
  36 import TyCon            ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
  37 import DataCon          ( isNullaryDataCon )
  38 import Var              ( varName )
  39 import FiniteMap
  40 import Digraph          ( stronglyConnComp, SCC(..) )
  41 import Name             ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
  42                           mkNameEnv, lookupNameEnv_NF
  43                         )
  44 import Outputable
  45 import Maybes           ( mapMaybe, catMaybes )
  46 import UniqSet          ( emptyUniqSet, unitUniqSet, unionUniqSets,
  47                           unionManyUniqSets, uniqSetToList )
  48 import ErrUtils         ( Message )
  49 import Unique           ( Unique, Uniquable(..) )
  50 import HsDecls          ( fromClassDeclNameList )
  51 import Generics         ( mkTyConGenInfo )
  52 \end{code}
  53
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{Type checking for type and class declarations}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 The main function
  62 ~~~~~~~~~~~~~~~~~
  63 \begin{code}
  64 tcTyAndClassDecls :: ValueEnv           -- Knot tying stuff
  65                   -> [RenamedHsDecl]
  66                   -> TcM TcEnv
  67
  68 tcTyAndClassDecls unf_env decls
  69   = sortByDependency decls              `thenTc` \ groups ->
  70     tcGroups unf_env groups
  71
  72 tcGroups unf_env []
  73   = tcGetEnv    `thenNF_Tc` \ env ->
  74     returnTc env
  75
  76 tcGroups unf_env (group:groups)
  77   = tcGroup unf_env group       `thenTc` \ env ->
  78     tcSetEnv env                        $
  79     tcGroups unf_env groups
  80 \end{code}
  81
  82 Dealing with a group
  83 ~~~~~~~~~~~~~~~~~~~~
  84 Consider a mutually-recursive group, binding
  85 a type constructor T and a class C.
  86
  87 Step 1:         getInitialKind
  88         Construct a KindEnv by binding T and C to a kind variable
  89
  90 Step 2:         kcTyClDecl
  91         In that environment, do a kind check
  92
  93 Step 3: Zonk the kinds
  94
  95 Step 4:         buildTyConOrClass
  96         Construct an environment binding T to a TyCon and C to a Class.
  97         a) Their kinds comes from zonking the relevant kind variable
  98         b) Their arity (for synonyms) comes direct from the decl
  99         c) The funcional dependencies come from the decl
 100         d) The rest comes a knot-tied binding of T and C, returned from Step 4
 101         e) The variances of the tycons in the group is calculated from
 102                 the knot-tied stuff
 103
 104 Step 5:         tcTyClDecl1
 105         In this environment, walk over the decls, constructing the TyCons and Classes.
 106         This uses in a strict way items (a)-(c) above, which is why they must
 107         be constructed in Step 4.
 108         Feed the results back to Step 4.
 109
 110 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 111 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 112
 113 \begin{code}
 114 tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM TcEnv
 115 tcGroup unf_env scc
 116   =     -- Step 1
 117     mapNF_Tc getInitialKind decls                               `thenNF_Tc` \ initial_kinds ->
 118
 119         -- Step 2
 120     tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)      `thenTc_`
 121
 122         -- Step 3
 123     zonkKindEnv initial_kinds                   `thenNF_Tc` \ final_kinds ->
 124
 125         -- Tie the knot
 126     fixTc ( \ ~(rec_details_list,  _) ->
 127                 -- Step 4
 128         let
 129             kind_env    = mkNameEnv final_kinds
 130             rec_details = mkNameEnv rec_details_list
 131
 132             tyclss, all_tyclss :: [(Name, TyThing)]
 133             tyclss = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
 134
 135                 -- Add the tycons that come from the classes
 136                 -- We want them in the environment because
 137                 -- they are mentioned in interface files
 138             all_tyclss  = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
 139                                                             let tycon = classTyCon clas
 140                           ] ++ tyclss
 141
 142                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 143             rec_vrcs    = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
 144         in
 145                 -- Step 5
 146         tcExtendGlobalEnv all_tyclss            $
 147         mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
 148         tcGetEnv                                `thenNF_Tc` \ env ->
 149         returnTc (tycls_details, env)
 150     )                                           `thenTc` \ (_, env) ->
 151     returnTc env
 152   where
 153     is_rec = case scc of
 154                 AcyclicSCC _ -> NonRecursive
 155                 CyclicSCC _  -> Recursive
 156
 157     decls = case scc of
 158                 AcyclicSCC decl -> [decl]
 159                 CyclicSCC decls -> decls
 160
 161 tcTyClDecl1 unf_env decl
 162   = tcAddDeclCtxt decl                  $
 163     if isClassDecl decl then
 164         tcClassDecl1 unf_env decl
 165     else
 166         tcTyDecl1 decl
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Step 1: Initial environment}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 178 getInitialKind (TySynonym name tyvars _ _)
 179  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 180    newKindVar           `thenNF_Tc` \ result_kind  ->
 181    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 182
 183 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
 184  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 185    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 186
 187 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
 188  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 189    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 190
 191 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 192 \end{code}
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Step 2: Kind checking}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 We need to kind check all types in the mutually recursive group
 202 before we know the kind of the type variables.  For example:
 203
 204 class C a where
 205    op :: D b => a -> b -> b
 206
 207 class D c where
 208    bop :: (Monad c) => ...
 209
 210 Here, the kind of the locally-polymorphic type variable "b"
 211 depends on *all the uses of class D*.  For example, the use of
 212 Monad c in bop's type signature means that D must have kind Type->Type.
 213
 214 \begin{code}
 215 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 216
 217 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
 218   = tcAddDeclCtxt decl                  $
 219     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 220     kcHsType rhs                        `thenTc` \ rhs_kind ->
 221     unifyKind result_kind rhs_kind
 222
 223 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
 224   = tcAddDeclCtxt decl                  $
 225     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 226     kcHsContext context                 `thenTc_`
 227     mapTc_ kc_con_decl con_decls
 228   where
 229     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 230       = tcAddSrcLoc loc                 $
 231         kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 232         tcExtendKindEnv kind_env        $
 233         kcConDetails ex_ctxt details
 234
 235 kcTyClDecl decl@(ClassDecl context class_name
 236                            hs_tyvars fundeps class_sigs
 237                            _ _ _ loc)
 238   = tcAddDeclCtxt decl                  $
 239     kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
 240     kcHsContext context                 `thenTc_`
 241     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 242   where
 243     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 244
 245 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]    -- Kind of the tycon/cls and its tyvars
 246                -> (Kind -> TcM a)               -- Thing inside
 247                -> TcM a
 248 -- Extend the env with bindings for the tyvars, taken from
 249 -- the kind of the tycon/class.  Give it to the thing inside, and
 250 -- check the result kind matches
 251 kcTyClDeclBody tc_name hs_tyvars thing_inside
 252   = tcLookupTy tc_name          `thenNF_Tc` \ tc ->
 253     let
 254         kind = case tc of
 255                   ATyCon tc -> tyConKind tc
 256                   AClass cl -> tyConKind (classTyCon cl)
 257                 -- For some odd reason, a class doesn't include its kind
 258
 259         (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
 260     in
 261     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection{Step 4: Building the tycon/class}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 buildTyConOrClass
 273         :: RecFlag -> NameEnv Kind
 274         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 275         -> RenamedTyClDecl -> (Name, TyThing)
 276         -- Can't fail; the only reason it's in the monad
 277         -- is so it can zonk the kinds
 278
 279 buildTyConOrClass is_rec kenv rec_vrcs rec_details
 280                   (TySynonym tycon_name tyvar_names rhs src_loc)
 281   = (tycon_name, ATyCon tycon)
 282   where
 283         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 284         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 285         arity               = length tyvar_names
 286         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 287         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 288         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 289
 290 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
 291                   (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
 292   = (tycon_name, ATyCon tycon)
 293   where
 294         tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
 295                            data_cons nconstrs
 296                            derived_classes
 297                            flavour is_rec gen_info
 298         gen_info = mkTyConGenInfo tycon name1 name2
 299
 300         DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
 301
 302         tycon_kind = lookupNameEnv_NF kenv tycon_name
 303         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 304         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 305
 306         flavour = case data_or_new of
 307                         NewType -> NewTyCon (mkNewTyConRep tycon)
 308                         DataType | all isNullaryDataCon data_cons -> EnumTyCon
 309                                  | otherwise                      -> DataTyCon
 310
 311 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
 312                   (ClassDecl context class_name
 313                              tyvar_names fundeps class_sigs def_methods pragmas
 314                              name_list src_loc)
 315   = (class_name, AClass clas)
 316   where
 317         (tycon_name, _, _, _) = fromClassDeclNameList name_list
 318         clas = mkClass class_name tyvars fds
 319                        sc_theta sc_sel_ids op_items
 320                        tycon
 321
 322         tycon = mkClassTyCon tycon_name class_kind tyvars
 323                              argvrcs dict_con
 324                              clas               -- Yes!  It's a dictionary
 325                              flavour
 326
 327         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 328
 329         class_kind = lookupNameEnv_NF kenv class_name
 330         tyvars     = mkTyClTyVars class_kind tyvar_names
 331         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 332         n_fields   = length sc_sel_ids + length op_items
 333
 334         flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
 335                 | otherwise     = DataTyCon
 336
 337         -- We can find the functional dependencies right away,
 338         -- and it is vital to do so. Why?  Because in the next pass
 339         -- we check for ambiguity in all the type signatures, and we
 340         -- need the functional dependcies to be done by then
 341         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 342         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 343         lookup     = lookupNameEnv_NF tyvar_env
 344
 345 bogusVrcs = panic "Bogus tycon arg variances"
 346 \end{code}
 347
 348
 349 %************************************************************************
 350 %*                                                                      *
 351 \subsection{Dependency analysis}
 352 %*                                                                      *
 353 %************************************************************************
 354
 355 Dependency analysis
 356 ~~~~~~~~~~~~~~~~~~~
 357 \begin{code}
 358 sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
 359 sortByDependency decls
 360   = let         -- CHECK FOR CLASS CYCLES
 361         cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
 362         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 363     in
 364     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 365
 366     let         -- CHECK FOR SYNONYM CYCLES
 367         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 368         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 369
 370     in
 371     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 372
 373         -- DO THE MAIN DEPENDENCY ANALYSIS
 374     let
 375         decl_sccs  = stronglyConnComp edges
 376     in
 377     returnTc decl_sccs
 378   where
 379     tycl_decls = [d | TyClD d <- decls]
 380     edges      = map mk_edges tycl_decls
 381
 382     is_syn_decl (d, _, _) = isSynDecl d
 383 \end{code}
 384
 385 Edges in Type/Class decls
 386 ~~~~~~~~~~~~~~~~~~~~~~~~~
 387
 388 \begin{code}
 389 ----------------------------------------------------
 390 -- mk_cls_edges looks only at the context of class decls
 391 -- Its used when we are figuring out if there's a cycle in the
 392 -- superclass hierarchy
 393
 394 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 395
 396 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
 397   = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 398 mk_cls_edges other_decl
 399   = Nothing
 400
 401 ----------------------------------------------------
 402 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 403
 404 mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _)
 405   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 406                                          get_cons condecls `unionUniqSets`
 407                                          get_deriv derivs))
 408
 409 mk_edges decl@(TySynonym name _ rhs _)
 410   = (decl, getUnique name, uniqSetToList (get_ty rhs))
 411
 412 mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _)
 413   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 414                                          get_sigs sigs))
 415
 416
 417 ----------------------------------------------------
 418 get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
 419 get_clas (HsPClass clas _) = Just clas
 420 get_clas _                 = Nothing
 421
 422 ----------------------------------------------------
 423 get_deriv Nothing     = emptyUniqSet
 424 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 425
 426 ----------------------------------------------------
 427 get_cons cons = unionManyUniqSets (map get_con cons)
 428
 429 ----------------------------------------------------
 430 get_con (ConDecl _ _ _ ctxt details _)
 431   = get_ctxt ctxt `unionUniqSets` get_con_details details
 432
 433 ----------------------------------------------------
 434 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 435 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
 436 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 437
 438 ----------------------------------------------------
 439 get_bty bty = get_ty (getBangType bty)
 440
 441 ----------------------------------------------------
 442 get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
 443                       | otherwise                  = set_name name
 444 get_ty (HsAppTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 445 get_ty (HsFunTy ty1 ty2)              = unionUniqSets (get_ty ty1) (get_ty ty2)
 446 get_ty (HsListTy ty)                  = set_name listTyCon_name `unionUniqSets` get_ty ty
 447 get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
 448 get_ty (HsUsgTy _ ty)                 = get_ty ty
 449 get_ty (HsUsgForAllTy _ ty)           = get_ty ty
 450 get_ty (HsForAllTy _ ctxt mty)        = get_ctxt ctxt `unionUniqSets` get_ty mty
 451 get_ty (HsPredTy (HsPClass name _))   = set_name name
 452 get_ty (HsPredTy (HsPIParam _ _))     = emptyUniqSet    -- I think
 453
 454 ----------------------------------------------------
 455 get_tys tys = unionManyUniqSets (map get_ty tys)
 456
 457 ----------------------------------------------------
 458 get_sigs sigs
 459   = unionManyUniqSets (map get_sig sigs)
 460   where
 461     get_sig (ClassOpSig _ _ ty _) = get_ty ty
 462     get_sig (FixSig _)            = emptyUniqSet
 463     get_sig other = panic "TcTyClsDecls:get_sig"
 464
 465 ----------------------------------------------------
 466 set_name name = unitUniqSet (getUnique name)
 467 \end{code}
 468
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection{Error management
 473 %*                                                                      *
 474 %************************************************************************
 475
 476 \begin{code}
 477 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 478
 479 typeCycleErr syn_cycles
 480   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 481
 482 classCycleErr cls_cycles
 483   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 484
 485 pp_cycle str decls
 486   = hang (text str)
 487          4 (vcat (map pp_decl decls))
 488   where
 489     pp_decl decl
 490       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 491      where
 492         name = tyClDeclName decl
 493
 494 \end{code}