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         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 OccName
  24 import MkId
  25 import Class
  26 import TyCon
  27 import Type
  28 import Coercion
  29
  30 import TcRnMonad
  31 import Util             ( count )
  32 import Outputable
  33
  34 import Data.List
  35 \end{code}
  36
  37
  38 \begin{code}
  39 ------------------------------------------------------
  40 buildSynTyCon :: Name -> [TyVar]
  41               -> SynTyConRhs
  42               -> Kind                   -- Kind of the RHS
  43               -> Maybe (TyCon, [Type])  -- family instance if applicable
  44               -> TcRnIf m n TyCon
  45
  46 buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
  47   = let
  48       kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
  49     in
  50     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
  51
  52 buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
  53   = do { -- We need to tie a knot as the coercion of a data instance depends
  54          -- on the instance representation tycon and vice versa.
  55        ; tycon <- fixM (\ tycon_rec -> do
  56          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  57          ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
  58                ; kind    = mkArrowKinds (map tyVarKind tvs) rhs_kind
  59                }
  60          ; return tycon
  61          })
  62        ; return tycon
  63        }
  64
  65 ------------------------------------------------------
  66 buildAlgTyCon :: Name -> [TyVar]
  67               -> ThetaType              -- Stupid theta
  68               -> AlgTyConRhs
  69               -> RecFlag
  70               -> Bool                   -- True <=> want generics functions
  71               -> Bool                   -- True <=> was declared in GADT syntax
  72               -> Maybe (TyCon, [Type])  -- family instance if applicable
  73               -> TcRnIf m n TyCon
  74
  75 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
  76               mb_family
  77   = do { -- We need to tie a knot as the coercion of a data instance depends
  78          -- on the instance representation tycon and vice versa.
  79        ; tycon <- fixM (\ tycon_rec -> do
  80          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  81          ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
  82                                     parent is_rec want_generics gadt_syn
  83                ; kind  = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
  84                }
  85          ; return tycon
  86          })
  87        ; return tycon
  88        }
  89
  90 -- If a family tycon with instance types is given, the current tycon is an
  91 -- instance of that family and we need to
  92 --
  93 -- (1) create a coercion that identifies the family instance type and the
  94 --     representation type from Step (1); ie, it is of the form
  95 --         `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
  96 --         `F' the family tycon and `R' the (derived) representation tycon,
  97 --         and
  98 -- (2) produce a `TyConParent' value containing the parent and coercion
  99 --     information.
 100 --
 101 mkParentInfo :: Maybe (TyCon, [Type])
 102              -> Name -> [TyVar]
 103              -> TyCon
 104              -> TcRnIf m n TyConParent
 105 mkParentInfo Nothing                  _       _   _         =
 106   return NoParentTyCon
 107 mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
 108   do { -- Create the coercion
 109      ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
 110      ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
 111                                         family instTys rep_tycon
 112      ; return $ FamilyTyCon family instTys co_tycon
 113      }
 114
 115 ------------------------------------------------------
 116 mkAbstractTyConRhs :: AlgTyConRhs
 117 mkAbstractTyConRhs = AbstractTyCon
 118
 119 mkOpenDataTyConRhs :: AlgTyConRhs
 120 mkOpenDataTyConRhs = OpenTyCon Nothing
 121
 122 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 123 mkDataTyConRhs cons
 124   = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
 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 setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing
 178 setAssocFamilyPermutation clas_tvs (ATyCon tc)
 179   = ATyCon (setTyConArgPoss clas_tvs tc)
 180 setAssocFamilyPermutation _clas_tvs other
 181   = pprPanic "setAssocFamilyPermutation" (ppr other)
 182
 183
 184 ------------------------------------------------------
 185 buildDataCon :: Name -> Bool
 186             -> [StrictnessMark]
 187             -> [Name]                   -- Field labels
 188             -> [TyVar] -> [TyVar]       -- Univ and ext
 189             -> [(TyVar,Type)]           -- Equality spec
 190             -> ThetaType                -- Does not include the "stupid theta"
 191                                         -- or the GADT equalities
 192             -> [Type] -> Type           -- Argument and result types
 193             -> TyCon                    -- Rep tycon
 194             -> TcRnIf m n DataCon
 195 -- A wrapper for DataCon.mkDataCon that
 196 --   a) makes the worker Id
 197 --   b) makes the wrapper Id if necessary, including
 198 --      allocating its unique (hence monadic)
 199 buildDataCon src_name declared_infix arg_stricts field_lbls
 200              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
 201   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 202         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 203         -- This last one takes the name of the data constructor in the source
 204         -- code, which (for Haskell source anyway) will be in the DataName name
 205         -- space, and puts it into the VarName name space
 206
 207         ; let
 208                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
 209                 data_con = mkDataCon src_name declared_infix
 210                                      arg_stricts field_lbls
 211                                      univ_tvs ex_tvs eq_spec ctxt
 212                                      arg_tys res_ty rep_tycon
 213                                      stupid_ctxt dc_ids
 214                 dc_ids = mkDataConIds wrap_name work_name data_con
 215
 216         ; return data_con }
 217
 218
 219 -- The stupid context for a data constructor should be limited to
 220 -- the type variables mentioned in the arg_tys
 221 -- ToDo: Or functionally dependent on?
 222 --       This whole stupid theta thing is, well, stupid.
 223 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 224 mkDataConStupidTheta tycon arg_tys univ_tvs
 225   | null stupid_theta = []      -- The common case
 226   | otherwise         = filter in_arg_tys stupid_theta
 227   where
 228     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
 229     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
 230         -- Start by instantiating the master copy of the
 231         -- stupid theta, taken from the TyCon
 232
 233     arg_tyvars      = tyVarsOfTypes arg_tys
 234     in_arg_tys pred = not $ isEmptyVarSet $
 235                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 236 \end{code}
 237
 238
 239 ------------------------------------------------------
 240 \begin{code}
 241 buildClass :: Bool                      -- True <=> do not include unfoldings
 242                                         --          on dict selectors
 243                                         -- Used when importing a class without -O
 244            -> Name -> [TyVar] -> ThetaType
 245            -> [FunDep TyVar]            -- Functional dependencies
 246            -> [TyThing]                 -- Associated types
 247            -> [(Name, DefMeth, Type)]   -- Method info
 248            -> RecFlag                   -- Info for type constructor
 249            -> TcRnIf m n Class
 250
 251 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 252   = do  { traceIf (text "buildClass")
 253         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 254         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 255                 -- The class name is the 'parent' for this datacon, not its tycon,
 256                 -- because one should import the class to get the binding for
 257                 -- the datacon
 258
 259         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
 260
 261           let { rec_tycon  = classTyCon rec_clas
 262               ; op_tys     = [ty | (_,_,ty) <- sig_stuff]
 263               ; op_names   = [op | (op,_,_) <- sig_stuff]
 264               ; op_items   = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
 265                              | (op_name, dm_info, _) <- sig_stuff ] }
 266                         -- Build the selector id and default method id
 267
 268         ; let n_value_preds   = count (not . isEqPred) sc_theta
 269               all_value_preds = n_value_preds == length sc_theta
 270               -- We only make selectors for the *value* superclasses,
 271               -- not equality predicates
 272
 273         ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc)
 274                                 [1..n_value_preds]
 275         ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
 276               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
 277               -- can construct names for the selectors. Thus
 278               --      class (C a, C b) => D a b where ...
 279               -- gives superclass selectors
 280               --      D_sc1, D_sc2
 281               -- (We used to call them D_C, but now we can have two different
 282               --  superclasses both called C!)
 283               --
 284
 285         ; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
 286                 -- Use a newtype if the data constructor has
 287                 --      (a) exactly one value field
 288                 --      (b) no existential or equality-predicate fields
 289                 -- i.e. exactly one operation or superclass taken together
 290                 -- See note [Class newtypes and equality predicates]
 291
 292                 -- We play a bit fast and loose by treating the superclasses
 293                 -- as ordinary arguments.  That means that in the case of
 294                 --     class C a => D a
 295                 -- we don't get a newtype with no arguments!
 296               args    = sc_sel_names ++ op_names
 297               arg_tys = map mkPredTy sc_theta ++ op_tys
 298
 299         ; dict_con <- buildDataCon datacon_name
 300                                    False        -- Not declared infix
 301                                    (map (const NotMarkedStrict) args)
 302                                    [{- No fields -}]
 303                                    tvs [{- no existentials -}]
 304                                    [{- No GADT equalities -}] [{- No theta -}]
 305                                    arg_tys
 306                                    (mkTyConApp rec_tycon (mkTyVarTys tvs))
 307                                    rec_tycon
 308
 309         ; rhs <- if use_newtype
 310                  then mkNewTyConRhs tycon_name rec_tycon dict_con
 311                  else return (mkDataTyConRhs [dict_con])
 312
 313         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 314
 315               ; tycon = mkClassTyCon tycon_name clas_kind tvs
 316                                      rhs rec_clas tc_isrec
 317                 -- A class can be recursive, and in the case of newtypes
 318                 -- this matters.  For example
 319                 --      class C a where { op :: C b => a -> b -> Int }
 320                 -- Because C has only one operation, it is represented by
 321                 -- a newtype, and it should be a *recursive* newtype.
 322                 -- [If we don't make it a recursive newtype, we'll expand the
 323                 -- newtype like a synonym, but that will lead to an infinite
 324                 -- type]
 325               ; atTyCons = [tycon | ATyCon tycon <- ats]
 326
 327               ; result = mkClass class_name tvs fds
 328                                  sc_theta sc_sel_ids atTyCons
 329                                  op_items tycon
 330               }
 331         ; traceIf (text "buildClass" <+> ppr tycon)
 332         ; return result
 333         })}
 334 \end{code}
 335
 336 Note [Class newtypes and equality predicates]
 337 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 338 Consider
 339         class (a ~ F b) => C a b where
 340           op :: a -> b
 341
 342 We cannot represent this by a newtype, even though it's not
 343 existential, and there's only one value field, because we do
 344 capture an equality predicate:
 345
 346         data C a b where
 347           MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
 348
 349 We need to access this equality predicate when we get passes a C
 350 dictionary.  See Trac #2238
 351