e412d7ef301c88d43d8e38c972e5030fbad5a421
[ghc.git] / 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 -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module BuildTyCl (
15         buildSynTyCon,
16         buildAlgTyCon, 
17         buildDataCon,
18         buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
19         TcMethInfo, buildClass,
20         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
21         mkNewTyConRhs, mkDataTyConRhs, 
22         newImplicitBinder
23     ) where
24
25 #include "HsVersions.h"
26
27 import IfaceEnv
28 import FamInstEnv( FamInstEnvs )
29 import DataCon
30 import PatSyn
31 import Var
32 import VarSet
33 import BasicTypes
34 import Name
35 import MkId
36 import Class
37 import TyCon
38 import Type
39 import TypeRep
40 import TcType
41 import Id
42 import Coercion
43
44 import DynFlags
45 import TcRnMonad
46 import UniqSupply
47 import Util
48 import Outputable
49 \end{code}
50         
51
52 \begin{code}
53 ------------------------------------------------------
54 buildSynTyCon :: Name -> [TyVar] -> [Role] 
55               -> SynTyConRhs
56               -> Kind                   -- ^ Kind of the RHS
57               -> TyConParent
58               -> TcRnIf m n TyCon
59 buildSynTyCon tc_name tvs roles rhs rhs_kind parent 
60   = return (mkSynTyCon tc_name kind tvs roles rhs parent)
61   where kind = mkPiKinds tvs rhs_kind
62
63
64 ------------------------------------------------------
65 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
66 distinctAbstractTyConRhs = AbstractTyCon True
67 totallyAbstractTyConRhs  = AbstractTyCon False
68
69 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
70 mkDataTyConRhs cons
71   = DataTyCon {
72         data_cons = cons,
73         is_enum = not (null cons) && all is_enum_con cons
74                   -- See Note [Enumeration types] in TyCon
75     }
76   where
77     is_enum_con con
78        | (_tvs, theta, arg_tys, _res) <- dataConSig con
79        = null theta && null arg_tys
80
81
82 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
83 -- ^ Monadic because it makes a Name for the coercion TyCon
84 --   We pass the Name of the parent TyCon, as well as the TyCon itself,
85 --   because the latter is part of a knot, whereas the former is not.
86 mkNewTyConRhs tycon_name tycon con 
87   = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
88         ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs
89         ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
90         ; return (NewTyCon { data_con    = con, 
91                              nt_rhs      = rhs_ty,
92                              nt_etad_rhs = (etad_tvs, etad_rhs),
93                              nt_co       = co_tycon } ) }
94                              -- Coreview looks through newtypes with a Nothing
95                              -- for nt_co, or uses explicit coercions otherwise
96   where
97     tvs    = tyConTyVars tycon
98     roles  = tyConRoles tycon
99     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
100     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
101         -- Instantiate the data con with the 
102         -- type variables from the tycon
103         -- NB: a newtype DataCon has a type that must look like
104         --        forall tvs.  <arg-ty> -> T tvs
105         -- Note that we *can't* use dataConInstOrigArgTys here because
106         -- the newtype arising from   class Foo a => Bar a where {}
107         -- has a single argument (Foo a) that is a *type class*, so
108         -- dataConInstOrigArgTys returns [].
109
110     etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
111     etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
112     etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface
113     (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
114  
115     eta_reduce :: [TyVar]       -- Reversed
116                -> [Role]        -- also reversed
117                -> Type          -- Rhs type
118                -> ([TyVar], [Role], Type)  -- Eta-reduced version
119                                            -- (tyvars in normal order)
120     eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
121                                   Just tv <- getTyVar_maybe arg,
122                                   tv == a,
123                                   not (a `elemVarSet` tyVarsOfType fun)
124                                 = eta_reduce as rs fun
125     eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
126                                 
127
128 ------------------------------------------------------
129 buildDataCon :: FamInstEnvs 
130             -> Name -> Bool
131             -> [HsBang] 
132             -> [Name]                   -- Field labels
133             -> [TyVar] -> [TyVar]       -- Univ and ext 
134             -> [(TyVar,Type)]           -- Equality spec
135             -> ThetaType                -- Does not include the "stupid theta"
136                                         -- or the GADT equalities
137             -> [Type] -> Type           -- Argument and result types
138             -> TyCon                    -- Rep tycon
139             -> TcRnIf m n DataCon
140 -- A wrapper for DataCon.mkDataCon that
141 --   a) makes the worker Id
142 --   b) makes the wrapper Id if necessary, including
143 --      allocating its unique (hence monadic)
144 buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
145              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
146   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
147         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
148         -- This last one takes the name of the data constructor in the source
149         -- code, which (for Haskell source anyway) will be in the DataName name
150         -- space, and puts it into the VarName name space
151
152         ; us <- newUniqueSupply
153         ; dflags <- getDynFlags
154         ; let
155                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
156                 data_con = mkDataCon src_name declared_infix
157                                      arg_stricts field_lbls
158                                      univ_tvs ex_tvs eq_spec ctxt
159                                      arg_tys res_ty rep_tycon
160                                      stupid_ctxt dc_wrk dc_rep
161                 dc_wrk = mkDataConWorkId work_name data_con
162                 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
163
164         ; return data_con }
165
166
167 -- The stupid context for a data constructor should be limited to
168 -- the type variables mentioned in the arg_tys
169 -- ToDo: Or functionally dependent on?  
170 --       This whole stupid theta thing is, well, stupid.
171 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
172 mkDataConStupidTheta tycon arg_tys univ_tvs
173   | null stupid_theta = []      -- The common case
174   | otherwise         = filter in_arg_tys stupid_theta
175   where
176     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
177     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
178         -- Start by instantiating the master copy of the 
179         -- stupid theta, taken from the TyCon
180
181     arg_tyvars      = tyVarsOfTypes arg_tys
182     in_arg_tys pred = not $ isEmptyVarSet $ 
183                       tyVarsOfType pred `intersectVarSet` arg_tyvars
184
185
186 ------------------------------------------------------
187 buildPatSyn :: Name -> Bool -> Bool
188             -> [Var]
189             -> [TyVar] -> [TyVar]     -- Univ and ext
190             -> ThetaType -> ThetaType -- Prov and req
191             -> Type                  -- Result type
192             -> TyVar
193             -> TcRnIf m n PatSyn
194 buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
195   = do  { (matcher, _, _) <- mkPatSynMatcherId src_name args
196                                               univ_tvs ex_tvs
197                                               prov_theta req_theta
198                                               pat_ty tv
199         ; wrapper <- case has_wrapper of
200             False -> return Nothing
201             True -> fmap Just $
202                     mkPatSynWrapperId src_name args
203                                       (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta)
204                                       pat_ty
205         ; return $ mkPatSyn src_name declared_infix
206                             args
207                             univ_tvs ex_tvs
208                             prov_theta req_theta
209                             pat_ty
210                             matcher
211                             wrapper }
212
213 mkPatSynMatcherId :: Name
214                   -> [Var]
215                   -> [TyVar]
216                   -> [TyVar]
217                   -> ThetaType -> ThetaType
218                   -> Type
219                   -> TyVar
220                   -> TcRnIf n m (Id, Type, Type)
221 mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv
222   = do { matcher_name <- newImplicitBinder name mkMatcherOcc
223
224        ; let res_ty = TyVarTy res_tv
225              cont_ty = mkSigmaTy ex_tvs prov_theta $
226                        mkFunTys (map varType args) res_ty
227
228        ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
229              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
230              matcher_id = mkVanillaGlobal matcher_name matcher_sigma
231        ; return (matcher_id, res_ty, cont_ty) }
232
233 mkPatSynWrapperId :: Name
234                   -> [Var]
235                   -> [TyVar]
236                   -> ThetaType
237                   -> Type
238                   -> TcRnIf n m Id
239 mkPatSynWrapperId name args qtvs theta pat_ty
240   = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
241
242        ; let wrapper_tau = mkFunTys (map varType args) pat_ty
243              wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau
244
245        ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
246        ; return wrapper_id }
247
248 \end{code}
249
250
251 ------------------------------------------------------
252 \begin{code}
253 type TcMethInfo = (Name, DefMethSpec, Type)  
254         -- A temporary intermediate, to communicate between 
255         -- tcClassSigs and buildClass.
256
257 buildClass :: Bool              -- True <=> do not include unfoldings 
258                                 --          on dict selectors
259                                 -- Used when importing a class without -O
260            -> Name -> [TyVar] -> [Role] -> ThetaType
261            -> [FunDep TyVar]               -- Functional dependencies
262            -> [ClassATItem]                -- Associated types
263            -> [TcMethInfo]                 -- Method info
264            -> ClassMinimalDef              -- Minimal complete definition
265            -> RecFlag                      -- Info for type constructor
266            -> TcRnIf m n Class
267
268 buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
269   = fixM  $ \ rec_clas ->       -- Only name generation inside loop
270     do  { traceIf (text "buildClass")
271         ; dflags <- getDynFlags
272
273         ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
274                 -- The class name is the 'parent' for this datacon, not its tycon,
275                 -- because one should import the class to get the binding for 
276                 -- the datacon
277
278
279         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
280                         -- Build the selector id and default method id
281
282               -- Make selectors for the superclasses 
283         ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc) 
284                                 [1..length sc_theta]
285         ; let sc_sel_ids = [ mkDictSelId dflags no_unf sc_name rec_clas 
286                            | sc_name <- sc_sel_names]
287               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
288               -- can construct names for the selectors. Thus
289               --      class (C a, C b) => D a b where ...
290               -- gives superclass selectors
291               --      D_sc1, D_sc2
292               -- (We used to call them D_C, but now we can have two different
293               --  superclasses both called C!)
294         
295         ; let use_newtype = isSingleton arg_tys
296                 -- Use a newtype if the data constructor 
297                 --   (a) has exactly one value field
298                 --       i.e. exactly one operation or superclass taken together
299                 --   (b) that value is of lifted type (which they always are, because
300                 --       we box equality superclasses)
301                 -- See note [Class newtypes and equality predicates]
302
303                 -- We treat the dictionary superclasses as ordinary arguments.  
304                 -- That means that in the case of
305                 --     class C a => D a
306                 -- we don't get a newtype with no arguments!
307               args      = sc_sel_names ++ op_names
308               op_tys    = [ty | (_,_,ty) <- sig_stuff]
309               op_names  = [op | (op,_,_) <- sig_stuff]
310               arg_tys   = sc_theta ++ op_tys
311               rec_tycon = classTyCon rec_clas
312                
313         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
314                                    datacon_name
315                                    False        -- Not declared infix
316                                    (map (const HsNoBang) args)
317                                    [{- No fields -}]
318                                    tvs [{- no existentials -}]
319                                    [{- No GADT equalities -}] 
320                                    [{- No theta -}]
321                                    arg_tys
322                                    (mkTyConApp rec_tycon (mkTyVarTys tvs))
323                                    rec_tycon
324
325         ; rhs <- if use_newtype
326                  then mkNewTyConRhs tycon_name rec_tycon dict_con
327                  else return (mkDataTyConRhs [dict_con])
328
329         ; let { clas_kind = mkPiKinds tvs constraintKind
330
331               ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
332                                      rhs rec_clas tc_isrec
333                 -- A class can be recursive, and in the case of newtypes 
334                 -- this matters.  For example
335                 --      class C a where { op :: C b => a -> b -> Int }
336                 -- Because C has only one operation, it is represented by
337                 -- a newtype, and it should be a *recursive* newtype.
338                 -- [If we don't make it a recursive newtype, we'll expand the
339                 -- newtype like a synonym, but that will lead to an infinite
340                 -- type]
341
342               ; result = mkClass tvs fds 
343                                  sc_theta sc_sel_ids at_items
344                                  op_items mindef tycon
345               }
346         ; traceIf (text "buildClass" <+> ppr tycon) 
347         ; return result }
348   where
349     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
350     mk_op_item rec_clas (op_name, dm_spec, _) 
351       = do { dflags <- getDynFlags
352            ; dm_info <- case dm_spec of
353                           NoDM      -> return NoDefMeth
354                           GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
355                                           ; return (GenDefMeth dm_name) }
356                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
357                                           ; return (DefMeth dm_name) }
358            ; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) }
359 \end{code}
360
361 Note [Class newtypes and equality predicates]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 Consider
364         class (a ~ F b) => C a b where
365           op :: a -> b
366
367 We cannot represent this by a newtype, even though it's not
368 existential, because there are two value fields (the equality
369 predicate and op. See Trac #2238
370
371 Moreover, 
372           class (a ~ F b) => C a b where {}
373 Here we can't use a newtype either, even though there is only
374 one field, because equality predicates are unboxed, and classes
375 are boxed.