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