BuildTyCl.hs 15.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
5

6
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
7

8
module BuildTyCl (
9
        buildDataCon,
10
        buildPatSyn,
batterseapower's avatar
batterseapower committed
11
        TcMethInfo, buildClass,
12
        distinctAbstractTyConRhs, totallyAbstractTyConRhs,
13
        mkNewTyConRhs, mkDataTyConRhs,
14
        newImplicitBinder, newTyConRepName
15 16 17 18
    ) where

#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
19
import IfaceEnv
Simon Peyton Jones's avatar
Simon Peyton Jones committed
20
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
21
import TysWiredIn( isCTupleTyConName )
Simon Marlow's avatar
Simon Marlow committed
22
import DataCon
cactus's avatar
cactus committed
23
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
24 25 26 27 28 29 30 31
import Var
import VarSet
import BasicTypes
import Name
import MkId
import Class
import TyCon
import Type
cactus's avatar
cactus committed
32
import Id
33
import TcType
34

35
import SrcLoc( noSrcSpan )
36
import DynFlags
37
import TcRnMonad
38
import UniqSupply
39
import Util
40
import Outputable
41

42 43 44
distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
distinctAbstractTyConRhs = AbstractTyCon True
totallyAbstractTyConRhs  = AbstractTyCon False
45

46 47
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
Ian Lynagh's avatar
Ian Lynagh committed
48 49
  = DataTyCon {
        data_cons = cons,
50
        is_enum = not (null cons) && all is_enum_con cons
51
                  -- See Note [Enumeration types] in TyCon
Ian Lynagh's avatar
Ian Lynagh committed
52
    }
53 54
  where
    is_enum_con con
55 56 57
       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
           <- dataConFullSig con
       = null ex_tvs && null eq_spec && null theta && null arg_tys
58

59

60
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
61 62 63
-- ^ Monadic because it makes a Name for the coercion TyCon
--   We pass the Name of the parent TyCon, as well as the TyCon itself,
--   because the latter is part of a knot, whereas the former is not.
64 65
mkNewTyConRhs tycon_name tycon con
  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
66 67
        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
68 69 70
        ; return (NewTyCon { data_con    = con,
                             nt_rhs      = rhs_ty,
                             nt_etad_rhs = (etad_tvs, etad_rhs),
Simon Peyton Jones's avatar
Simon Peyton Jones committed
71
                             nt_co       = nt_ax } ) }
72 73
                             -- Coreview looks through newtypes with a Nothing
                             -- for nt_co, or uses explicit coercions otherwise
74
  where
75
    tvs    = tyConTyVars tycon
76
    roles  = tyConRoles tycon
77 78
    inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
    rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
79 80 81 82 83 84 85 86
        -- Instantiate the data con with the
        -- type variables from the tycon
        -- NB: a newtype DataCon has a type that must look like
        --        forall tvs.  <arg-ty> -> T tvs
        -- Note that we *can't* use dataConInstOrigArgTys here because
        -- the newtype arising from   class Foo a => Bar a where {}
        -- has a single argument (Foo a) that is a *type class*, so
        -- dataConInstOrigArgTys returns [].
87

88 89 90 91
    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface
    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
92 93

    eta_reduce :: [TyVar]       -- Reversed
94
               -> [Role]        -- also reversed
95 96
               -> Type          -- Rhs type
               -> ([TyVar], [Role], Type)  -- Eta-reduced version
97 98
                                           -- (tyvars in normal order)
    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
99 100
                                  Just tv <- getTyVar_maybe arg,
                                  tv == a,
101
                                  not (a `elemVarSet` tyCoVarsOfType fun)
102
                                = eta_reduce as rs fun
103
    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
104

105
------------------------------------------------------
106
buildDataCon :: FamInstEnvs
107 108
            -> Name
            -> Bool                     -- Declared infix
109
            -> TyConRepName
110 111 112
            -> [HsSrcBang]
            -> Maybe [HsImplBang]
                -- See Note [Bangs on imported data constructors] in MkId
Adam Gundry's avatar
Adam Gundry committed
113
           -> [FieldLabel]             -- Field labels
114
           -> [TyVar] -> [TyVar]       -- Univ and ext
115
           -> [EqSpec]                 -- Equality spec
116 117 118 119 120
           -> ThetaType                -- Does not include the "stupid theta"
                                       -- or the GADT equalities
           -> [Type] -> Type           -- Argument and result types
           -> TyCon                    -- Rep tycon
           -> TcRnIf m n DataCon
121 122 123
-- A wrapper for DataCon.mkDataCon that
--   a) makes the worker Id
--   b) makes the wrapper Id if necessary, including
124
--      allocating its unique (hence monadic)
125
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
126 127 128 129 130 131
             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
        -- This last one takes the name of the data constructor in the source
        -- code, which (for Haskell source anyway) will be in the DataName name
        -- space, and puts it into the VarName name space
