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 CmdLineOpts      ( DynFlags, DynFlag(..), dopt )
  14 import HsSyn            ( TyClDecl(..),  HsTyVarBndr,
  15                           ConDecl(..),   Sig(..), HsPred(..),
  16                           tyClDeclName, hsTyVarNames,
  17                           isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
  18                         )
  19 import RnHsSyn          ( RenamedTyClDecl, tyClDeclFVs )
  20 import BasicTypes       ( RecFlag(..), NewOrData(..), isRec )
  21 import HscTypes         ( implicitTyThingIds )
  22
  23 import TcMonad
  24 import TcEnv            ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
  25                           tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
  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, tyConKind, ArgVrcs, AlgTyConFlavour(..),
  37                           mkSynTyCon, mkAlgTyCon, mkClassTyCon )
  38 import DataCon          ( isNullaryDataCon )
  39 import Var              ( varName )
  40 import FiniteMap
  41 import Digraph          ( stronglyConnComp, SCC(..) )
  42 import Name             ( Name, getSrcLoc, isTyVarName )
  43 import Name             ( NameEnv, mkNameEnv, lookupNameEnv_NF )
  44 import NameSet
  45 import Outputable
  46 import Maybes           ( mapMaybe )
  47 import ErrUtils         ( Message )
  48 import HsDecls          ( getClassDeclSysNames )
  49 import Generics         ( mkTyConGenInfo )
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Type checking for type and class declarations}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 The main function
  60 ~~~~~~~~~~~~~~~~~
  61 \begin{code}
  62 tcTyAndClassDecls :: RecTcEnv           -- Knot tying stuff
  63                   -> [RenamedTyClDecl]
  64                   -> TcM TcEnv
  65
  66 tcTyAndClassDecls unf_env decls
  67   = sortByDependency decls              `thenTc` \ groups ->
  68     tcGroups unf_env groups
  69
  70 tcGroups unf_env []
  71   = tcGetEnv    `thenNF_Tc` \ env ->
  72     returnTc env
  73
  74 tcGroups unf_env (group:groups)
  75   = tcGroup unf_env group       `thenTc` \ env ->
  76     tcSetEnv env                $
  77     tcGroups unf_env groups
  78 \end{code}
  79
  80 Dealing with a group
  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. Feed the results back to Step 4.
 106         For this step, pass the is-recursive flag as the wimp-out flag
 107         to tcTyClDecl1.
 108
 109
 110 Step 6:         tcTyClDecl1 again
 111         For a recursive group only, check all the decls again, just
 112         but this time with the wimp flag off.  Now we can check things
 113         like whether a function argument is an unboxed tuple, looking
 114         through type synonyms properly.  We can't do that in Step 5.
 115
 116 Step 7:         Extend environment
 117         We extend the type environment with bindings not only for the TyCons and Classes,
 118         but also for their "implicit Ids" like data constructors and class selectors
 119
 120 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 121 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 122
 123 \begin{code}
 124 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
 125 tcGroup unf_env scc
 126   = getDOptsTc                                                  `thenTc` \ dflags ->
 127         -- Step 1
 128     mapNF_Tc getInitialKind decls                               `thenNF_Tc` \ initial_kinds ->
 129
 130         -- Step 2
 131     tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)      `thenTc_`
 132
 133         -- Step 3
 134     zonkKindEnv initial_kinds                   `thenNF_Tc` \ final_kinds ->
 135
 136         -- Tie the knot
 137     fixTc ( \ ~(rec_details_list, _, _) ->
 138                 -- Step 4
 139         let
 140             kind_env    = mkNameEnv final_kinds
 141             rec_details = mkNameEnv rec_details_list
 142
 143             tyclss, all_tyclss :: [TyThing]
 144             tyclss = map (buildTyConOrClass dflags is_rec kind_env
 145                                                    rec_vrcs rec_details) decls
 146
 147                 -- Add the tycons that come from the classes
 148                 -- We want them in the environment because
 149                 -- they are mentioned in interface files
 150             all_tyclss  = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
 151                           ++ tyclss
 152
 153                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 154             rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
 155         in
 156                 -- Step 5
 157         tcExtendGlobalEnv all_tyclss                    $
 158         mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
 159
 160                 -- Return results
 161         tcGetEnv                                        `thenNF_Tc` \ env ->
 162         returnTc (tycls_details, all_tyclss, env)
 163     )                                           `thenTc` \ (_, all_tyclss, env) ->
 164
 165     tcSetEnv env                                $
 166
 167         -- Step 6
 168         -- For a recursive group, check all the types again,
 169         -- this time with the wimp flag off
 170     (if isRec is_rec then
 171         mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
 172      else
 173         returnTc ()
 174     )                                           `thenTc_`
 175
 176         -- Step 7
 177         -- Extend the environment with the final TyCons/Classes
 178         -- and their implicit Ids
 179     tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
 180
 181   where
 182     is_rec = case scc of
 183                 AcyclicSCC _ -> NonRecursive
 184                 CyclicSCC _  -> Recursive
 185
 186     decls = case scc of
 187                 AcyclicSCC decl -> [decl]
 188                 CyclicSCC decls -> decls
 189
 190 tcTyClDecl1 is_rec unf_env decl
 191   | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
 192   | otherwise        = tcAddDeclCtxt decl (tcTyDecl1    is_rec unf_env decl)
 193 \end{code}
 194
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection{Step 1: Initial environment}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 \begin{code}
 203 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 204 getInitialKind (TySynonym name tyvars _ _)
 205  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 206    newKindVar           `thenNF_Tc` \ result_kind  ->
 207    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 208
 209 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
 210  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 211    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 212
 213 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
 214  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 215    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 216
 217 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 218 \end{code}
 219
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsection{Step 2: Kind checking}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 We need to kind check all types in the mutually recursive group
 228 before we know the kind of the type variables.  For example:
 229
 230 class C a where
 231    op :: D b => a -> b -> b
 232
 233 class D c where
 234    bop :: (Monad c) => ...
 235
 236 Here, the kind of the locally-polymorphic type variable "b"
 237 depends on *all the uses of class D*.  For example, the use of
 238 Monad c in bop's type signature means that D must have kind Type->Type.
 239
 240 \begin{code}
 241 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 242
 243 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
 244   = tcAddDeclCtxt decl                  $
 245     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 246     kcHsType rhs                        `thenTc` \ rhs_kind ->
 247     unifyKind result_kind rhs_kind
 248
 249 kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _)
 250   = tcAddDeclCtxt decl                  $
 251     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 252     kcHsContext context                 `thenTc_`
 253     mapTc_ kc_con_decl con_decls
 254   where
 255     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 256       = tcAddSrcLoc loc                 $
 257         kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 258         tcExtendKindEnv kind_env        $
 259         kcConDetails new_or_data ex_ctxt details
 260
 261 kcTyClDecl decl@(ClassDecl context class_name
 262                            hs_tyvars fundeps class_sigs
 263                            _ _ loc)
 264   = tcAddDeclCtxt decl                  $
 265     kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
 266     kcHsContext context                 `thenTc_`
 267     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 268   where
 269     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 270
 271 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]    -- Kind of the tycon/cls and its tyvars
 272                -> (Kind -> TcM a)               -- Thing inside
 273                -> TcM a
 274 -- Extend the env with bindings for the tyvars, taken from
 275 -- the kind of the tycon/class.  Give it to the thing inside, and
 276 -- check the result kind matches
 277 kcTyClDeclBody tc_name hs_tyvars thing_inside
 278   = tcLookup tc_name            `thenNF_Tc` \ thing ->
 279     let
 280         kind = case thing of
 281                   AGlobal (ATyCon tc) -> tyConKind tc
 282                   AGlobal (AClass cl) -> tyConKind (classTyCon cl)
 283                   AThing kind         -> kind
 284                 -- For some odd reason, a class doesn't include its kind
 285
 286         (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
 287     in
 288     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 289 \end{code}
 290
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Step 4: Building the tycon/class}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 buildTyConOrClass
 300         :: DynFlags
 301         -> RecFlag -> NameEnv Kind
 302         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 303         -> RenamedTyClDecl -> TyThing
 304
 305 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
 306                   (TySynonym tycon_name tyvar_names rhs src_loc)
 307   = ATyCon tycon
 308   where
 309         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 310         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 311         arity               = length tyvar_names
 312         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 313         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 314         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 315
 316 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 317                   (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
 318   = ATyCon tycon
 319   where
 320         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 321                            data_cons nconstrs sel_ids
 322                            flavour is_rec gen_info
 323
 324         gen_info | not (dopt Opt_Generics dflags) = Nothing
 325                  | otherwise = mkTyConGenInfo tycon name1 name2
 326
 327         DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
 328
 329         tycon_kind = lookupNameEnv_NF kenv tycon_name
 330         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 331         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 332
 333         flavour = case data_or_new of
 334                         NewType -> NewTyCon (mkNewTyConRep tycon)
 335                         DataType | all isNullaryDataCon data_cons -> EnumTyCon
 336                                  | otherwise                      -> DataTyCon
 337
 338 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 339                   (ClassDecl context class_name
 340                              tyvar_names fundeps class_sigs def_methods
 341                              name_list src_loc)
 342   = AClass clas
 343   where
 344         (tycon_name, _, _, _) = getClassDeclSysNames name_list
 345         clas = mkClass class_name tyvars fds
 346                        sc_theta sc_sel_ids op_items
 347                        tycon
 348
 349         tycon = mkClassTyCon tycon_name class_kind tyvars
 350                              argvrcs dict_con
 351                              clas               -- Yes!  It's a dictionary
 352                              flavour
 353
 354         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 355
 356         class_kind = lookupNameEnv_NF kenv class_name
 357         tyvars     = mkTyClTyVars class_kind tyvar_names
 358         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 359         n_fields   = length sc_sel_ids + length op_items
 360
 361         flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
 362                 | otherwise     = DataTyCon
 363
 364         -- We can find the functional dependencies right away,
 365         -- and it is vital to do so. Why?  Because in the next pass
 366         -- we check for ambiguity in all the type signatures, and we
 367         -- need the functional dependcies to be done by then
 368         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 369         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 370         lookup     = lookupNameEnv_NF tyvar_env
 371
 372 bogusVrcs = panic "Bogus tycon arg variances"
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection{Dependency analysis}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 Dependency analysis
 383 ~~~~~~~~~~~~~~~~~~~
 384 \begin{code}
 385 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
 386 sortByDependency decls
 387   = let         -- CHECK FOR CLASS CYCLES
 388         cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
 389         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 390     in
 391     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 392
 393     let         -- CHECK FOR SYNONYM CYCLES
 394         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 395         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 396
 397     in
 398     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 399
 400         -- DO THE MAIN DEPENDENCY ANALYSIS
 401     let
 402         decl_sccs  = stronglyConnComp edges
 403     in
 404     returnTc decl_sccs
 405   where
 406     tycl_decls = filter (not . isIfaceSigDecl) decls
 407     edges      = map mkEdges tycl_decls
 408
 409     is_syn_decl (d, _, _) = isSynDecl d
 410 \end{code}
 411
 412 Edges in Type/Class decls
 413 ~~~~~~~~~~~~~~~~~~~~~~~~~
 414
 415 \begin{code}
 416 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 417         -- Find the free non-tyvar vars
 418 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 419                where
 420                  add n fvs | isTyVarName n = fvs
 421                            | otherwise     = n : fvs
 422
 423 ----------------------------------------------------
 424 -- mk_cls_edges looks only at the context of class decls
 425 -- Its used when we are figuring out if there's a cycle in the
 426 -- superclass hierarchy
 427
 428 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 429
 430 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
 431 mkClassEdges other_decl                             = Nothing
 432
 433 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 434 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 435 \end{code}
 436
 437
 438 %************************************************************************
 439 %*                                                                      *
 440 \subsection{Error management
 441 %*                                                                      *
 442 %************************************************************************
 443
 444 \begin{code}
 445 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 446
 447 typeCycleErr syn_cycles
 448   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 449
 450 classCycleErr cls_cycles
 451   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 452
 453 pp_cycle str decls
 454   = hang (text str)
 455          4 (vcat (map pp_decl decls))
 456   where
 457     pp_decl decl
 458       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 459      where
 460         name = tyClDeclName decl
 461
 462 \end{code}