2 % (c) The University of Glasgow 2011
7 module Generics ( canDoGenerics,
8 mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
9 MetaTyCons(..), metaTyCons2TyCons
19 import Name hiding (varName)
20 import Module (moduleName, moduleNameString)
25 -- For generation of representation types
26 import TcEnv (tcLookupTyCon)
27 import TcRnMonad (TcM, newUnique)
35 #include "HsVersions.h"
38 %************************************************************************
40 \subsection{Generating representation types}
42 %************************************************************************
45 canDoGenerics :: TyCon -> Bool
46 -- Called on source-code data types, to see if we should generate
47 -- generic functions for them.
50 = let result = not (any bad_con (tyConDataCons tycon)) -- See comment below
51 -- We do not support datatypes with context (for now)
52 && null (tyConStupidTheta tycon)
54 -- Primitives are (probably) not representable either
55 && not (isPrimTyCon tycon)
56 -- Foreigns are (probably) not representable either
57 && not (isForeignTyCon tycon)
59 -- We don't like type families
60 && not (isFamilyTyCon tycon)
62 in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result
64 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
65 -- If any of the constructor has an unboxed type as argument,
66 -- then we can't build the embedding-projection pair, because
67 -- it relies on instantiating *polymorphic* sum and product types
68 -- at the argument types of the constructors
70 -- Nor can we do the job if it's an existential data constructor,
72 -- Nor if the args are polymorphic types (I don't think)
73 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
76 %************************************************************************
78 \subsection{Generating the RHS of a generic default method}
80 %************************************************************************
83 type US = Int -- Local unique supply, just a plain Int
84 type Alt = (LPat RdrName, LHsExpr RdrName)
86 -- Bindings for the Representable0 instance
87 mkBindsRep0 :: TyCon -> LHsBinds RdrName
89 unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
91 unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
93 from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
94 to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ]
95 loc = srcLocSpan (getSrcLoc tycon)
96 datacons = tyConDataCons tycon
98 -- Recurse over the sum first
99 from0_alts, to0_alts :: [Alt]
100 (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
102 --------------------------------------------------------------------------------
103 -- Type representation
104 --------------------------------------------------------------------------------
106 tc_mkRep0Ty :: -- The type to generate representation for
108 -- Metadata datatypes to refer to
110 -- Generated representation0 type
112 tc_mkRep0Ty tycon metaDts =
114 d1 <- tcLookupTyCon d1TyConName
115 c1 <- tcLookupTyCon c1TyConName
116 s1 <- tcLookupTyCon s1TyConName
117 nS1 <- tcLookupTyCon noSelTyConName
118 rec0 <- tcLookupTyCon rec0TyConName
119 par0 <- tcLookupTyCon par0TyConName
120 u1 <- tcLookupTyCon u1TyConName
121 v1 <- tcLookupTyCon v1TyConName
122 plus <- tcLookupTyCon sumTyConName
123 times <- tcLookupTyCon prodTyConName
125 let mkSum' a b = mkTyConApp plus [a,b]
126 mkProd a b = mkTyConApp times [a,b]
127 mkRec0 a = mkTyConApp rec0 [a]
128 mkPar0 a = mkTyConApp par0 [a]
129 mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
130 mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
131 (null (dataConFieldLabels a))]
132 -- This field has no label
133 mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
134 -- This field has a label
135 mkS False d a = mkTyConApp s1 [d, a]
137 sumP [] = mkTyConTy v1
138 sumP l = ASSERT (length metaCTyCons == length l)
139 foldBal mkSum' [ mkC i d a
140 | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
141 -- The Bool is True if this constructor has labelled fields
142 prod :: Int -> [Type] -> Bool -> Type
143 prod i [] _ = ASSERT (length metaSTyCons > i)
144 ASSERT (length (metaSTyCons !! i) == 0)
146 prod i l b = ASSERT (length metaSTyCons > i)
147 ASSERT (length l == length (metaSTyCons !! i))
148 foldBal mkProd [ arg d t b
149 | (d,t) <- zip (metaSTyCons !! i) l ]
151 arg :: Type -> Type -> Bool -> Type
152 arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
153 -- Argument is not a type variable, use Rec0
154 recOrPar t Nothing = mkRec0 t
155 -- Argument is a type variable, use Par0
156 recOrPar t (Just _) = mkPar0 t
158 metaDTyCon = mkTyConTy (metaD metaDts)
159 metaCTyCons = map mkTyConTy (metaC metaDts)
160 metaSTyCons = map (map mkTyConTy) (metaS metaDts)
164 tc_mkRep0TyCon :: TyCon -- The type to generate representation for
165 -> MetaTyCons -- Metadata datatypes to refer to
166 -> TcM TyCon -- Generated representation0 type
167 tc_mkRep0TyCon tycon metaDts =
168 -- Consider the example input tycon `D`, where data D a b = D_ a
172 -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
173 rep0Ty <- tc_mkRep0Ty tycon metaDts
174 -- `rep0` = GHC.Generics.Rep0 (type family)
175 rep0 <- tcLookupTyCon rep0TyConName
177 let modl = nameModule (tyConName tycon)
178 loc = nameSrcSpan (tyConName tycon)
179 -- `repName` is a name we generate for the synonym
180 repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
181 -- `coName` is a name for the coercion
182 coName = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
184 tyvars = tyConTyVars tycon
186 appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
188 res = mkSynTyCon repName
189 -- rep0Ty has kind `kind of D` -> *
190 (tyConKind tycon `mkArrowKind` liftedTypeKind)
191 tyvars (SynonymTyCon rep0Ty)
192 (FamInstTyCon rep0 appT
193 (mkCoercionTyCon coName (tyConArity tycon)
194 -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
195 (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
199 --------------------------------------------------------------------------------
201 --------------------------------------------------------------------------------
203 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
205 -- One meta datatype per constructor
207 -- One meta datatype per selector per constructor
208 , metaS :: [[TyCon]] }
210 instance Outputable MetaTyCons where
211 ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
213 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
214 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
217 -- Bindings for Datatype, Constructor, and Selector instances
218 mkBindsMetaD :: FixityEnv -> TyCon
219 -> ( LHsBinds RdrName -- Datatype instance
220 , [LHsBinds RdrName] -- Constructor instances
221 , [[LHsBinds RdrName]]) -- Selector instances
222 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
224 mkBag l = foldr1 unionBags
225 [ unitBag (L loc (mkFunBind (L loc name) matches))
226 | (name, matches) <- l ]
227 dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
228 , (moduleName_RDR, moduleName_matches)]
230 allConBinds = map conBinds datacons
231 conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
232 ++ ifElseEmpty (dataConIsInfix c)
233 [ (conFixity_RDR, conFixity_matches c) ]
234 ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
235 [ (conIsRecord_RDR, conIsRecord_matches c) ]
238 ifElseEmpty p x = if p then x else []
239 fixity c = case lookupFixity fix_env (dataConName c) of
240 Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
241 Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
242 Fixity n InfixN -> buildFix n notAssocDataCon_RDR
243 buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
244 , nlHsIntLit (toInteger n)]
246 allSelBinds = map (map selBinds) datasels
247 selBinds s = mkBag [(selName_RDR, selName_matches s)]
249 loc = srcLocSpan (getSrcLoc tycon)
250 mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
251 datacons = tyConDataCons tycon
252 datasels = map dataConFieldLabels datacons
254 dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
256 moduleName_matches = mkStringLHS . moduleNameString . moduleName
257 . nameModule . tyConName $ tycon
259 conName_matches c = mkStringLHS . showPpr . nameOccName
261 conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
262 conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
264 selName_matches s = mkStringLHS (showPpr (nameOccName s))
267 --------------------------------------------------------------------------------
269 --------------------------------------------------------------------------------
271 mkSum :: US -- Base for generating unique names
272 -> TyCon -- The type constructor
273 -> [DataCon] -- The data constructors
274 -> ([Alt], -- Alternatives for the T->Trep "from" function
275 [Alt]) -- Alternatives for the Trep->T "to" function
277 -- Datatype without any constructors
278 mkSum _us tycon [] = ([from_alt], [to_alt])
280 from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
281 to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
282 -- These M1s are meta-information for the datatype
283 makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
284 errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
285 errMsgTo = "No values for empty datatype " ++ showPpr tycon
287 -- Datatype with at least one constructor
288 mkSum us _tycon datacons =
289 unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
291 -- Build the sum for a particular constructor
292 mk1Sum :: US -- Base for generating unique names
293 -> Int -- The index of this constructor
294 -> Int -- Total number of constructors
295 -> DataCon -- The data constructor
296 -> (Alt, -- Alternative for the T->Trep "from" function
297 Alt) -- Alternative for the Trep->T "to" function
298 mk1Sum us i n datacon = (from_alt, to_alt)
300 n_args = dataConSourceArity datacon -- Existentials already excluded
302 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
305 datacon_rdr = getRdrName datacon
306 app_exp = nlHsVarApps datacon_rdr datacon_vars
308 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
309 from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
311 to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
312 -- These M1s are meta-information for the datatype
315 -- Generates the L1/R1 sum pattern
316 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
318 | n == 0 = error "impossible"
320 | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
321 | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
324 -- Generates the L1/R1 sum expression
325 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
327 | n == 0 = error "impossible"
329 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
330 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
333 --------------------------------------------------------------------------------
334 -- Dealing with products
335 --------------------------------------------------------------------------------
337 -- Build a product expression
338 mkProd_E :: US -- Base for unique names
339 -> [RdrName] -- List of variables matched on the lhs
340 -> LHsExpr RdrName -- Resulting product expression
341 mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
342 mkProd_E _ vars = mkM1_E (foldBal prod appVars)
343 -- These M1s are meta-information for the constructor
345 appVars = map wrapArg_E vars
346 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
348 wrapArg_E :: RdrName -> LHsExpr RdrName
349 wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
350 -- This M1 is meta-information for the selector
352 -- Build a product pattern
353 mkProd_P :: US -- Base for unique names
354 -> [RdrName] -- List of variables to match
355 -> LPat RdrName -- Resulting product pattern
356 mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
357 mkProd_P _ vars = mkM1_P (foldBal prod appVars)
358 -- These M1s are meta-information for the constructor
360 appVars = map wrapArg_P vars
361 prod a b = prodDataCon_RDR `nlConPat` [a,b]
363 wrapArg_P :: RdrName -> LPat RdrName
364 wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
365 -- This M1 is meta-information for the selector
367 mkGenericLocal :: US -> RdrName
368 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
370 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
371 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
373 mkM1_P :: LPat RdrName -> LPat RdrName
374 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
376 -- | Variant of foldr1 for producing balanced lists
377 foldBal :: (a -> a -> a) -> [a] -> a
378 foldBal op = foldBal' op (error "foldBal: empty list")
380 foldBal' :: (a -> a -> a) -> a -> [a] -> a
383 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
384 in foldBal' op x a `op` foldBal' op x b