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