Generate Typeable info at definition sites
[ghc.git] / compiler / typecheck / TcTypeable.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
4 -}
5
6 module TcTypeable(
7 mkTypeableBinds, mkModIdBindings
8 ) where
9
10
11 import TcBinds( addTypecheckedBinds )
12 import IfaceEnv( newGlobalBinder )
13 import TcEnv
14 import TcRnMonad
15 import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
16 import Id
17 import IdInfo( IdDetails(..) )
18 import Type
19 import TyCon
20 import DataCon
21 import Name( getOccName )
22 import OccName
23 import Module
24 import HsSyn
25 import DynFlags
26 import Bag
27 import Fingerprint(Fingerprint(..), fingerprintString)
28 import Outputable
29 import Data.Word( Word64 )
30 import FastString ( FastString, mkFastString )
31
32 {- Note [Grand plan for Typeable]
33 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
34 The overall plan is this:
35
36 1. Generate a binding for each module p:M
37 (done in TcTypeable by mkModIdBindings)
38 M.$trModule :: GHC.Types.Module
39 M.$trModule = Module "p" "M"
40 ("tr" is short for "type representation"; see GHC.Types)
41
42 We might want to add the filename too.
43 This can be used for the lightweight stack-tracing stuff too
44
45 Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
46
47 2. Generate a binding for every data type declaration T in module M,
48 M.$tcT :: GHC.Types.TyCon
49 M.$tcT = TyCon ...fingerprint info...
50 $trModule
51 "T"
52 We define (in TyCon)
53 type TyConRepName = Name
54 to use for these M.$tcT "tycon rep names".
55
56 3. Record the TyConRepName in T's TyCon, including for promoted
57 data and type constructors, and kinds like * and #.
58
59 The TyConRepNaem is not an "implicit Id". It's more like a record
60 selector: the TyCon knows its name but you have to go to the
61 interface file to find its type, value, etc
62
63 4. Solve Typeable costraints. This is done by a custom Typeable solver,
64 currently in TcInteract, that use M.$tcT so solve (Typeable T).
65
66 There are many wrinkles:
67
68 * Since we generate $tcT for every data type T, the types TyCon and
69 Module must be available right from the start; so they are defined
70 in ghc-prim:GHC.Types
71
72 * To save space and reduce dependencies, we need use quite low-level
73 representations for TyCon and Module. See GHC.Types
74 Note [Runtime representation of modules and tycons]
75
76 * It's hard to generate the TyCon/Module bindings when the types TyCon
77 and Module aren't yet available; i.e. when compiling GHC.Types
78 itself. So we *don't* generate them for types in GHC.Types. Instead
79 we write them by hand in base:GHC.Typeable.Internal.
80
81 * To be able to define them by hand, they need to have user-writable
82 names, thus
83 tcBool not $tcBool for the type-rep TyCon for Bool
84 Hence PrelNames.tyConRepModOcc
85
86 * Moreover for type constructors with special syntax, they need to have
87 completely hand-crafted names
88 lists tcList not $tc[] for the type-rep TyCon for []
89 kinds tcLiftedKind not $tc* for the type-rep TyCon for *
90 Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
91 to use for the TyConRepName
92
93 * Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
94 be wired in as well. For these wired-in TyCons we generate the
95 TyConRepName's unique from that of the TyCon; see
96 Unique.tyConRepNameUnique, dataConRepNameUnique.
97
98 -}
99
100 {- *********************************************************************
101 * *
102 Building top-level binding for $trModule
103 * *
104 ********************************************************************* -}
105
106 mkModIdBindings :: TcM TcGblEnv
107 mkModIdBindings
108 = do { mod <- getModule
109 ; if mod == gHC_TYPES
110 then getGblEnv -- Do not generate bindings for modules in GHC.Types
111 else
112 do { loc <- getSrcSpanM
113 ; tr_mod_dc <- tcLookupDataCon trModuleDataConName
114 ; tr_name_dc <- tcLookupDataCon trNameSDataConName
115 ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
116 ; let mod_id = mkExportedLocalId ReflectionId mod_nm
117 (mkTyConApp (dataConTyCon tr_mod_dc) [])
118 mod_bind = mkVarBind mod_id mod_rhs
119 mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
120 [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
121 , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
122
123 ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
124 ; return (tcg_env { tcg_tr_module = Just mod_id }
125 `addTypecheckedBinds` [unitBag mod_bind]) } }
126
127
128 {- *********************************************************************
129 * *
130 Building type-representation bindings
131 * *
132 ********************************************************************* -}
133
134 mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
135 mkTypeableBinds tycons
136 = do { dflags <- getDynFlags
137 ; gbl_env <- getGblEnv
138 ; mod <- getModule
139 ; if mod == gHC_TYPES
140 then return ([], []) -- Do not generate bindings for modules in GHC.Types
141 else
142 do { tr_datacon <- tcLookupDataCon trTyConDataConName
143 ; trn_datacon <- tcLookupDataCon trNameSDataConName
144 ; let pkg_str = unitIdString (moduleUnitId mod)
145 mod_str = moduleNameString (moduleName mod)
146 mod_expr = case tcg_tr_module gbl_env of -- Should be set by now
147 Just mod_id -> nlHsVar mod_id
148 Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
149 stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
150 tc_binds = map (mk_typeable_binds stuff) tycons
151 tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
152 ; return (tycon_rep_ids, tc_binds) } }
153
154 trNameLit :: DataCon -> FastString -> LHsExpr Id
155 trNameLit tr_name_dc fs
156 = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
157
158 type TypeableStuff
159 = ( DynFlags
160 , LHsExpr Id -- Of type GHC.Types.Module
161 , String -- Package name
162 , String -- Module name
163 , DataCon -- Data constructor GHC.Types.TyCon
164 , DataCon ) -- Data constructor GHC.Types.TrNameS
165
166 mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
167 mk_typeable_binds stuff tycon
168 = mkTyConRepBinds stuff tycon
169 `unionBags`
170 unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
171
172 mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
173 mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
174 = case tyConRepName_maybe tycon of
175 Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
176 where
177 rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
178 _ -> emptyBag
179 where
180 tr_tycon = dataConTyCon tr_datacon
181 rep_rhs = nlHsApps (dataConWrapId tr_datacon)
182 [ nlHsLit (word64 high), nlHsLit (word64 low)
183 , mod_expr
184 , trNameLit trn_datacon (mkFastString tycon_str) ]
185
186 tycon_str = add_tick (occNameString (getOccName tycon))
187 add_tick s | isPromotedDataCon tycon = '\'' : s
188 | isPromotedTyCon tycon = '\'' : s
189 | otherwise = s
190
191 hashThis :: String
192 hashThis = unwords [pkg_str, mod_str, tycon_str]
193
194 Fingerprint high low
195 | gopt Opt_SuppressUniques dflags = Fingerprint 0 0
196 | otherwise = fingerprintString hashThis
197
198 word64 :: Word64 -> HsLit
199 word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
200 | otherwise = \n -> HsWordPrim (show n) (toInteger n)
201
202 mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
203 mkTypeableDataConBinds stuff dc
204 = case promoteDataCon_maybe dc of
205 Promoted tc -> mkTyConRepBinds stuff tc
206 NotPromoted -> emptyBag