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