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