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