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(..),
  15                           ConDecl(..),   Sig(..), HsPred(..),
  16                           tyClDeclName, hsTyVarNames, tyClDeclTyVars,
  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 )
  27 import TcClassDcl       ( tcClassDecl1 )
  28 import TcInstDcls       ( tcAddDeclCtxt )
  29 import TcMonoType       ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
  30 import TcMType          ( unifyKind, newKindVar, zonkKindEnv )
  31 import TcType           ( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
  32 import Variance         ( calcTyConArgVrcs )
  33 import Class            ( Class, mkClass, classTyCon )
  34 import TyCon            ( TyCon, ArgVrcs, AlgTyConFlavour(..),
  35                           tyConKind, tyConDataCons,
  36                           mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
  37                           isRecursiveTyCon )
  38 import DataCon          ( dataConOrigArgTys )
  39 import Var              ( varName )
  40 import FiniteMap
  41 import Digraph          ( stronglyConnComp, SCC(..) )
  42 import Name             ( Name, getSrcLoc, isTyVarName )
  43 import NameEnv
  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 unlifted 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     traceTc (text "starting" <+> ppr final_kinds)               `thenTc_`
 138     fixTc ( \ ~(rec_details_list, _, _) ->
 139                 -- Step 4
 140         let
 141             kind_env    = mkNameEnv final_kinds
 142             rec_details = mkNameEnv rec_details_list
 143
 144             tyclss, all_tyclss :: [TyThing]
 145             tyclss = map (buildTyConOrClass dflags is_rec kind_env
 146                                                    rec_vrcs rec_details) decls
 147
 148                 -- Add the tycons that come from the classes
 149                 -- We want them in the environment because
 150                 -- they are mentioned in interface files
 151             all_tyclss  = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
 152                           ++ tyclss
 153
 154                 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
 155             rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
 156         in
 157                 -- Step 5
 158         tcExtendGlobalEnv all_tyclss                    $
 159         mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
 160
 161                 -- Return results
 162         tcGetEnv                                        `thenNF_Tc` \ env ->
 163         returnTc (tycls_details, all_tyclss, env)
 164     )                                           `thenTc` \ (_, all_tyclss, env) ->
 165
 166     tcSetEnv env                                $
 167
 168     traceTc (text "ready for pass 2" <+> ppr (isRec is_rec))                    `thenTc_`
 169
 170         -- Step 6
 171         -- For a recursive group, check all the types again,
 172         -- this time with the wimp flag off
 173     (if isRec is_rec then
 174         mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
 175      else
 176         returnTc ()
 177     )                                           `thenTc_`
 178
 179     traceTc (text "done")                       `thenTc_`
 180
 181         -- Step 7
 182         -- Extend the environment with the final TyCons/Classes
 183         -- and their implicit Ids
 184     tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
 185
 186   where
 187     is_rec = case scc of
 188                 AcyclicSCC _ -> NonRecursive
 189                 CyclicSCC _  -> Recursive
 190
 191     decls = case scc of
 192                 AcyclicSCC decl -> [decl]
 193                 CyclicSCC decls -> decls
 194
 195 tcTyClDecl1 is_rec unf_env decl
 196   | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
 197   | otherwise        = tcAddDeclCtxt decl (tcTyDecl1    is_rec unf_env decl)
 198 \end{code}
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection{Step 1: Initial environment}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 209 getInitialKind decl
 210  = kcHsTyVars (tyClDeclTyVars decl)     `thenNF_Tc` \ arg_kinds ->
 211    newKindVar                           `thenNF_Tc` \ result_kind  ->
 212    returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
 213
 214 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
 215 \end{code}
 216
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection{Step 2: Kind checking}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 We need to kind check all types in the mutually recursive group
 225 before we know the kind of the type variables.  For example:
 226
 227 class C a where
 228    op :: D b => a -> b -> b
 229
 230 class D c where
 231    bop :: (Monad c) => ...
 232
 233 Here, the kind of the locally-polymorphic type variable "b"
 234 depends on *all the uses of class D*.  For example, the use of
 235 Monad c in bop's type signature means that D must have kind Type->Type.
 236
 237 \begin{code}
 238 kcTyClDecl :: RenamedTyClDecl -> TcM ()
 239
 240 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
 241   = kcTyClDeclBody decl         $ \ result_kind ->
 242     kcHsType rhs                `thenTc` \ rhs_kind ->
 243     unifyKind result_kind rhs_kind
 244
 245 kcTyClDecl (ForeignType {}) = returnTc ()
 246
 247 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
 248   = kcTyClDeclBody decl                 $ \ result_kind ->
 249     kcHsContext context                 `thenTc_`
 250     mapTc_ kc_con_decl con_decls
 251   where
 252     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
 253       = kcHsTyVars ex_tvs               `thenNF_Tc` \ kind_env ->
 254         tcExtendKindEnv kind_env        $
 255         kcConDetails new_or_data ex_ctxt details
 256
 257 kcTyClDecl decl@(ClassDecl {tcdCtxt = context,  tcdSigs = class_sigs})
 258   = kcTyClDeclBody decl         $ \ result_kind ->
 259     kcHsContext context         `thenTc_`
 260     mapTc_ kc_sig (filter isClassOpSig class_sigs)
 261   where
 262     kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
 263
 264 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
 265 -- Extend the env with bindings for the tyvars, taken from
 266 -- the kind of the tycon/class.  Give it to the thing inside, and
 267 -- check the result kind matches
 268 kcTyClDeclBody decl thing_inside
 269   = tcAddDeclCtxt decl          $
 270     tcLookup (tcdName decl)     `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 (tyClDeclTyVars decl)) 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 -> TyThing
 296
 297 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
 298                   (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
 299   = ATyCon tycon
 300   where
 301         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 302         tycon_kind          = lookupNameEnv_NF kenv tycon_name
 303         arity               = length tyvar_names
 304         tyvars              = mkTyClTyVars tycon_kind tyvar_names
 305         SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
 306         argvrcs             = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 307
 308 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 309                   (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
 310                            tcdNCons = nconstrs, tcdSysNames = sys_names})
 311   = ATyCon tycon
 312   where
 313         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
 314                            data_cons nconstrs sel_ids
 315                            flavour is_rec gen_info
 316
 317         gen_info | not (dopt Opt_Generics dflags) = Nothing
 318                  | otherwise = mkTyConGenInfo tycon sys_names
 319
 320         DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
 321
 322         tycon_kind = lookupNameEnv_NF kenv tycon_name
 323         tyvars     = mkTyClTyVars tycon_kind tyvar_names
 324         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 325
 326         -- Watch out!  mkTyConApp asks whether the tycon is a NewType,
 327         -- so flavour has to be able to answer this question without consulting rec_details
 328         flavour = case data_or_new of
 329                     NewType  -> NewTyCon (mkNewTyConRep tycon)
 330                     DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
 331                              | otherwise                                -> DataTyCon
 332                         -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
 333                         -- but that looks at the *representation* arity, and that in turn
 334                         -- depends on deciding whether to unpack the args, and that
 335                         -- depends on whether it's a data type or a newtype --- so
 336                         -- in the recursive case we can get a loop.  This version is simple!
 337
 338 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 339                   (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
 340   = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
 341
 342 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 343                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
 344                               tcdFDs = fundeps, tcdSysNames = name_list} )
 345   = AClass clas
 346   where
 347         (tycon_name, _, _, _) = getClassDeclSysNames name_list
 348         clas = mkClass class_name tyvars fds
 349                        sc_theta sc_sel_ids op_items
 350                        tycon
 351
 352         tycon = mkClassTyCon tycon_name class_kind tyvars
 353                              argvrcs dict_con
 354                              clas               -- Yes!  It's a dictionary
 355                              flavour
 356                              is_rec
 357                 -- A class can be recursive, and in the case of newtypes
 358                 -- this matters.  For example
 359                 --      class C a where { op :: C b => a -> b -> Int }
 360                 -- Because C has only one operation, it is represented by
 361                 -- a newtype, and it should be a *recursive* newtype.
 362                 -- [If we don't make it a recursive newtype, we'll expand the
 363                 -- newtype like a synonym, but that will lead toan inifinite type
 364
 365         ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 366
 367         class_kind = lookupNameEnv_NF kenv class_name
 368         tyvars     = mkTyClTyVars class_kind tyvar_names
 369         argvrcs    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 370
 371         flavour = case dataConOrigArgTys dict_con of
 372                         -- The tyvars in the datacon are the same as in the class
 373                     [rep_ty] -> NewTyCon rep_ty
 374                     other    -> DataTyCon
 375
 376         -- We can find the functional dependencies right away,
 377         -- and it is vital to do so. Why?  Because in the next pass
 378         -- we check for ambiguity in all the type signatures, and we
 379         -- need the functional dependcies to be done by then
 380         fds        = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
 381         tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
 382         lookup     = lookupNameEnv_NF tyvar_env
 383
 384 bogusVrcs = panic "Bogus tycon arg variances"
 385 \end{code}
 386
 387 \begin{code}
 388 mkNewTyConRep :: TyCon          -- The original type constructor
 389               -> Type           -- Chosen representation type
 390 -- Find the representation type for this newtype TyCon
 391 -- For a recursive type constructor we give an error thunk,
 392 -- because we never look at the rep in that case
 393 -- (see notes on newypes in types/TypeRep
 394
 395 mkNewTyConRep tc
 396   | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
 397   | otherwise           = head (dataConOrigArgTys (head (tyConDataCons tc)))
 398 \end{code}
 399
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsection{Dependency analysis}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 Dependency analysis
 408 ~~~~~~~~~~~~~~~~~~~
 409 \begin{code}
 410 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
 411 sortByDependency decls
 412   = let         -- CHECK FOR CLASS CYCLES
 413         cls_sccs   = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
 414         cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
 415     in
 416     checkTc (null cls_cycles) (classCycleErr cls_cycles)        `thenTc_`
 417
 418     let         -- CHECK FOR SYNONYM CYCLES
 419         syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
 420         syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
 421
 422     in
 423     checkTc (null syn_cycles) (typeCycleErr syn_cycles)         `thenTc_`
 424
 425         -- DO THE MAIN DEPENDENCY ANALYSIS
 426     let
 427         decl_sccs  = stronglyConnComp edges
 428     in
 429     returnTc decl_sccs
 430   where
 431     tycl_decls = filter (not . isIfaceSigDecl) decls
 432     edges      = map mkEdges tycl_decls
 433
 434     is_syn_decl (d, _, _) = isSynDecl d
 435 \end{code}
 436
 437 Edges in Type/Class decls
 438 ~~~~~~~~~~~~~~~~~~~~~~~~~
 439
 440 \begin{code}
 441 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
 442         -- Find the free non-tyvar vars
 443 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 444                where
 445                  add n fvs | isTyVarName n = fvs
 446                            | otherwise     = n : fvs
 447
 448 ----------------------------------------------------
 449 -- mk_cls_edges looks only at the context of class decls
 450 -- Its used when we are figuring out if there's a cycle in the
 451 -- superclass hierarchy
 452
 453 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 454
 455 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
 456 mkClassEdges other_decl                                        = Nothing
 457
 458 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
 459 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
 460 \end{code}
 461
 462
 463 %************************************************************************
 464 %*                                                                      *
 465 \subsection{Error management
 466 %*                                                                      *
 467 %************************************************************************
 468
 469 \begin{code}
 470 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 471
 472 typeCycleErr syn_cycles
 473   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 474
 475 classCycleErr cls_cycles
 476   = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
 477
 478 pp_cycle str decls
 479   = hang (text str)
 480          4 (vcat (map pp_decl decls))
 481   where
 482     pp_decl decl
 483       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
 484      where
 485         name = tyClDeclName decl
 486
 487 \end{code}