132

133
        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
134 135
        ; us <- newUniqueSupply
        ; dflags <- getDynFlags
136 137
        ; let
                stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
138
                data_con = mkDataCon src_name declared_infix prom_info
139
                                     src_bangs field_lbls
140 141 142
                                     univ_tvs ex_tvs eq_spec ctxt
                                     arg_tys res_ty rep_tycon
                                     stupid_ctxt dc_wrk dc_rep
143
                dc_wrk = mkDataConWorkId work_name data_con
144 145
                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
                                                  impl_bangs data_con)
146

147
        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
148
        ; return data_con }
149

150 151

-- The stupid context for a data constructor should be limited to
152
-- the type variables mentioned in the arg_tys
153 154
-- ToDo: Or functionally dependent on?
--       This whole stupid theta thing is, well, stupid.
Ian Lynagh's avatar
Ian Lynagh committed
155
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
156
mkDataConStupidTheta tycon arg_tys univ_tvs
157 158
  | null stupid_theta = []      -- The common case
  | otherwise         = filter in_arg_tys stupid_theta
159
  where
niteria's avatar
niteria committed
160
    tc_subst     = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
161
    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
162 163
        -- Start by instantiating the master copy of the
        -- stupid theta, taken from the TyCon
164

165
    arg_tyvars      = tyCoVarsOfTypes arg_tys
166
    in_arg_tys pred = not $ isEmptyVarSet $
167
                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars
cactus's avatar
cactus committed
168 169 170


------------------------------------------------------
171
buildPatSyn :: Name -> Bool
172
            -> (Id,Bool) -> Maybe (Id, Bool)
173 174 175 176
            -> ([TyVar], ThetaType) -- ^ Univ and req
            -> ([TyVar], ThetaType) -- ^ Ex and prov
            -> [Type]               -- ^ Argument types
            -> Type                 -- ^ Result type
Matthew Pickering's avatar
Matthew Pickering committed
177 178
            -> [FieldLabel]         -- ^ Field labels for
                                    --   a record pattern synonym
179
            -> PatSyn
180
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
Matthew Pickering's avatar
Matthew Pickering committed
181 182
            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
            pat_ty field_labels
183 184 185 186
  = -- The assertion checks that the matcher is
    -- compatible with the pattern synonym
    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
                 , ex_tvs `equalLength` ex_tvs1
187
                 , pat_ty `eqType` substTy subst pat_ty1
188 189 190
                 , prov_theta `eqTypes` substTys subst prov_theta1
                 , req_theta `eqTypes` substTys subst req_theta1
                 , arg_tys `eqTypes` substTys subst arg_tys1
191 192 193 194 195 196 197
                 ])
            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1
                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1
                    , ppr req_theta <+> twiddle <+> ppr req_theta1
                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
198
    mkPatSyn src_name declared_infix
199 200
             (univ_tvs, req_theta) (ex_tvs, prov_theta)
             arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
201
             matcher builder field_labels
202
  where
203 204 205 206 207
    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
    ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
    (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
    (arg_tys1, _) = tcSplitFunTys cont_tau
    twiddle = char '~'
niteria's avatar
niteria committed
208 209
    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
                       (mkTyVarTys (univ_tvs ++ ex_tvs))
210

211
------------------------------------------------------
212
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
213
        -- A temporary intermediate, to communicate between
214
        -- tcClassSigs and buildClass.
215

216
buildClass :: Name  -- Name of the class/tycon (they have the same Name)
217
           -> [TyVar] -> [Role] -> ThetaType
218
           -> Kind
219 220 221 222 223 224
           -> [FunDep TyVar]               -- Functional dependencies
           -> [ClassATItem]                -- Associated types
           -> [TcMethInfo]                 -- Method info
           -> ClassMinimalDef              -- Minimal complete definition
           -> RecFlag                      -- Info for type constructor
           -> TcRnIf m n Class
225

226
buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec
227 228
  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
    do  { traceIf (text "buildClass")
229

230
        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
231
        ; tc_rep_name  <- newTyConRepName tycon_name
232

233 234
        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                        -- Build the selector id and default method id
235

236 237
              -- Make selectors for the superclasses
        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
238
                                (takeList sc_theta [fIRST_TAG..])
239
        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
240
                           | sc_name <- sc_sel_names]
241 242 243 244 245 246 247 248 249 250 251 252
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
              -- can construct names for the selectors. Thus
              --      class (C a, C b) => D a b where ...
              -- gives superclass selectors
              --      D_sc1, D_sc2
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)

        ; let use_newtype = isSingleton arg_tys
                -- Use a newtype if the data constructor
                --   (a) has exactly one value field
                --       i.e. exactly one operation or superclass taken together
