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