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 import TcRnMonad
  18
  19 import DataCon
  20 import Var
  21 import VarSet
  22 import TysWiredIn
  23 import BasicTypes
  24 import Name
  25 import OccName
  26 import MkId
  27 import Class
  28 import TyCon
  29 import Type
  30 import Coercion
  31
  32 import TcRnMonad
  33 import Outputable
  34
  35 import Data.List
  36 \end{code}
  37
  38
  39 \begin{code}
  40 ------------------------------------------------------
  41 buildSynTyCon :: Name -> [TyVar]
  42               -> SynTyConRhs
  43               -> Maybe (TyCon, [Type])  -- family instance if applicable
  44               -> TcRnIf m n TyCon
  45
  46 buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
  47   = let
  48       kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
  49     in
  50     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
  51
  52 buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) 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) (typeKind rhs_ty)
  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                              nt_rep = mkNewTyConRep tycon rhs_ty }) }
 146   where
 147         -- If all_coercions is True then we use coercions for all newtypes
 148         -- otherwise we use coercions for recursive newtypes and look through
 149         -- non-recursive newtypes
 150     all_coercions = True
 151     tvs    = tyConTyVars tycon
 152     rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))))
 153              -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
 154              head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
 155         -- Instantiate the data con with the
 156         -- type variables from the tycon
 157         -- NB: a newtype DataCon has no existentials; hence the
 158         --     call to dataConInstOrigArgTys has the right type args
 159
 160     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
 161     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
 162                         -- See Note [Tricky iface loop] in LoadIface
 163     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
 164
 165     eta_reduce :: [TyVar]               -- Reversed
 166                -> Type                  -- Rhs type
 167                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
 168     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
 169                            Just tv <- getTyVar_maybe arg,
 170                            tv == a,
 171                            not (a `elemVarSet` tyVarsOfType fun)
 172                          = eta_reduce as fun
 173     eta_reduce tvs ty = (reverse tvs, ty)
 174
 175
 176 mkNewTyConRep :: TyCon          -- The original type constructor
 177               -> Type           -- The arg type of its constructor
 178               -> Type           -- Chosen representation type
 179 -- The "representation type" is guaranteed not to be another newtype
 180 -- at the outermost level; but it might have newtypes in type arguments
 181
 182 -- Find the representation type for this newtype TyCon
 183 -- Remember that the representation type is the *ultimate* representation
 184 -- type, looking through other newtypes.
 185 --
 186 -- splitTyConApp_maybe no longer looks through newtypes, so we must
 187 -- deal explicitly with this case
 188 --
 189 -- The trick is to to deal correctly with recursive newtypes
 190 -- such as      newtype T = MkT T
 191
 192 mkNewTyConRep tc rhs_ty
 193   | null (tyConDataCons tc) = unitTy
 194         -- External Core programs can have newtypes with no data constructors
 195   | otherwise               = go [tc] rhs_ty
 196   where
 197         -- Invariant: tcs have been seen before
 198     go tcs rep_ty
 199         = case splitTyConApp_maybe rep_ty of
 200             Just (tc, tys)
 201                 | tc `elem` tcs -> unitTy       -- Recursive loop
 202                 | isNewTyCon tc ->
 203                     if isRecursiveTyCon tc then
 204                         go (tc:tcs) (substTyWith tvs tys rhs_ty)
 205                     else
 206                         substTyWith tvs tys rhs_ty
 207                 where
 208                   (tvs, rhs_ty) = newTyConRhs tc
 209
 210             other -> rep_ty
 211
 212 ------------------------------------------------------
 213 buildDataCon :: Name -> Bool
 214             -> [StrictnessMark]
 215             -> [Name]                   -- Field labels
 216             -> [TyVar] -> [TyVar]       -- Univ and ext
 217             -> [(TyVar,Type)]           -- Equality spec
 218             -> ThetaType                -- Does not include the "stupid theta"
 219                                         -- or the GADT equalities
 220             -> [Type] -> TyCon
 221             -> TcRnIf m n DataCon
 222 -- A wrapper for DataCon.mkDataCon that
 223 --   a) makes the worker Id
 224 --   b) makes the wrapper Id if necessary, including
 225 --      allocating its unique (hence monadic)
 226 buildDataCon src_name declared_infix arg_stricts field_lbls
 227              univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
 228   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 229         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 230         -- This last one takes the name of the data constructor in the source
 231         -- code, which (for Haskell source anyway) will be in the DataName name
 232         -- space, and puts it into the VarName name space
 233
 234         ; let
 235                 stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
 236                 data_con = mkDataCon src_name declared_infix
 237                                      arg_stricts field_lbls
 238                                      univ_tvs ex_tvs eq_spec ctxt
 239                                      arg_tys tycon
 240                                      stupid_ctxt dc_ids
 241                 dc_ids = mkDataConIds wrap_name work_name data_con
 242
 243         ; returnM data_con }
 244
 245
 246 -- The stupid context for a data constructor should be limited to
 247 -- the type variables mentioned in the arg_tys
 248 -- ToDo: Or functionally dependent on?
 249 --       This whole stupid theta thing is, well, stupid.
 250 mkDataConStupidTheta tycon arg_tys univ_tvs
 251   | null stupid_theta = []      -- The common case
 252   | otherwise         = filter in_arg_tys stupid_theta
 253   where
 254     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
 255     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
 256         -- Start by instantiating the master copy of the
 257         -- stupid theta, taken from the TyCon
 258
 259     arg_tyvars      = tyVarsOfTypes arg_tys
 260     in_arg_tys pred = not $ isEmptyVarSet $
 261                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 262
 263 ------------------------------------------------------
 264 mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
 265 mkTyConSelIds tycon rhs
 266   =  [ mkRecordSelId tycon fld
 267      | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
 268         -- We'll check later that fields with the same name
 269         -- from different constructors have the same type.
 270 \end{code}
 271
 272
 273 ------------------------------------------------------
 274 \begin{code}
 275 buildClass :: Name -> [TyVar] -> ThetaType
 276            -> [FunDep TyVar]            -- Functional dependencies
 277            -> [TyThing]                 -- Associated types
 278            -> [(Name, DefMeth, Type)]   -- Method info
 279            -> RecFlag                   -- Info for type constructor
 280            -> TcRnIf m n Class
 281
 282 buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 283   = do  { traceIf (text "buildClass")
 284         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 285         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 286                 -- The class name is the 'parent' for this datacon, not its tycon,
 287                 -- because one should import the class to get the binding for
 288                 -- the datacon
 289
 290         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
 291
 292           let { rec_tycon  = classTyCon rec_clas
 293               ; op_tys     = [ty | (_,_,ty) <- sig_stuff]
 294               ; op_items   = [ (mkDictSelId op_name rec_clas, dm_info)
 295                              | (op_name, dm_info, _) <- sig_stuff ] }
 296                         -- Build the selector id and default method id
 297
 298         ; dict_con <- buildDataCon datacon_name
 299                                    False        -- Not declared infix
 300                                    (map (const NotMarkedStrict) op_tys)
 301                                    [{- No labelled fields -}]
 302                                    tvs [{- no existentials -}]
 303                                    [{- No GADT equalities -}] sc_theta
 304                                    op_tys
 305                                    rec_tycon
 306
 307         ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc)
 308                                 [1..length (dataConDictTheta dict_con)]
 309               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
 310               -- can construct names for the selectors.  Thus
 311               --      class (C a, C b) => D a b where ...
 312               -- gives superclass selectors
 313               --      D_sc1, D_sc2
 314               -- (We used to call them D_C, but now we can have two different
 315               --  superclasses both called C!)
 316         ; let sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]
 317
 318                 -- Use a newtype if the class constructor has exactly one field:
 319                 -- i.e. exactly one operation or superclass taken together
 320                 -- Watch out: the sc_theta includes equality predicates,
 321                 --            which don't count for this purpose; hence dataConDictTheta
 322         ; rhs <- if ((length $ dataConDictTheta dict_con) + length sig_stuff) == 1
 323                  then mkNewTyConRhs tycon_name rec_tycon dict_con
 324                  else return (mkDataTyConRhs [dict_con])
 325
 326         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 327
 328               ; tycon = mkClassTyCon tycon_name clas_kind tvs
 329                                      rhs rec_clas tc_isrec
 330                 -- A class can be recursive, and in the case of newtypes
 331                 -- this matters.  For example
 332                 --      class C a where { op :: C b => a -> b -> Int }
 333                 -- Because C has only one operation, it is represented by
 334                 -- a newtype, and it should be a *recursive* newtype.
 335                 -- [If we don't make it a recursive newtype, we'll expand the
 336                 -- newtype like a synonym, but that will lead to an infinite
 337                 -- type]
 338               ; atTyCons = [tycon | ATyCon tycon <- ats]
 339
 340               ; result = mkClass class_name tvs fds
 341                                  sc_theta sc_sel_ids atTyCons
 342                                  op_items tycon
 343               }
 344         ; traceIf (text "buildClass" <+> ppr tycon)
 345         ; return result
 346         })}
 347 \end{code}
 348
 349