batterseapower's avatar
batterseapower committed
253 254
                --   (b) that value is of lifted type (which they always are, because
                --       we box equality superclasses)
255
                -- See note [Class newtypes and equality predicates]
256

257
                -- We treat the dictionary superclasses as ordinary arguments.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
258
                -- That means that in the case of
259 260 261
                --     class C a => D a
                -- we don't get a newtype with no arguments!
              args      = sc_sel_names ++ op_names
262
              op_tys    = [ty | (_,ty,_) <- sig_stuff]
263 264
              op_names  = [op | (op,_,_) <- sig_stuff]
              arg_tys   = sc_theta ++ op_tys
265
              rec_tycon = classTyCon rec_clas
266

267
        ; rep_nm   <- newTyConRepName datacon_name
268
        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
269
                                   datacon_name
270
                                   False        -- Not declared infix
271
                                   rep_nm
272 273
                                   (map (const no_bang) args)
                                   (Just (map (const HsLazy) args))
274 275 276
                                   [{- No fields -}]
                                   tvs [{- no existentials -}]
                                   [{- No GADT equalities -}]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
277
                                   [{- No theta -}]
278
                                   arg_tys
279 280 281 282 283
                                   (mkTyConApp rec_tycon (mkTyVarTys tvs))
                                   rec_tycon

        ; rhs <- if use_newtype
                 then mkNewTyConRhs tycon_name rec_tycon dict_con
284 285 286
                 else if isCTupleTyConName tycon_name
                 then return (TupleTyCon { data_con = dict_con
                                         , tup_sort = ConstraintTuple })
287 288
                 else return (mkDataTyConRhs [dict_con])

289 290
        ; let { tycon = mkClassTyCon tycon_name kind tvs roles
                                     rhs rec_clas tc_isrec tc_rep_name
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
                -- A class can be recursive, and in the case of newtypes
                -- this matters.  For example
                --      class C a where { op :: C b => a -> b -> Int }
                -- Because C has only one operation, it is represented by
                -- a newtype, and it should be a *recursive* newtype.
                -- [If we don't make it a recursive newtype, we'll expand the
                -- newtype like a synonym, but that will lead to an infinite
                -- type]

              ; result = mkClass tvs fds
                                 sc_theta sc_sel_ids at_items
                                 op_items mindef tycon
              }
        ; traceIf (text "buildClass" <+> ppr tycon)
        ; return result }
306
  where
307 308
    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict

309
    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
310
    mk_op_item rec_clas (op_name, _, dm_spec)
311
      = do { dm_info <- case dm_spec of
312 313 314
                          Nothing   -> return Nothing
                          Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
                                          ; return (Just (dm_name, spec)) }
315
           ; return (mkDictSelId op_name rec_clas, dm_info) }
316

Austin Seipp's avatar
Austin Seipp committed
317
{-
318 319 320
Note [Class newtypes and equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
321 322
        class (a ~ F b) => C a b where
          op :: a -> b
323 324

We cannot represent this by a newtype, even though it's not
Simon Peyton Jones's avatar
Simon Peyton Jones committed
325 326 327
existential, because there are two value fields (the equality
predicate and op. See Trac #2238

Simon Peyton Jones's avatar
Simon Peyton Jones committed
328
Moreover,
329
          class (a ~ F b) => C a b where {}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
330 331 332
Here we can't use a newtype either, even though there is only
one field, because equality predicates are unboxed, and classes
are boxed.
Austin Seipp's avatar
Austin Seipp committed
333
-}
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351

newImplicitBinder :: Name                       -- Base name
                  -> (OccName -> OccName)       -- Occurrence name modifier
                  -> TcRnIf m n Name            -- Implicit name
-- Called in BuildTyCl to allocate the implicit binders of type/class decls
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
newImplicitBinder base_name mk_sys_occ
  | Just mod <- nameModule_maybe base_name
  = newGlobalBinder mod occ loc
  | otherwise           -- When typechecking a [d| decl bracket |],
                        -- TH generates types, classes etc with Internal names,
                        -- so we follow suit for the implicit binders
  = do  { uniq <- newUnique
        ; return (mkInternalName uniq occ loc) }
  where
    occ = mk_sys_occ (nameOccName base_name)
    loc = nameSrcSpan base_name
352 353 354 355 356 357 358 359

-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
  | Just mod <- nameModule_maybe tc_name
  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
  = newGlobalBinder mod occ noSrcSpan
  | otherwise
360
  = newImplicitBinder tc_name mkTyConRepOcc