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                           HsTyVarBndr,
  15                           ConDecl(..),
  16                           Sig(..), HsPred(..),
  17                           tyClDeclName, hsTyVarNames,
  18                           isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
  19                         )
  20 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs )
  21 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  22
  23 import TcMonad
  24 import TcEnv            ( TcEnv, TyThing(..), TyThingDetails(..),
  25                           tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv )
  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, mkAlgTyConRep, mkClassTyCon )
  38 import DataCon          ( isNullaryDataCon )
  39 import Var              ( varName )
  40 import FiniteMap
  41 import Digraph          ( stronglyConnComp, SCC(..) )
  42 import Name             ( Name, NamedThing(..), NameEnv, getSrcLoc,
  43                           mkNameEnv, lookupNameEnv_NF, isTyVarName
  44                         )
  45 import NameSet
  46 import Outputable
  47 import Maybes           ( mapMaybe )
  48 import ErrUtils         ( Message )
  49 import HsDecls          ( getClassDeclSysNames )
  50 import Generics         ( mkTyConGenInfo )
  51 import CmdLineOpts      ( DynFlags )
  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 :: TcEnv              -- 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 :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
 115 tcGroup unf_env scc
 116   = getDOptsTc                                                  `thenTc` \ dflags ->
 117         -- Step 1
 118     mapNF_Tc getInitialKind decls                               `thenNF_Tc` \ initial_kinds ->
 119
 120         -- Step 2
 121     tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)      `thenTc_`
 122
 123         -- Step 3
 124     zonkKindEnv initial_kinds                   `thenNF_Tc` \ final_kinds ->
 125
 126         -- Tie the knot
 127     fixTc ( \ ~(rec_details_list,  _) ->
 128                 -- Step 4
 129         let
 130             kind_env    = mkNameEnv final_kinds
 131             rec_details = mkNameEnv rec_details_list
 132
 133             tyclss, all_tyclss :: [(Name, TyThing)]
 134             tyclss = map (buildTyConOrClass dflags is_rec kind_env
 135                                                    rec_vrcs rec_details) decls
 136
 137                 -- Add the tycons that come from the classes
 138                 -- We want them in the environment because
 139                 -- they are mentioned in interface files
 140             all_tyclss  = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
 141                                                             let tycon = classTyCon clas
 142                           ] ++ tyclss
 143
 144                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 145             rec_vrcs    = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
 146         in
 147                 -- Step 5
 148         tcExtendGlobalEnv all_tyclss            $
 149         mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
 150         tcGetEnv                                `thenNF_Tc` \ env ->
 151         returnTc (tycls_details, env)
 152     )                                           `thenTc` \ (_, env) ->
 153     returnTc env
 154   where
 155     is_rec = case scc of
 156                 AcyclicSCC _ -> NonRecursive
 157                 CyclicSCC _  -> Recursive
 158
 159     decls = case scc of
 160                 AcyclicSCC decl -> [decl]
 161                 CyclicSCC decls -> decls
 162
 163 tcTyClDecl1 unf_env decl
 164   = tcAddDeclCtxt decl                  $
 165     if isClassDecl decl then
 166         tcClassDecl1 unf_env decl
 167     else
 168         tcTyDecl1 decl
 169 \end{code}
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection{Step 1: Initial environment}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 180 getInitialKind (TySynonym name tyvars _ _)
 181  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 182    newKindVar           `thenNF_Tc` \ result_kind  ->
 183    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 184
 185 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
 186  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 187    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 188
 189 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
 190  = kcHsTyVars tyvars    `thenNF_Tc` \ arg_kinds ->
 191    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 192
 193 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 194 \end{code}
 195
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsection{Step 2: Kind checking}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 We need to kind check all types in the mutually recursive group
 204 before we know the kind of the type variables.  For example:
 205
 206 class C a where
 207    op :: D b => a -> b -> b
 208
 209 class D c where
 210    bop :: (Monad c) => ...
 211
 212 Here, the kind of the locally-polymorphic type variable "b"
 213 depends on *all the uses of class D*.  For example, the use of
 214 Monad c in bop's type signature means that D must have kind Type->Type.
 215
 216 \begin{code}
 217 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 218
 219 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
 220   = tcAddDeclCtxt decl                  $
 221     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 222     kcHsType rhs                        `thenTc` \ rhs_kind ->
 223     unifyKind result_kind rhs_kind
 224
 225 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _)
 226   = tcAddDeclCtxt decl                  $
 227     kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
 228     kcHsContext context                 `thenTc_`
 229     mapTc_ kc_con_decl con_decls
 230   where
 231     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 232       = tcAddSrcLoc loc                 $
 233         kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 234         tcExtendKindEnv kind_env        $
 235         kcConDetails ex_ctxt details
 236
 237 kcTyClDecl decl@(ClassDecl context class_name
 238                            hs_tyvars fundeps class_sigs
 239                            _ _ loc)
 240   = tcAddDeclCtxt decl                  $
 241     kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
 242     kcHsContext context                 `thenTc_`
 243     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 244   where
 245     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
 246
 247 kcTyClDeclBody :: Name -> [HsTyVarBndr Name]    -- Kind of the tycon/cls and its tyvars
 248                -> (Kind -> TcM a)               -- Thing inside
 249                -> TcM a
 250 -- Extend the env with bindings for the tyvars, taken from
 251 -- the kind of the tycon/class.  Give it to the thing inside, and
 252 -- check the result kind matches
 253 kcTyClDeclBody tc_name hs_tyvars thing_inside
 254   = tcLookupGlobal tc_name              `thenNF_Tc` \ thing ->
 255     let
 256         kind = case thing of
 257                   ATyCon tc -> tyConKind tc
 258                   AClass cl -> tyConKind (classTyCon cl)
 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                            derived_classes
 300                            flavour is_rec gen_info
 301         gen_info = mkTyConGenInfo dflags tycon name1 name2
 302
 303         DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
 304
 305         tycon_kind = lookupNameEnv_NF kenv tycon_name
 306         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 307         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 308
 309         flavour = case data_or_new of
 310                         NewType -> NewTyCon (mkNewTyConRep tycon)
 311                         DataType | all isNullaryDataCon data_cons -> EnumTyCon
 312                                  | otherwise                      -> DataTyCon
 313
 314 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 315                   (ClassDecl context class_name
 316                              tyvar_names fundeps class_sigs def_methods
 317                              name_list src_loc)
 318   = (class_name, AClass clas)
 319   where
 320         (tycon_name, _, _, _) = getClassDeclSysNames name_list
 321         clas = mkClass class_name tyvars fds
 322                        sc_theta sc_sel_ids op_items
 323                        tycon
 324
 325         tycon = mkClassTyCon tycon_name class_kind tyvars
 326                              argvrcs dict_con
 327                              clas               -- Yes!  It's a dictionary
 328                              flavour
 329
 330         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 331
 332         class_kind = lookupNameEnv_NF kenv class_name
 333         tyvars     = mkTyClTyVars class_kind tyvar_names
 334         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 335         n_fields   = length sc_sel_ids + length op_items
 336
 337         flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
 338                 | otherwise     = DataTyCon
 339
 340         -- We can find the functional dependencies right away,
 341         -- and it is vital to do so. Why?  Because in the next pass
 342         -- we check for ambiguity in all the type signatures, and we
 343         -- need the functional dependcies to be done by then
 344         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 345         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 346         lookup     = lookupNameEnv_NF tyvar_env
 347
 348 bogusVrcs = panic "Bogus tycon arg variances"
 349 \end{code}
 350
 351
 352 %************************************************************************
 353 %*                                                                      *
 354 \subsection{Dependency analysis}
 355 %*                                                                      *
 356 %************************************************************************
 357
 358 Dependency analysis
 359 ~~~~~~~~~~~~~~~~~~~
 360 \begin{code}
 361 sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
 362 sortByDependency decls
 363   = let         -- CHECK FOR CLASS CYCLES
 364         cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
 365         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 366     in
 367     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 368
 369     let         -- CHECK FOR SYNONYM CYCLES
 370         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 371         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 372
 373     in
 374     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 375
 376         -- DO THE MAIN DEPENDENCY ANALYSIS
 377     let
 378         decl_sccs  = stronglyConnComp edges
 379     in
 380     returnTc decl_sccs
 381   where
 382     tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)]
 383     edges      = map mkEdges tycl_decls
 384
 385     is_syn_decl (d, _, _) = isSynDecl d
 386 \end{code}
 387
 388 Edges in Type/Class decls
 389 ~~~~~~~~~~~~~~~~~~~~~~~~~
 390
 391 \begin{code}
 392 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 393 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 394                where
 395                  add n fvs | isTyVarName n = fvs
 396                            | otherwise     = n : fvs
 397
 398 ----------------------------------------------------
 399 -- mk_cls_edges looks only at the context of class decls
 400 -- Its used when we are figuring out if there's a cycle in the
 401 -- superclass hierarchy
 402
 403 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 404
 405 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
 406 mkClassEdges other_decl                             = Nothing
 407
 408 ----------------------------------------------------
 409 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 410 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 411 \end{code}
 412
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsection{Error management
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 422
 423 typeCycleErr syn_cycles
 424   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 425
 426 classCycleErr cls_cycles
 427   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 428
 429 pp_cycle str decls
 430   = hang (text str)
 431          4 (vcat (map pp_decl decls))
 432   where
 433     pp_decl decl
 434       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 435      where
 436         name = tyClDeclName decl
 437
 438 \end{code}