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