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