BuildTyCl.hs 18.5 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,
11
        TcMethInfo, MethInfo, buildClass,
12
        mkNewTyConRhs,
13
        newImplicitBinder, newTyConRepName
14 15 16 17
    ) where

#include "HsVersions.h"

18 19
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
20
import IfaceEnv
Simon Peyton Jones's avatar
Simon Peyton Jones committed
21
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
22
import TysWiredIn( isCTupleTyConName )
23
import TysPrim ( voidPrimTy )
Simon Marlow's avatar
Simon Marlow committed
24
import DataCon
Gergő Érdi's avatar
Gergő Érdi committed
25
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
26 27 28 29
import Var
import VarSet
import BasicTypes
import Name
30
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
31 32 33 34
import MkId
import Class
import TyCon
import Type
Gergő Érdi's avatar
Gergő Érdi committed
35
import Id
36
import TcType
37

38
import SrcLoc( SrcSpan, noSrcSpan )
39
import DynFlags
40
import TcRnMonad
41
import UniqSupply
42
import Util
43
import Outputable
44

45

46
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
47 48 49
-- ^ 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.
50 51
mkNewTyConRhs tycon_name tycon con
  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
52 53
        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
54 55 56
        ; 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
57
                             nt_co       = nt_ax } ) }
58 59
                             -- Coreview looks through newtypes with a Nothing
                             -- for nt_co, or uses explicit coercions otherwise
60
  where
61
    tvs    = tyConTyVars tycon
62
    roles  = tyConRoles tycon
63 64 65 66 67 68
    con_arg_ty = case dataConRepArgTys con of
                   [arg_ty] -> arg_ty
                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
    rhs_ty = substTyWith (dataConUnivTyVars con)
                         (mkTyVarTys tvs) con_arg_ty
        -- Instantiate the newtype's RHS with the
69 70 71 72 73 74 75
        -- 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 [].
76

77 78 79 80
    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
81 82

    eta_reduce :: [TyVar]       -- Reversed
83
               -> [Role]        -- also reversed
84 85
               -> Type          -- Rhs type
               -> ([TyVar], [Role], Type)  -- Eta-reduced version
86 87
                                           -- (tyvars in normal order)
    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
88 89
                                  Just tv <- getTyVar_maybe arg,
                                  tv == a,
90
                                  not (a `elemVarSet` tyCoVarsOfType fun)
91
                                = eta_reduce as rs fun
92
    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
93

94
------------------------------------------------------
95
buildDataCon :: FamInstEnvs
96 97
            -> Name
            -> Bool                     -- Declared infix
98
            -> TyConRepName
99 100 101
            -> [HsSrcBang]
            -> Maybe [HsImplBang]
                -- See Note [Bangs on imported data constructors] in MkId
Adam Gundry's avatar
Adam Gundry committed
102
           -> [FieldLabel]             -- Field labels
103
           -> [TyVar]                  -- Universals
Ningning Xie's avatar
Ningning Xie committed
104
           -> [TyCoVar]                -- Existentials
105
           -> [TyVarBinder]            -- User-written 'TyVarBinder's
106
           -> [EqSpec]                 -- Equality spec
107
           -> KnotTied ThetaType       -- Does not include the "stupid theta"
108
                                       -- or the GADT equalities
109 110 111
           -> [KnotTied Type]          -- Arguments
           -> KnotTied Type            -- Result types
           -> KnotTied TyCon           -- Rep tycon
112 113
           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
                                       -- ConTag
114
           -> TcRnIf m n DataCon
115 116 117
-- A wrapper for DataCon.mkDataCon that
--   a) makes the worker Id
--   b) makes the wrapper Id if necessary, including
118
--      allocating its unique (hence monadic)
119 120 121
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
             rep_tycon tag_map
122 123 124 125 126
  = 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
127

128
        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
129 130
        ; us <- newUniqueSupply
        ; dflags <- getDynFlags
131
        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
132 133
              tag = lookupNameEnv_NF tag_map src_name
              -- See Note [Constructor tag allocation], fixes #14657
134 135
              data_con = mkDataCon src_name declared_infix prom_info
                                   src_bangs field_lbls
136
                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
137
                                   arg_tys res_ty NoRRI rep_tycon tag
138 139 140 141
                                   stupid_ctxt dc_wrk dc_rep
              dc_wrk = mkDataConWorkId work_name data_con
              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
                                                impl_bangs data_con)
142

143
        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
144
        ; return data_con }
145

146 147

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

162
    arg_tyvars      = tyCoVarsOfTypes arg_tys
163
    in_arg_tys pred = not $ isEmptyVarSet $
164
                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars
Gergő Érdi's avatar
Gergő Érdi committed
165 166 167


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

208 209 210 211 212 213 214 215
    -- For a nullary pattern synonym we add a single void argument to the
    -- matcher to preserve laziness in the case of unlifted types.
    -- See #12746
    compareArgTys :: [Type] -> [Type] -> Bool
    compareArgTys [] [x] = x `eqType` voidPrimTy
    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys


216
------------------------------------------------------
217 218
type TcMethInfo = MethInfo  -- this variant needs zonking
type MethInfo       -- A temporary intermediate, to communicate
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
                    -- between tcClassSigs and buildClass.
  = ( Name   -- Name of the class op
    , Type   -- Type of the class op
    , Maybe (DefMethSpec (SrcSpan, Type)))
         -- Nothing                    => no default method
         --
         -- Just VanillaDM             => There is an ordinary
         --                               polymorphic default method
         --
         -- Just (GenericDM (loc, ty)) => There is a generic default metho
         --                               Here is its type, and the location
         --                               of the type signature
         --    We need that location /only/ to attach it to the
         --    generic default method's Name; and we need /that/
         --    only to give the right location of an ambiguity error
         --    for the generic default method, spat out by checkValidClass
