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            ( HsDecl(..), TyClDecl(..),
  15                           HsTyVarBndr,
  16                           ConDecl(..),
  17                           Sig(..), HsPred(..),
  18                           tyClDeclName, hsTyVarNames,
  19                           isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
  20                         )
  21 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs )
  22 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  23
  24 import TcMonad
  25 import TcEnv            ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
  26                           tcExtendKindEnv, tcLookup, tcExtendGlobalEnv )
  27 import TcTyDecls        ( tcTyDecl1, kcConDetails, mkNewTyConRep )
  28 import TcClassDcl       ( tcClassDecl1 )
  29 import TcMonoType       ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
  30 import TcType           ( TcKind, newKindVar, zonkKindEnv )
  31
  32 import TcUnify          ( unifyKind )
  33 import TcInstDcls       ( tcAddDeclCtxt )
  34 import Type             ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
  35 import Variance         ( calcTyConArgVrcs )
  36 import Class            ( Class, mkClass, classTyCon )
  37 import TyCon            ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
  38                           mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
  39 import DataCon          ( isNullaryDataCon )
  40 import Var              ( varName )
  41 import FiniteMap
  42 import Digraph          ( stronglyConnComp, SCC(..) )
  43 import Name             ( Name, NamedThing(..), getSrcLoc, isTyVarName )
  44 import Name             ( NameEnv, mkNameEnv, lookupNameEnv_NF )
  45 import NameSet
  46 import Outputable
  47 import Maybes           ( mapMaybe )
  48 import ErrUtils         ( Message )
  49 import HsDecls          ( getClassDeclSysNames )
  50 import Generics         ( mkTyConGenInfo )
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Type checking for type and class declarations}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 The main function
  61 ~~~~~~~~~~~~~~~~~
  62 \begin{code}
  63 tcTyAndClassDecls :: RecTcEnv           -- Knot tying stuff
  64                   -> [RenamedHsDecl]
  65                   -> TcM TcEnv
  66
  67 tcTyAndClassDecls unf_env decls
  68   = sortByDependency decls              `thenTc` \ groups ->
  69     tcGroups unf_env groups
  70
  71 tcGroups unf_env []
  72   = tcGetEnv    `thenNF_Tc` \ env ->
  73     returnTc env
  74
  75 tcGroups unf_env (group:groups)
  76   = tcGroup unf_env group       `thenTc` \ env ->
  77     tcSetEnv env                $
  78     tcGroups unf_env groups
  79 \end{code}
  80
  81 Dealing with a group
  82 ~~~~~~~~~~~~~~~~~~~~
  83 Consider a mutually-recursive group, binding
  84 a type constructor T and a class C.
  85
  86 Step 1:         getInitialKind
  87         Construct a KindEnv by binding T and C to a kind variable
  88
  89 Step 2:         kcTyClDecl
  90         In that environment, do a kind check
  91
  92 Step 3: Zonk the kinds
  93
  94 Step 4:         buildTyConOrClass
  95         Construct an environment binding T to a TyCon and C to a Class.
  96         a) Their kinds comes from zonking the relevant kind variable
  97         b) Their arity (for synonyms) comes direct from the decl
  98         c) The funcional dependencies come from the decl
  99         d) The rest comes a knot-tied binding of T and C, returned from Step 4
 100         e) The variances of the tycons in the group is calculated from
 101                 the knot-tied stuff
 102
 103 Step 5:         tcTyClDecl1
 104         In this environment, walk over the decls, constructing the TyCons and Classes.
 105         This uses in a strict way items (a)-(c) above, which is why they must
 106         be constructed in Step 4.
 107         Feed the results back to Step 4.
 108
 109 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 110 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 111
 112 \begin{code}
 113 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
 114 tcGroup unf_env scc
 115   = getDOptsTc                                                  `thenTc` \ dflags ->
 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 dflags is_rec kind_env
 134                                                    rec_vrcs rec_details) decls
 135
 136                 -- Add the tycons that come from the classes
 137                 -- We want them in the environment because
 138                 -- they are mentioned in interface files
 139             all_tyclss  = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
 140                                                             let tycon = classTyCon clas
 141                           ] ++ tyclss
 142
 143                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 144             rec_vrcs    = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
 145         in
 146                 -- Step 5
 147         tcExtendGlobalEnv all_tyclss            $
 148         mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
 149         tcGetEnv                                `thenNF_Tc` \ env ->
 150         returnTc (tycls_details, env)
 151     )                                           `thenTc` \ (_, env) ->
 152     returnTc env
 153   where
 154     is_rec = case scc of
 155                 AcyclicSCC _ -> NonRecursive
 156                 CyclicSCC _  -> Recursive
 157
 158     decls = case scc of
 159                 AcyclicSCC decl -> [decl]
 160                 CyclicSCC decls -> decls
 161
 162 tcTyClDecl1 unf_env decl
 163   = tcAddDeclCtxt decl                  $
 164     if isClassDecl decl then
 165         tcClassDecl1 unf_env decl
 166     else
 167         tcTyDecl1 decl
 168 \end{code}
 169
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{Step 1: Initial environment}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 179 getInitialKind (TySynonym name tyvars _ _)
 180  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 181    newKindVar           `thenNF_Tc` \ result_kind  ->
 182    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 183
 184 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
 185  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 186    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 187
 188 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
 189  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 190    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 191
 192 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 193 \end{code}
 194
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection{Step 2: Kind checking}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 We need to kind check all types in the mutually recursive group
 203 before we know the kind of the type variables.  For example:
 204
 205 class C a where
 206    op :: D b => a -> b -> b
 207
 208 class D c where
 209    bop :: (Monad c) => ...
 210
 211 Here, the kind of the locally-polymorphic type variable "b"
 212 depends on *all the uses of class D*.  For example, the use of
 213 Monad c in bop's type signature means that D must have kind Type->Type.
 214
 215 \begin{code}
 216 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 217
 218 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
 219   = tcAddDeclCtxt decl                  $
 220     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 221     kcHsType rhs                        `thenTc` \ rhs_kind ->
 222     unifyKind result_kind rhs_kind
 223
 224 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _)
 225   = tcAddDeclCtxt decl                  $
 226     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 227     kcHsContext context                 `thenTc_`
 228     mapTc_ kc_con_decl con_decls
 229   where
 230     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 231       = tcAddSrcLoc loc                 $
 232         kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 233         tcExtendKindEnv kind_env        $
 234         kcConDetails ex_ctxt details
 235
 236 kcTyClDecl decl@(ClassDecl context class_name
 237                            hs_tyvars fundeps class_sigs
 238                            _ _ loc)
 239   = tcAddDeclCtxt decl                  $
 240     kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
 241     kcHsContext context                 `thenTc_`
 242     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 243   where
 244     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 245
 246 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]    -- Kind of the tycon/cls and its tyvars
 247                -> (Kind -> TcM a)               -- Thing inside
 248                -> TcM a
 249 -- Extend the env with bindings for the tyvars, taken from
 250 -- the kind of the tycon/class.  Give it to the thing inside, and
 251 -- check the result kind matches
 252 kcTyClDeclBody tc_name hs_tyvars thing_inside
 253   = tcLookup tc_name            `thenNF_Tc` \ thing ->
 254     let
 255         kind = case thing of
 256                   AGlobal (ATyCon tc) -> tyConKind tc
 257                   AGlobal (AClass cl) -> tyConKind (classTyCon cl)
 258                   AThing kind         -> kind
 259                 -- For some odd reason, a class doesn't include its kind
 260
 261         (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
 262     in
 263     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection{Step 4: Building the tycon/class}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 buildTyConOrClass
 275         :: DynFlags
 276         -> RecFlag -> NameEnv Kind
 277         -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
 278         -> RenamedTyClDecl -> (Name, TyThing)
 279         -- Can't fail; the only reason it's in the monad
 280         -- is so it can zonk the kinds
 281
 282 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
 283                   (TySynonym tycon_name tyvar_names rhs src_loc)
 284   = (tycon_name, ATyCon tycon)
 285   where
 286         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 287         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 288         arity               = length tyvar_names
 289         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 290         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 291         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 292
 293 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 294                   (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
 295   = (tycon_name, ATyCon tycon)
 296   where
 297         tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
 298                            data_cons nconstrs
 299                            flavour is_rec gen_info
 300
 301         gen_info | not (dopt Opt_Generics dflags) = Nothing
 302                  | otherwise = mkTyConGenInfo tycon name1 name2
 303
 304         DataTyDetails ctxt data_cons = 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
 318                              name_list src_loc)
 319   = (class_name, AClass clas)
 320   where
 321         (tycon_name, _, _, _) = getClassDeclSysNames 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 mkClassEdges 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, not (isIfaceSigDecl d)]
 384     edges      = map mkEdges 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 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 394 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 395                where
 396                  add n fvs | isTyVarName n = fvs
 397                            | otherwise     = n : fvs
 398
 399 ----------------------------------------------------
 400 -- mk_cls_edges looks only at the context of class decls
 401 -- Its used when we are figuring out if there's a cycle in the
 402 -- superclass hierarchy
 403
 404 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 405
 406 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
 407 mkClassEdges other_decl                             = Nothing
 408
 409 ----------------------------------------------------
 410 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 411 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsection{Error management
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 \begin{code}
 422 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 423
 424 typeCycleErr syn_cycles
 425   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 426
 427 classCycleErr cls_cycles
 428   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 429
 430 pp_cycle str decls
 431   = hang (text str)
 432          4 (vcat (map pp_decl decls))
 433   where
 434     pp_decl decl
 435       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 436      where
 437         name = tyClDeclName decl
 438
 439 \end{code}