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