compiler/iface/BuildTyCl.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 \begin{code}
   7 module BuildTyCl (
   8         buildSynTyCon,
   9         buildAlgTyCon,
  10         buildDataCon,
  11         TcMethInfo, buildClass,
  12         mkAbstractTyConRhs,
  13         mkNewTyConRhs, mkDataTyConRhs
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import IfaceEnv
  19
  20 import DataCon
  21 import Var
  22 import VarSet
  23 import BasicTypes
  24 import Name
  25 import MkId
  26 import Class
  27 import TyCon
  28 import Type
  29 import Coercion
  30
  31 import TcRnMonad
  32 import Data.List        ( partition )
  33 import Outputable
  34 \end{code}
  35
  36
  37 \begin{code}
  38 ------------------------------------------------------
  39 buildSynTyCon :: Name -> [TyVar]
  40               -> SynTyConRhs
  41               -> Kind                   -- ^ Kind of the RHS
  42               -> TyConParent
  43               -> Maybe (TyCon, [Type])    -- ^ family instance if applicable
  44               -> TcRnIf m n TyCon
  45 buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family
  46   | Just fam_inst_info <- mb_family
  47   = ASSERT( isNoParent parent )
  48     fixM $ \ tycon_rec -> do
  49     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
  50     ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
  51
  52   | otherwise
  53   = return (mkSynTyCon tc_name kind tvs rhs parent)
  54   where
  55     kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
  56
  57 ------------------------------------------------------
  58 buildAlgTyCon :: Name -> [TyVar]
  59               -> ThetaType              -- ^ Stupid theta
  60               -> AlgTyConRhs
  61               -> RecFlag
  62               -> Bool                   -- ^ True <=> want generics functions
  63               -> Bool                   -- ^ True <=> was declared in GADT syntax
  64               -> TyConParent
  65               -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
  66               -> TcRnIf m n TyCon
  67
  68 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
  69               parent mb_family
  70   | Just fam_inst_info <- mb_family
  71   = -- We need to tie a knot as the coercion of a data instance depends
  72      -- on the instance representation tycon and vice versa.
  73     ASSERT( isNoParent parent )
  74     fixM $ \ tycon_rec -> do
  75     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
  76     ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
  77                          fam_parent is_rec want_generics gadt_syn) }
  78
  79   | otherwise
  80   = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
  81                        parent is_rec want_generics gadt_syn)
  82   where
  83     kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
  84
  85 -- | If a family tycon with instance types is given, the current tycon is an
  86 -- instance of that family and we need to
  87 --
  88 -- (1) create a coercion that identifies the family instance type and the
  89 --     representation type from Step (1); ie, it is of the form
  90 --         `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
  91 --         `F' the family tycon and `R' the (derived) representation tycon,
  92 --         and
  93 -- (2) produce a `TyConParent' value containing the parent and coercion
  94 --     information.
  95 --
  96 mkFamInstParentInfo :: Name -> [TyVar]
  97                     -> (TyCon, [Type])
  98                     -> TyCon
  99                     -> TcRnIf m n TyConParent
 100 mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
 101   = do { -- Create the coercion
 102        ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
 103        ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
 104                                         family instTys rep_tycon
 105        ; return $ FamInstTyCon family instTys co_tycon }
 106
 107 ------------------------------------------------------
 108 mkAbstractTyConRhs :: AlgTyConRhs
 109 mkAbstractTyConRhs = AbstractTyCon
 110
 111 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 112 mkDataTyConRhs cons
 113   = DataTyCon {
 114         data_cons = cons,
 115         is_enum = -- We define datatypes with no constructors to not be
 116                   -- enumerations; this fixes trac #2578,  Otherwise we
 117                   -- end up generating an empty table for
 118                   --   <mod>_<type>_closure_tbl
 119                   -- which is used by tagToEnum# to map Int# to constructors
 120                   -- in an enumeration. The empty table apparently upset
 121                   -- the linker.
 122                   not (null cons) &&
 123                   all isNullarySrcDataCon cons
 124     }
 125
 126 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 127 -- ^ Monadic because it makes a Name for the coercion TyCon
 128 --   We pass the Name of the parent TyCon, as well as the TyCon itself,
 129 --   because the latter is part of a knot, whereas the former is not.
 130 mkNewTyConRhs tycon_name tycon con
 131   = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
 132         ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
 133               cocon_maybe | all_coercions || isRecursiveTyCon tycon
 134                           = Just co_tycon
 135                           | otherwise
 136                           = Nothing
 137         ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
 138         ; return (NewTyCon { data_con    = con,
 139                              nt_rhs      = rhs_ty,
 140                              nt_etad_rhs = (etad_tvs, etad_rhs),
 141                              nt_co       = cocon_maybe } ) }
 142                              -- Coreview looks through newtypes with a Nothing
 143                              -- for nt_co, or uses explicit coercions otherwise
 144   where
 145         -- If all_coercions is True then we use coercions for all newtypes
 146         -- otherwise we use coercions for recursive newtypes and look through
 147         -- non-recursive newtypes
 148     all_coercions = True
 149     tvs    = tyConTyVars tycon
 150     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
 151     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
 152         -- Instantiate the data con with the
 153         -- type variables from the tycon
 154         -- NB: a newtype DataCon has a type that must look like
 155         --        forall tvs.  <arg-ty> -> T tvs
 156         -- Note that we *can't* use dataConInstOrigArgTys here because
 157         -- the newtype arising from   class Foo a => Bar a where {}
 158         -- has a single argument (Foo a) that is a *type class*, so
 159         -- dataConInstOrigArgTys returns [].
 160
 161     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
 162     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
 163                         -- See Note [Tricky iface loop] in LoadIface
 164     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
 165
 166     eta_reduce :: [TyVar]               -- Reversed
 167                -> Type                  -- Rhs type
 168                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
 169     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
 170                            Just tv <- getTyVar_maybe arg,
 171                            tv == a,
 172                            not (a `elemVarSet` tyVarsOfType fun)
 173                          = eta_reduce as fun
 174     eta_reduce tvs ty = (reverse tvs, ty)
 175
 176
 177 ------------------------------------------------------
 178 buildDataCon :: Name -> Bool
 179             -> [HsBang]
 180             -> [Name]                   -- Field labels
 181             -> [TyVar] -> [TyVar]       -- Univ and ext
 182             -> [(TyVar,Type)]           -- Equality spec
 183             -> ThetaType                -- Does not include the "stupid theta"
 184                                         -- or the GADT equalities
 185             -> [Type] -> Type           -- Argument and result types
 186             -> TyCon                    -- Rep tycon
 187             -> TcRnIf m n DataCon
 188 -- A wrapper for DataCon.mkDataCon that
 189 --   a) makes the worker Id
 190 --   b) makes the wrapper Id if necessary, including
 191 --      allocating its unique (hence monadic)
 192 buildDataCon src_name declared_infix arg_stricts field_lbls
 193              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
 194   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 195         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 196         -- This last one takes the name of the data constructor in the source
 197         -- code, which (for Haskell source anyway) will be in the DataName name
 198         -- space, and puts it into the VarName name space
 199
 200         ; let
 201                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
 202                 data_con = mkDataCon src_name declared_infix
 203                                      arg_stricts field_lbls
 204                                      univ_tvs ex_tvs eq_spec ctxt
 205                                      arg_tys res_ty rep_tycon
 206                                      stupid_ctxt dc_ids
 207                 dc_ids = mkDataConIds wrap_name work_name data_con
 208
 209         ; return data_con }
 210
 211
 212 -- The stupid context for a data constructor should be limited to
 213 -- the type variables mentioned in the arg_tys
 214 -- ToDo: Or functionally dependent on?
 215 --       This whole stupid theta thing is, well, stupid.
 216 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 217 mkDataConStupidTheta tycon arg_tys univ_tvs
 218   | null stupid_theta = []      -- The common case
 219   | otherwise         = filter in_arg_tys stupid_theta
 220   where
 221     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
 222     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
 223         -- Start by instantiating the master copy of the
 224         -- stupid theta, taken from the TyCon
 225
 226     arg_tyvars      = tyVarsOfTypes arg_tys
 227     in_arg_tys pred = not $ isEmptyVarSet $
 228                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 229 \end{code}
 230
 231
 232 ------------------------------------------------------
 233 \begin{code}
 234 type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate
 235                                              -- between tcClassSigs and buildClass
 236
 237 buildClass :: Bool              -- True <=> do not include unfoldings
 238                                 --          on dict selectors
 239                                 -- Used when importing a class without -O
 240            -> Name -> [TyVar] -> ThetaType
 241            -> [FunDep TyVar]               -- Functional dependencies
 242            -> [TyThing]                    -- Associated types
 243            -> [TcMethInfo]                 -- Method info
 244            -> RecFlag                      -- Info for type constructor
 245            -> TcRnIf m n Class
 246
 247 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 248   = do  { traceIf (text "buildClass")
 249         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 250         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 251                 -- The class name is the 'parent' for this datacon, not its tycon,
 252                 -- because one should import the class to get the binding for
 253                 -- the datacon
 254
 255         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
 256
 257         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
 258                         -- Build the selector id and default method id
 259
 260         ; let (eq_theta, dict_theta) = partition isEqPred sc_theta
 261
 262               -- We only make selectors for the *value* superclasses,
 263               -- not equality predicates
 264         ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc)
 265                                 [1..length dict_theta]
 266         ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas
 267                            | sc_name <- sc_sel_names]
 268               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
 269               -- can construct names for the selectors. Thus
 270               --      class (C a, C b) => D a b where ...
 271               -- gives superclass selectors
 272               --      D_sc1, D_sc2
 273               -- (We used to call them D_C, but now we can have two different
 274               --  superclasses both called C!)
 275
 276         ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1)
 277                 -- Use a newtype if the data constructor has
 278                 --      (a) exactly one value field
 279                 --      (b) no existential or equality-predicate fields
 280                 -- i.e. exactly one operation or superclass taken together
 281                 -- See note [Class newtypes and equality predicates]
 282
 283                 -- We play a bit fast and loose by treating the dictionary
 284                 -- superclasses as ordinary arguments.  That means that in
 285                 -- the case of
 286                 --     class C a => D a
 287                 -- we don't get a newtype with no arguments!
 288               args      = sc_sel_names ++ op_names
 289               op_tys    = [ty | (_,_,ty) <- sig_stuff]
 290               op_names  = [op | (op,_,_) <- sig_stuff]
 291               arg_tys   = map mkPredTy dict_theta ++ op_tys
 292               rec_tycon = classTyCon rec_clas
 293
 294         ; dict_con <- buildDataCon datacon_name
 295                                    False        -- Not declared infix
 296                                    (map (const HsNoBang) args)
 297                                    [{- No fields -}]
 298                                    tvs [{- no existentials -}]
 299                                    [{- No GADT equalities -}]
 300                                    eq_theta
 301                                    arg_tys
 302                                    (mkTyConApp rec_tycon (mkTyVarTys tvs))
 303                                    rec_tycon
 304
 305         ; rhs <- if use_newtype
 306                  then mkNewTyConRhs tycon_name rec_tycon dict_con
 307                  else return (mkDataTyConRhs [dict_con])
 308
 309         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 310
 311               ; tycon = mkClassTyCon tycon_name clas_kind tvs
 312                                      rhs rec_clas tc_isrec
 313                 -- A class can be recursive, and in the case of newtypes
 314                 -- this matters.  For example
 315                 --      class C a where { op :: C b => a -> b -> Int }
 316                 -- Because C has only one operation, it is represented by
 317                 -- a newtype, and it should be a *recursive* newtype.
 318                 -- [If we don't make it a recursive newtype, we'll expand the
 319                 -- newtype like a synonym, but that will lead to an infinite
 320                 -- type]
 321               ; atTyCons = [tycon | ATyCon tycon <- ats]
 322
 323               ; result = mkClass class_name tvs fds
 324                                  (eq_theta ++ dict_theta)  -- Equalities first
 325                                  (length eq_theta)         -- Number of equalities
 326                                  sc_sel_ids atTyCons
 327                                  op_items tycon
 328               }
 329         ; traceIf (text "buildClass" <+> ppr tycon)
 330         ; return result
 331         })}
 332   where
 333     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
 334     mk_op_item rec_clas (op_name, dm_spec, _)
 335       = do { dm_info <- case dm_spec of
 336                           NoDM      -> return NoDefMeth
 337                           GenericDM -> return GenDefMeth
 338                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
 339                                           ; return (DefMeth dm_name) }
 340            ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
 341 \end{code}
 342
 343 Note [Class newtypes and equality predicates]
 344 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 345 Consider
 346         class (a ~ F b) => C a b where
 347           op :: a -> b
 348
 349 We cannot represent this by a newtype, even though it's not
 350 existential, and there's only one value field, because we do
 351 capture an equality predicate:
 352
 353         data C a b where
 354           MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
 355
 356 We need to access this equality predicate when we get passes a C
 357 dictionary.  See Trac #2238
 358