235

236
buildClass :: Name  -- Name of the class/tycon (they have the same Name)
237
           -> [TyConBinder]                -- Of the tycon
238
           -> [Role]
239
           -> [FunDep TyVar]               -- Functional dependencies
240 241
           -- Super classes, associated types, method info, minimal complete def.
           -- This is Nothing if the class is abstract.
242
           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
243
           -> TcRnIf m n Class
244

245 246 247 248 249
buildClass tycon_name binders roles fds Nothing
  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
    do  { traceIf (text "buildClass")

        ; tc_rep_name  <- newTyConRepName tycon_name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
250
        ; let univ_tvs = binderVars binders
251 252 253 254 255 256 257 258
              tycon = mkClassTyCon tycon_name binders roles
                                   AbstractTyCon rec_clas tc_rep_name
              result = mkAbstractClass tycon_name univ_tvs fds tycon
        ; traceIf (text "buildClass" <+> ppr tycon)
        ; return result }

buildClass tycon_name binders roles fds
           (Just (sc_theta, at_items, sig_stuff, mindef))
259 260
  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
    do  { traceIf (text "buildClass")
261

262
        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
263
        ; tc_rep_name  <- newTyConRepName tycon_name
264

265 266
        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                        -- Build the selector id and default method id
267

268 269
              -- Make selectors for the superclasses
        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
270
                                (takeList sc_theta [fIRST_TAG..])
271
        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
272
                           | sc_name <- sc_sel_names]
273 274 275 276 277 278 279 280 281 282 283 284
              -- 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
285 286
                --   (b) that value is of lifted type (which they always are, because
                --       we box equality superclasses)
287
                -- See note [Class newtypes and equality predicates]
288

289
                -- We treat the dictionary superclasses as ordinary arguments.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
290
                -- That means that in the case of
291 292
                --     class C a => D a
                -- we don't get a newtype with no arguments!
293 294 295 296 297
              args       = sc_sel_names ++ op_names
              op_tys     = [ty | (_,ty,_) <- sig_stuff]
              op_names   = [op | (op,_,_) <- sig_stuff]
              arg_tys    = sc_theta ++ op_tys
              rec_tycon  = classTyCon rec_clas
298
              univ_bndrs = tyConTyVarBinders binders
299
              univ_tvs   = binderVars univ_bndrs
300

301
        ; rep_nm   <- newTyConRepName datacon_name
302
        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
303
                                   datacon_name
304
                                   False        -- Not declared infix
305
                                   rep_nm
306 307
                                   (map (const no_bang) args)
                                   (Just (map (const HsLazy) args))
308
                                   [{- No fields -}]
309
                                   univ_tvs
310
                                   [{- no existentials -}]
311
                                   univ_bndrs
312
                                   [{- No GADT equalities -}]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
313
                                   [{- No theta -}]
314
                                   arg_tys
315
                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
316
                                   rec_tycon
317
                                   (mkTyConTagMap rec_tycon)
318

319 320 321 322 323 324 325 326
        ; rhs <- case () of
                  _ | use_newtype
                    -> mkNewTyConRhs tycon_name rec_tycon dict_con
                    | isCTupleTyConName tycon_name
                    -> return (TupleTyCon { data_con = dict_con
                                          , tup_sort = ConstraintTuple })
                    | otherwise
                    -> return (mkDataTyConRhs [dict_con])
327

328
        ; let { tycon = mkClassTyCon tycon_name binders roles
Edward Z. Yang's avatar
Edward Z. Yang committed
329
                                     rhs rec_clas tc_rep_name
330 331 332 333 334 335 336 337 338
                -- 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]

339
              ; result = mkClass tycon_name univ_tvs fds
340 341 342 343 344
                                 sc_theta sc_sel_ids at_items
                                 op_items mindef tycon
              }
        ; traceIf (text "buildClass" <+> ppr tycon)
        ; return result }
345
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
346
    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
347

348
    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
349
    mk_op_item rec_clas (op_name, _, dm_spec)
350
      = do { dm_info <- mk_dm_info op_name dm_spec
351
           ; return (mkDictSelId op_name rec_clas, dm_info) }
352

353 354 355 356 357 358 359 360 361 362 363
    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
    mk_dm_info _ Nothing
      = return Nothing
    mk_dm_info op_name (Just VanillaDM)
      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
           ; return (Just (dm_name, VanillaDM)) }
    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
           ; return (Just (dm_name, GenericDM dm_ty)) }

Austin Seipp's avatar
Austin Seipp committed
364
{-
365 366 367
Note [Class newtypes and equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
368 369
        class (a ~ F b) => C a b where
          op :: a -> b
370 371

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
375
Moreover,
376
          class (a ~ F b) => C a b where {}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
377 378 379
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
380
-}
381 382 383 384 385 386

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
Gabor Greif's avatar
Gabor Greif committed
387
-- For iface ones, the LoadIface has already allocated a suitable name in the cache
388
newImplicitBinder base_name mk_sys_occ
389 390 391 392 393 394 395 396
  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)

newImplicitBinderLoc :: Name                       -- Base name
                     -> (OccName -> OccName)       -- Occurrence name modifier
                     -> SrcSpan
                     -> TcRnIf m n Name            -- Implicit name
-- Just the same, but lets you specify the SrcSpan
newImplicitBinderLoc base_name mk_sys_occ loc
397 398 399 400 401 402 403 404 405
  | 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)
406 407 408 409 410 411 412 413

-- | 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
414
  = newImplicitBinder tc_name mkTyConRepOcc