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