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               -> Maybe (TyCon, [Type])  -- family instance if applicable
  43               -> TcRnIf m n TyCon
  44
  45 buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
  46   = let
  47       kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
  48     in
  49     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
  50
  51 buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
  52   = do { -- We need to tie a knot as the coercion of a data instance depends
  53          -- on the instance representation tycon and vice versa.
  54        ; tycon <- fixM (\ tycon_rec -> do
  55          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  56          ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
  57                ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
  58                }
  59          ; return tycon
  60          })
  61        ; return tycon
  62        }
  63
  64 ------------------------------------------------------
  65 buildAlgTyCon :: Name -> [TyVar]
  66               -> ThetaType              -- Stupid theta
  67               -> AlgTyConRhs
  68               -> RecFlag
  69               -> Bool                   -- True <=> want generics functions
  70               -> Bool                   -- True <=> was declared in GADT syntax
  71               -> Maybe (TyCon, [Type])  -- family instance if applicable
  72               -> TcRnIf m n TyCon
  73
  74 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
  75               mb_family
  76   = do { -- We need to tie a knot as the coercion of a data instance depends
  77          -- on the instance representation tycon and vice versa.
  78        ; tycon <- fixM (\ tycon_rec -> do
  79          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  80          ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
  81                                     fields parent is_rec want_generics gadt_syn
  82                ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
  83                ; fields  = mkTyConSelIds tycon rhs
  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     rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))))
 151              -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
 152              head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
 153         -- Instantiate the data con with the
 154         -- type variables from the tycon
 155         -- NB: a newtype DataCon has no existentials; hence the
 156         --     call to dataConInstOrigArgTys has the right type args
 157
 158     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
 159     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
 160                         -- See Note [Tricky iface loop] in LoadIface
 161     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
 162
 163     eta_reduce :: [TyVar]               -- Reversed
 164                -> Type                  -- Rhs type
 165                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
 166     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
 167                            Just tv <- getTyVar_maybe arg,
 168                            tv == a,
 169                            not (a `elemVarSet` tyVarsOfType fun)
 170                          = eta_reduce as fun
 171     eta_reduce tvs ty = (reverse tvs, ty)
 172
 173
 174 ------------------------------------------------------
 175 buildDataCon :: Name -> Bool
 176             -> [StrictnessMark]
 177             -> [Name]                   -- Field labels
 178             -> [TyVar] -> [TyVar]       -- Univ and ext
 179             -> [(TyVar,Type)]           -- Equality spec
 180             -> ThetaType                -- Does not include the "stupid theta"
 181                                         -- or the GADT equalities
 182             -> [Type] -> TyCon
 183             -> TcRnIf m n DataCon
 184 -- A wrapper for DataCon.mkDataCon that
 185 --   a) makes the worker Id
 186 --   b) makes the wrapper Id if necessary, including
 187 --      allocating its unique (hence monadic)
 188 buildDataCon src_name declared_infix arg_stricts field_lbls
 189              univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
 190   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 191         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 192         -- This last one takes the name of the data constructor in the source
 193         -- code, which (for Haskell source anyway) will be in the DataName name
 194         -- space, and puts it into the VarName name space
 195
 196         ; let
 197                 stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
 198                 data_con = mkDataCon src_name declared_infix
 199                                      arg_stricts field_lbls
 200                                      univ_tvs ex_tvs eq_spec ctxt
 201                                      arg_tys tycon
 202                                      stupid_ctxt dc_ids
 203                 dc_ids = mkDataConIds wrap_name work_name data_con
 204
 205         ; return data_con }
 206
 207
 208 -- The stupid context for a data constructor should be limited to
 209 -- the type variables mentioned in the arg_tys
 210 -- ToDo: Or functionally dependent on?
 211 --       This whole stupid theta thing is, well, stupid.
 212 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 213 mkDataConStupidTheta tycon arg_tys univ_tvs
 214   | null stupid_theta = []      -- The common case
 215   | otherwise         = filter in_arg_tys stupid_theta
 216   where
 217     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
 218     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
 219         -- Start by instantiating the master copy of the
 220         -- stupid theta, taken from the TyCon
 221
 222     arg_tyvars      = tyVarsOfTypes arg_tys
 223     in_arg_tys pred = not $ isEmptyVarSet $
 224                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 225
 226 ------------------------------------------------------
 227 mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
 228 mkTyConSelIds tycon rhs
 229   =  [ mkRecordSelId tycon fld
 230      | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
 231         -- We'll check later that fields with the same name
 232         -- from different constructors have the same type.
 233 \end{code}
 234
 235
 236 ------------------------------------------------------
 237 \begin{code}
 238 buildClass :: Bool                      -- True <=> do not include unfoldings
 239                                         --          on dict selectors
 240                                         -- Used when importing a class without -O
 241            -> Name -> [TyVar] -> ThetaType
 242            -> [FunDep TyVar]            -- Functional dependencies
 243            -> [TyThing]                 -- Associated types
 244            -> [(Name, DefMeth, Type)]   -- Method info
 245            -> RecFlag                   -- Info for type constructor
 246            -> TcRnIf m n Class
 247
 248 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 249   = do  { traceIf (text "buildClass")
 250         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 251         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 252                 -- The class name is the 'parent' for this datacon, not its tycon,
 253                 -- because one should import the class to get the binding for
 254                 -- the datacon
 255
 256         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
 257
 258           let { rec_tycon  = classTyCon rec_clas
 259               ; op_tys     = [ty | (_,_,ty) <- sig_stuff]
 260               ; op_items   = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
 261                              | (op_name, dm_info, _) <- sig_stuff ] }
 262                         -- Build the selector id and default method id
 263
 264         ; dict_con <- buildDataCon datacon_name
 265                                    False        -- Not declared infix
 266                                    (map (const NotMarkedStrict) op_tys)
 267                                    [{- No labelled fields -}]
 268                                    tvs [{- no existentials -}]
 269                                    [{- No GADT equalities -}] sc_theta
 270                                    op_tys
 271                                    rec_tycon
 272
 273         ; let n_value_preds   = count (not . isEqPred) sc_theta
 274               all_value_preds = n_value_preds == length sc_theta
 275               -- We only make selectors for the *value* superclasses,
 276               -- not equality predicates
 277
 278         ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc)
 279                                 [1..n_value_preds]
 280         ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
 281               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
 282               -- can construct names for the selectors. Thus
 283               --      class (C a, C b) => D a b where ...
 284               -- gives superclass selectors
 285               --      D_sc1, D_sc2
 286               -- (We used to call them D_C, but now we can have two different
 287               --  superclasses both called C!)
 288               --
 289
 290         ; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
 291                 -- Use a newtype if the data constructor has
 292                 --      (a) exactly one value field
 293                 --      (b) no existential or equality-predicate fields
 294                 -- i.e. exactly one operation or superclass taken together
 295                 -- See note [Class newtypes and equality predicates]
 296
 297         ; rhs <- if use_newtype
 298                  then mkNewTyConRhs tycon_name rec_tycon dict_con
 299                  else return (mkDataTyConRhs [dict_con])
 300
 301         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 302
 303               ; tycon = mkClassTyCon tycon_name clas_kind tvs
 304                                      rhs rec_clas tc_isrec
 305                 -- A class can be recursive, and in the case of newtypes
 306                 -- this matters.  For example
 307                 --      class C a where { op :: C b => a -> b -> Int }
 308                 -- Because C has only one operation, it is represented by
 309                 -- a newtype, and it should be a *recursive* newtype.
 310                 -- [If we don't make it a recursive newtype, we'll expand the
 311                 -- newtype like a synonym, but that will lead to an infinite
 312                 -- type]
 313               ; atTyCons = [tycon | ATyCon tycon <- ats]
 314
 315               ; result = mkClass class_name tvs fds
 316                                  sc_theta sc_sel_ids atTyCons
 317                                  op_items tycon
 318               }
 319         ; traceIf (text "buildClass" <+> ppr tycon)
 320         ; return result
 321         })}
 322 \end{code}
 323
 324 Note [Class newtypes and equality predicates]
 325 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 326 Consider
 327         class (a ~ F b) => C a b where
 328           op :: a -> b
 329
 330 We cannot represent this by a newtype, even though it's not
 331 existential, and there's only one value field, because we do
 332 capture an equality predicate:
 333
 334         data C a b where
 335           MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
 336
 337 We need to access this equality predicate when we get passes a C
 338 dictionary.  See Trac #2238
 339