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, mkOpenNewTyConRhs,
  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 Data.List
  33 \end{code}
  34
  35
  36 \begin{code}
  37 ------------------------------------------------------
  38 buildSynTyCon :: Name -> [TyVar]
  39               -> SynTyConRhs
  40               -> Maybe (TyCon, [Type])  -- family instance if applicable
  41               -> TcRnIf m n TyCon
  42
  43 buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
  44   = let
  45       kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
  46     in
  47     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
  48
  49 buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
  50   = do { -- We need to tie a knot as the coercion of a data instance depends
  51          -- on the instance representation tycon and vice versa.
  52        ; tycon <- fixM (\ tycon_rec -> do
  53          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  54          ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
  55                ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
  56                }
  57          ; return tycon
  58          })
  59        ; return tycon
  60        }
  61
  62 ------------------------------------------------------
  63 buildAlgTyCon :: Name -> [TyVar]
  64               -> ThetaType              -- Stupid theta
  65               -> AlgTyConRhs
  66               -> RecFlag
  67               -> Bool                   -- True <=> want generics functions
  68               -> Bool                   -- True <=> was declared in GADT syntax
  69               -> Maybe (TyCon, [Type])  -- family instance if applicable
  70               -> TcRnIf m n TyCon
  71
  72 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
  73               mb_family
  74   = do { -- We need to tie a knot as the coercion of a data instance depends
  75          -- on the instance representation tycon and vice versa.
  76        ; tycon <- fixM (\ tycon_rec -> do
  77          { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
  78          ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
  79                                     fields parent is_rec want_generics gadt_syn
  80                ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
  81                ; fields  = mkTyConSelIds tycon rhs
  82                }
  83          ; return tycon
  84          })
  85        ; return tycon
  86        }
  87
  88 -- If a family tycon with instance types is given, the current tycon is an
  89 -- instance of that family and we need to
  90 --
  91 -- (1) create a coercion that identifies the family instance type and the
  92 --     representation type from Step (1); ie, it is of the form
  93 --         `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
  94 --         `F' the family tycon and `R' the (derived) representation tycon,
  95 --         and
  96 -- (2) produce a `TyConParent' value containing the parent and coercion
  97 --     information.
  98 --
  99 mkParentInfo :: Maybe (TyCon, [Type])
 100              -> Name -> [TyVar]
 101              -> TyCon
 102              -> TcRnIf m n TyConParent
 103 mkParentInfo Nothing                  _       _   _         =
 104   return NoParentTyCon
 105 mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
 106   do { -- Create the coercion
 107      ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
 108      ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
 109                                         family instTys rep_tycon
 110      ; return $ FamilyTyCon family instTys co_tycon
 111      }
 112
 113 ------------------------------------------------------
 114 mkAbstractTyConRhs :: AlgTyConRhs
 115 mkAbstractTyConRhs = AbstractTyCon
 116
 117 mkOpenDataTyConRhs :: AlgTyConRhs
 118 mkOpenDataTyConRhs = OpenTyCon Nothing False
 119
 120 mkOpenNewTyConRhs :: AlgTyConRhs
 121 mkOpenNewTyConRhs = OpenTyCon Nothing True
 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         ; 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                              nt_rep = mkNewTyConRep tycon rhs_ty }) }
 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     rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
 152         -- Instantiate the data con with the
 153         -- type variables from the tycon
 154
 155     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
 156     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
 157                         -- See Note [Tricky iface loop] in LoadIface
 158     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
 159
 160     eta_reduce :: [TyVar]               -- Reversed
 161                -> Type                  -- Rhs type
 162                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
 163     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
 164                            Just tv <- getTyVar_maybe arg,
 165                            tv == a,
 166                            not (a `elemVarSet` tyVarsOfType fun)
 167                          = eta_reduce as fun
 168     eta_reduce tvs ty = (reverse tvs, ty)
 169
 170
 171 mkNewTyConRep :: TyCon          -- The original type constructor
 172               -> Type           -- The arg type of its constructor
 173               -> Type           -- Chosen representation type
 174 -- The "representation type" is guaranteed not to be another newtype
 175 -- at the outermost level; but it might have newtypes in type arguments
 176
 177 -- Find the representation type for this newtype TyCon
 178 -- Remember that the representation type is the *ultimate* representation
 179 -- type, looking through other newtypes.
 180 --
 181 -- splitTyConApp_maybe no longer looks through newtypes, so we must
 182 -- deal explicitly with this case
 183 --
 184 -- The trick is to to deal correctly with recursive newtypes
 185 -- such as      newtype T = MkT T
 186
 187 mkNewTyConRep tc rhs_ty
 188   | null (tyConDataCons tc) = unitTy
 189         -- External Core programs can have newtypes with no data constructors
 190   | otherwise               = go [tc] rhs_ty
 191   where
 192         -- Invariant: tcs have been seen before
 193     go tcs rep_ty
 194         = case splitTyConApp_maybe rep_ty of
 195             Just (tc, tys)
 196                 | tc `elem` tcs -> unitTy       -- Recursive loop
 197                 | isNewTyCon tc ->
 198                     if isRecursiveTyCon tc then
 199                         go (tc:tcs) (substTyWith tvs tys rhs_ty)
 200                     else
 201                         substTyWith tvs tys rhs_ty
 202                 where
 203                   (tvs, rhs_ty) = newTyConRhs tc
 204
 205             other -> rep_ty
 206
 207 ------------------------------------------------------
 208 buildDataCon :: Name -> Bool
 209             -> [StrictnessMark]
 210             -> [Name]                   -- Field labels
 211             -> [TyVar] -> [TyVar]       -- Univ and ext
 212             -> [(TyVar,Type)]           -- Equality spec
 213             -> ThetaType                -- Does not include the "stupid theta"
 214                                         -- or the GADT equalities
 215             -> [Type] -> TyCon
 216             -> TcRnIf m n DataCon
 217 -- A wrapper for DataCon.mkDataCon that
 218 --   a) makes the worker Id
 219 --   b) makes the wrapper Id if necessary, including
 220 --      allocating its unique (hence monadic)
 221 buildDataCon src_name declared_infix arg_stricts field_lbls
 222              univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
 223   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 224         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 225         -- This last one takes the name of the data constructor in the source
 226         -- code, which (for Haskell source anyway) will be in the DataName name
 227         -- space, and puts it into the VarName name space
 228
 229         ; let
 230                 stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
 231                 data_con = mkDataCon src_name declared_infix
 232                                      arg_stricts field_lbls
 233                                      univ_tvs ex_tvs eq_spec ctxt
 234                                      arg_tys tycon
 235                                      stupid_ctxt dc_ids
 236                 dc_ids = mkDataConIds wrap_name work_name data_con
 237
 238         ; returnM data_con }
 239
 240
 241 -- The stupid context for a data constructor should be limited to
 242 -- the type variables mentioned in the arg_tys
 243 -- ToDo: Or functionally dependent on?
 244 --       This whole stupid theta thing is, well, stupid.
 245 mkDataConStupidTheta tycon arg_tys univ_tvs
 246   | null stupid_theta = []      -- The common case
 247   | otherwise         = filter in_arg_tys stupid_theta
 248   where
 249     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
 250     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
 251         -- Start by instantiating the master copy of the
 252         -- stupid theta, taken from the TyCon
 253
 254     arg_tyvars      = tyVarsOfTypes arg_tys
 255     in_arg_tys pred = not $ isEmptyVarSet $
 256                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 257
 258 ------------------------------------------------------
 259 mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
 260 mkTyConSelIds tycon rhs
 261   =  [ mkRecordSelId tycon fld
 262      | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
 263         -- We'll check later that fields with the same name
 264         -- from different constructors have the same type.
 265 \end{code}
 266
 267
 268 ------------------------------------------------------
 269 \begin{code}
 270 buildClass :: Name -> [TyVar] -> ThetaType
 271            -> [FunDep TyVar]            -- Functional dependencies
 272            -> [TyThing]                 -- Associated types
 273            -> [(Name, DefMeth, Type)]   -- Method info
 274            -> RecFlag                   -- Info for type constructor
 275            -> TcRnIf m n Class
 276
 277 buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 278   = do  { tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 279         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 280                 -- The class name is the 'parent' for this datacon, not its tycon,
 281                 -- because one should import the class to get the binding for
 282                 -- the datacon
 283         ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc)
 284                                 [1..length sc_theta]
 285               -- We number off the superclass selectors, 1, 2, 3 etc so that we
 286               -- can construct names for the selectors.  Thus
 287               --      class (C a, C b) => D a b where ...
 288               -- gives superclass selectors
 289               --      D_sc1, D_sc2
 290               -- (We used to call them D_C, but now we can have two different
 291               --  superclasses both called C!)
 292
 293         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
 294
 295           let { rec_tycon          = classTyCon rec_clas
 296               ; op_tys             = [ty | (_,_,ty) <- sig_stuff]
 297               ; sc_tys             = mkPredTys sc_theta
 298               ; dict_component_tys = sc_tys ++ op_tys
 299               ; sc_sel_ids         = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]
 300               ; op_items = [ (mkDictSelId op_name rec_clas, dm_info)
 301                            | (op_name, dm_info, _) <- sig_stuff ] }
 302                         -- Build the selector id and default method id
 303
 304         ; dict_con <- buildDataCon datacon_name
 305                                    False        -- Not declared infix
 306                                    (map (const NotMarkedStrict) dict_component_tys)
 307                                    [{- No labelled fields -}]
 308                                    tvs [{- no existentials -}]
 309                                    [{- No equalities -}] [{-No context-}]
 310                                    dict_component_tys
 311                                    rec_tycon
 312
 313         ; rhs <- case dict_component_tys of
 314                             [rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con
 315                             other    -> return (mkDataTyConRhs [dict_con])
 316
 317         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 318
 319               ; tycon = mkClassTyCon tycon_name clas_kind tvs
 320                                      rhs rec_clas tc_isrec
 321                 -- A class can be recursive, and in the case of newtypes
 322                 -- this matters.  For example
 323                 --      class C a where { op :: C b => a -> b -> Int }
 324                 -- Because C has only one operation, it is represented by
 325                 -- a newtype, and it should be a *recursive* newtype.
 326                 -- [If we don't make it a recursive newtype, we'll expand the
 327                 -- newtype like a synonym, but that will lead to an infinite
 328                 -- type]
 329               ; atTyCons = [tycon | ATyCon tycon <- ats]
 330               }
 331         ; return (mkClass class_name tvs fds
 332                        sc_theta sc_sel_ids atTyCons op_items
 333                        tycon)
 334         })}
 335 \end{code}
 336
 337