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