2 % (c) The University of Glasgow 2006
6 {-# OPTIONS -fno-warn-incomplete-patterns #-}
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13 module Generics ( canDoGenerics, mkTyConGenericBinds,
15 validGenericInstanceType, validGenericMethodType,
16 mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
17 MetaTyCons(..), metaTyCons2TyCons
27 import Name hiding (varName)
28 import OccName (varName)
29 import Module (moduleName, moduleNameString)
32 import Var hiding (varName)
37 -- For generation of representation types
38 import TcEnv (tcLookupTyCon)
39 import TcRnMonad (TcM, newUnique)
40 import TcMType (newMetaTyVar)
49 import Data.List (splitAt)
50 import Debug.Trace (trace)
52 #include "HsVersions.h"
55 Roadmap of what's where in the Generics work.
56 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
62 Checks that HsNumTy has a "1" in it.
64 TcInstDcls.mkGenericInstance:
65 Checks for invalid type patterns, such as f {| Int |}
68 Checks for a method type that is too complicated;
69 e.g. has for-alls or lists in it
70 We could lift this restriction
72 TcClassDecl.mkDefMethRhs
73 Checks that the instance type is simple, in an instance decl
74 where we let the compiler fill in a generic method.
75 e.g. instance C (T Int)
76 is not valid if C has generic methods.
78 TcClassDecl.checkGenericClassIsUnary
79 Checks that we don't have generic methods in a multi-parameter class
81 TcClassDecl.checkDefaultBinds
82 Checks that all the equations for a method in a class decl
83 are generic, or all are non-generic
87 Checking that the type constructors which are present in Generic
88 patterns (not Unit, this is done differently) is done in mk_inst_info
89 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
90 HsOpTy is tied to Generic definitions which is not a very good design
91 feature, indeed a bug. However, the check is easy to move from
92 tcHsType back to mk_inst_info and everything will be fine. Also see
93 bug #5. [I don't think that this is the case anymore after SPJ's latest
94 changes in that regard. Delete this comment? -=chak/7Jun2]
98 Making generic information to put into a tycon. Constructs the
99 representation type, which, I think, are not used later. Perhaps it is
100 worth removing them from the GI datatype. Although it does get used in
101 the construction of conversion functions (internally).
105 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
109 Defines generic and other type and data constructors.
111 This is sadly incomplete, but will be added to.
114 Bugs & shortcomings of existing implementation:
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 2. Another pretty big bug I dscovered at the last minute when I was
118 testing the code is that at the moment the type variable of the class
119 is scoped over the entire declaration, including the patterns. For
120 instance, if I have the following code,
124 er {| Plus a b |} (Inl x) (Inl y) = er x y
125 er {| Plus a b |} (Inr x) (Inr y) = er x y
126 er {| Plus a b |} _ _ = False
128 and I print out the types of the generic patterns, I get the
129 following. Note that all the variable names for "a" are the same,
130 while for "b" they are all different.
133 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
134 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
135 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
137 This is a bug as if I change the code to
139 er {| Plus c b |} (Inl x) (Inl y) = er x y
141 all the names come out to be different.
143 Thus, all the types (Plus a b) come out to be different, so I cannot
144 compare them and test whether they are all the same and thus cannot
145 return an error if the type variables are different.
147 Temporary fix/hack. I am not checking for this, I just assume they are
148 the same, see line "check_ty = True" in TcInstDecls. When we resolve
149 the issue with variables, though - I assume that we will make them to
150 be the same in all the type patterns, jus uncomment the check and
151 everything should work smoothly.
153 Hence, I have also left the rather silly construction of:
154 * extracting all the type variables from all the types
155 * putting them *all* into the environment
156 * typechecking all the types
157 * selecting one of them and using it as the instance_ty.
159 (the alternative is to make sure that all the types are the same,
160 taking one, extracting its variables, putting them into the environment,
161 type checking it, using it as the instance_ty)
163 6. What happens if we do not supply all of the generic patterns? At
164 the moment, the compiler crashes with an error message "Non-exhaustive
165 patterns in a generic declaration"
168 What has not been addressed:
169 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 Contexts. In the generated instance declarations for the 3 primitive
172 type constructors, we need contexts. It is unclear what those should
173 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
175 Type application. We have type application in expressions
176 (essentially) on the lhs of an equation. Do we want to allow it on the
179 Scoping of type variables in a generic definition. At the moment, (see
180 TcInstDecls) we extract the type variables inside the type patterns
181 and add them to the environment. See my bug #2 above. This seems pretty
186 %************************************************************************
188 \subsection{Getting the representation type out}
190 %************************************************************************
193 validGenericInstanceType :: Type -> Bool
194 -- Checks for validity of the type pattern in a generic
195 -- declaration. It's ok to have
197 -- but it's not OK to have
200 validGenericInstanceType inst_ty
201 = case tcSplitTyConApp_maybe inst_ty of
202 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
205 validGenericMethodType :: Type -> Bool
206 -- At the moment we only allow method types built from
211 -- * an arbitrary type not involving the class type variables
212 -- e.g. this is ok: forall b. Ord b => [b] -> a
213 -- where a is the class variable
214 validGenericMethodType ty
217 (local_tvs, _, tau) = tcSplitSigmaTy ty
220 | not (isTauTy ty) = False -- Note [Higher ramk methods]
221 | isTyVarTy ty = True
222 | no_tyvars_in_ty = True
223 | otherwise = case tcSplitTyConApp_maybe ty of
224 Just (tc,tys) -> valid_tycon tc && all valid tys
227 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
229 valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
230 -- Compare bimapApp, below
234 %************************************************************************
236 \subsection{Generating representation types}
238 %************************************************************************
241 canDoGenerics :: ThetaType -> [DataCon] -> Bool
242 -- Called on source-code data types, to see if we should generate
243 -- generic functions for them. (This info is recorded in the interface file for
244 -- imported data types.)
246 canDoGenerics stupid_theta data_cons
247 = not (any bad_con data_cons) -- See comment below
249 -- && not (null data_cons) -- No values of the type
250 -- JPM: we now support empty datatypes
252 && null stupid_theta -- We do not support datatypes with context (for now)
254 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
255 -- If any of the constructor has an unboxed type as argument,
256 -- then we can't build the embedding-projection pair, because
257 -- it relies on instantiating *polymorphic* sum and product types
258 -- at the argument types of the constructors
260 -- Nor can we do the job if it's an existential data constructor,
262 -- Nor if the args are polymorphic types (I don't think)
263 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
264 -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it
265 -- like this for now...
268 %************************************************************************
270 \subsection{Generating the RHS of a generic default method}
272 %************************************************************************
275 type US = Int -- Local unique supply, just a plain Int
276 type Alt = (LPat RdrName, LHsExpr RdrName)
278 data GenRep = GenRep {
279 genBindsFrom0 :: TyCon -> LHsBinds RdrName
280 , genBindsTo0 :: TyCon -> LHsBinds RdrName
281 , genBindsFrom1 :: TyCon -> LHsBinds RdrName
282 , genBindsTo1 :: TyCon -> LHsBinds RdrName
283 , genBindsModuleName :: TyCon -> LHsBinds RdrName
284 , genBindsConName :: DataCon -> LHsBinds RdrName
285 , genBindsConFixity :: DataCon -> LHsBinds RdrName
286 , genBindsConIsRecord :: DataCon -> LHsBinds RdrName
287 , genBindsSelName :: DataCon -> Int -> LHsBinds RdrName
290 -- Bindings for the Representable0 instance
291 mkBindsRep0 :: TyCon -> LHsBinds RdrName
293 unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
295 unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
297 from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
298 to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ]
299 loc = srcLocSpan (getSrcLoc tycon)
300 datacons = tyConDataCons tycon
302 -- Recurse over the sum first
303 from0_alts, to0_alts :: [Alt]
304 (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
307 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
308 mkTyConGenericBinds tycon =
310 unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
312 unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
319 from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
320 to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ]
321 loc = srcLocSpan (getSrcLoc tycon)
322 datacons = tyConDataCons tycon
323 (from0_RDR, to0_RDR) = mkGenericNames tycon
325 -- Recurse over the sum first
326 from0_alts, to0_alts :: [Alt]
327 (from0_alts, to0_alts) = mkSum init_us tycon datacons
328 init_us = 1 :: US -- Unique supply
331 --------------------------------------------------------------------------------
332 -- Type representation
333 --------------------------------------------------------------------------------
335 mkRep0Ty :: TyCon -> LHsType Name
338 res = d1 `nlHsAppTy` (cons datacons)
339 d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO
340 c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO
341 s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO
342 plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b
343 times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b
344 k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x
346 datacons = tyConDataCons tycon
347 n_args datacon = dataConSourceArity datacon
348 datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon]
350 cons ds = c1 `nlHsAppTy` sum ds
351 sum [] = nlHsTyVar v1TyConName
352 sum l = foldBal plus (map sel l)
353 sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d)
354 prod [] = nlHsTyVar u1TyConName
355 prod l = foldBal times (map arg l)
356 arg :: Type -> LHsType Name
358 arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO
361 tc_mkRep0Ty :: -- The type to generate representation for
363 -- Metadata datatypes to refer to
365 -- Generated representation0 type
367 tc_mkRep0Ty tycon metaDts =
369 d1 <- tcLookupTyCon d1TyConName
370 c1 <- tcLookupTyCon c1TyConName
371 s1 <- tcLookupTyCon s1TyConName
372 rec0 <- tcLookupTyCon rec0TyConName
373 u1 <- tcLookupTyCon u1TyConName
374 v1 <- tcLookupTyCon v1TyConName
375 plus <- tcLookupTyCon sumTyConName
376 times <- tcLookupTyCon prodTyConName
377 noSel <- tcLookupTyCon noSelTyConName
378 freshTy <- newMetaTyVar TauTv liftedTypeKind
380 let mkSum a b = mkTyConApp plus [a,b]
381 mkProd a b = mkTyConApp times [a,b]
382 mkRec0 a = mkTyConApp rec0 [a]
383 mkD a = mkTyConApp d1 [metaDTyCon, sum (tyConDataCons a)]
384 mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)]
385 mkS d a = mkTyConApp s1 [d, a]
387 sum [] = mkTyConTy v1
388 sum l = ASSERT (length metaCTyCons == length l)
389 foldBal mkSum [ mkC i d a
390 | (d,(a,i)) <- zip metaCTyCons (zip l [0..]) ]
391 prod :: Int -> [Type] -> Type
392 prod i [] = ASSERT (length metaSTyCons > i)
393 ASSERT (length (metaSTyCons !! i) == 0)
395 prod i l = ASSERT (length metaSTyCons > i)
396 ASSERT (length l == length (metaSTyCons !! i))
397 foldBal mkProd [ arg d a
398 | (d,a) <- zip (metaSTyCons !! i) l ]
400 arg d t = mkS d (mkRec0 t)
402 metaDTyCon = mkTyConTy (metaD metaDts)
403 metaCTyCons = map mkTyConTy (metaC metaDts)
404 metaSTyCons = map (map mkTyConTy) (metaS metaDts)
408 tc_mkRep0TyCon :: TyCon -- The type to generate representation for
409 -> MetaTyCons -- Metadata datatypes to refer to
410 -> TcM TyCon -- Generated representation0 type
411 tc_mkRep0TyCon tycon metaDts =
412 -- Consider the example input tycon `D`, where data D a b = D_ a
416 -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
417 rep0Ty <- tc_mkRep0Ty tycon metaDts
418 -- `rep0` = GHC.Generics.Rep0 (type family)
419 rep0 <- tcLookupTyCon rep0TyConName
421 let mod = nameModule (tyConName tycon)
422 loc = nameSrcSpan (tyConName tycon)
423 -- `repName` is a name we generate for the synonym
424 repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc
425 -- `coName` is a name for the coercion
426 coName = mkExternalName uniq2 mod (mkGenR0 (nameOccName (tyConName tycon))) loc
428 tyvars = tyConTyVars tycon
430 appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
432 res = mkSynTyCon repName
433 -- rep0Ty has kind `kind of D` -> *
434 (tyConKind tycon `mkArrowKind` liftedTypeKind)
435 tyvars (SynonymTyCon rep0Ty)
436 (FamInstTyCon rep0 appT
437 (mkCoercionTyCon coName (tyConArity tycon)
438 -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
439 (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
443 --------------------------------------------------------------------------------
445 --------------------------------------------------------------------------------
447 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
449 -- One meta datatype per constructor
451 -- One meta datatype per selector per constructor
452 , metaS :: [[TyCon]] }
454 instance Outputable MetaTyCons where
455 ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
457 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
458 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
461 -- Bindings for Datatype, Constructor, and Selector instances
462 mkBindsMetaD :: FixityEnv -> TyCon
463 -> ( LHsBinds RdrName -- Datatype instance
464 , [LHsBinds RdrName] -- Constructor instances
465 , [[LHsBinds RdrName]]) -- Selector instances
466 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
468 mkBag l = foldr1 unionBags
469 [ unitBag (L loc (mkFunBind (L loc name) matches))
470 | (name, matches) <- l ]
471 dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
472 , (moduleName_RDR, moduleName_matches)]
474 allConBinds = map conBinds datacons
475 conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
476 ++ ifElseEmpty (dataConIsInfix c)
477 [ (conFixity_RDR, conFixity_matches c) ]
478 ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
479 [ (conIsRecord_RDR, conIsRecord_matches c) ]
480 ++ ifElseEmpty (isTupleCon c)
482 ,conIsTuple_matches (dataConTyCon c))]
485 ifElseEmpty p x = if p then x else []
486 fixity c = case lookupFixity fix_env (dataConName c) of
487 Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
488 Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
489 Fixity n InfixN -> buildFix n notAssocDataCon_RDR
490 buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
491 , nlHsIntLit (toInteger n)]
493 allSelBinds = map (map selBinds) datasels
494 selBinds s = mkBag [(selName_RDR, selName_matches s)]
496 loc = srcLocSpan (getSrcLoc tycon)
497 mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
498 datacons = tyConDataCons tycon
499 datasels = map dataConFieldLabels datacons
501 dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
503 moduleName_matches = mkStringLHS . moduleNameString . moduleName
504 . nameModule . tyConName $ tycon
506 conName_matches c = mkStringLHS . showPpr . nameOccName
508 conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
509 conIsRecord_matches c = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
510 -- TODO: check that this works
511 conIsTuple_matches c = [mkSimpleHsAlt nlWildPat
512 (nlHsApp (nlHsVar arityDataCon_RDR)
514 (toInteger (tupleTyConArity c))))]
516 selName_matches s = mkStringLHS (showPpr (nameOccName s))
519 --------------------------------------------------------------------------------
521 --------------------------------------------------------------------------------
523 mkSum :: US -- Base for generating unique names
524 -> TyCon -- The type constructor
525 -> [DataCon] -- The data constructors
526 -> ([Alt], -- Alternatives for the T->Trep "from" function
527 [Alt]) -- Alternatives for the Trep->T "to" function
529 -- Datatype without any constructors
530 mkSum _us tycon [] = ([from_alt], [to_alt])
532 from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
533 to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
534 -- These M1s are meta-information for the datatype
535 makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
536 errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
537 errMsgTo = "No values for empty datatype " ++ showPpr tycon
539 -- Datatype with at least one constructor
540 mkSum us _tycon datacons =
541 unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
543 -- Build the sum for a particular constructor
544 mk1Sum :: US -- Base for generating unique names
545 -> Int -- The index of this constructor
546 -> Int -- Total number of constructors
547 -> DataCon -- The data constructor
548 -> (Alt, -- Alternative for the T->Trep "from" function
549 Alt) -- Alternative for the Trep->T "to" function
550 mk1Sum us i n datacon = (from_alt, to_alt)
552 n_args = dataConSourceArity datacon -- Existentials already excluded
554 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
557 datacon_rdr = getRdrName datacon
558 app_exp = nlHsVarApps datacon_rdr datacon_vars
560 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
561 from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
563 to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
564 -- These M1s are meta-information for the datatype
567 -- Generates the L1/R1 sum pattern
568 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
570 | n == 0 = error "impossible"
572 | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
573 | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
576 -- Generates the L1/R1 sum expression
577 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
579 | n == 0 = error "impossible"
581 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
582 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
585 --------------------------------------------------------------------------------
586 -- Dealing with products
587 --------------------------------------------------------------------------------
589 -- Build a product expression
590 mkProd_E :: US -- Base for unique names
591 -> [RdrName] -- List of variables matched on the lhs
592 -> LHsExpr RdrName -- Resulting product expression
593 mkProd_E us [] = mkM1_E (nlHsVar u1DataCon_RDR)
594 mkProd_E us vars = mkM1_E (foldBal prod appVars)
595 -- These M1s are meta-information for the constructor
597 appVars = map wrapArg_E vars
598 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
600 -- TODO: Produce a P0 when v is a parameter
601 wrapArg_E :: RdrName -> LHsExpr RdrName
602 wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
603 -- This M1 is meta-information for the selector
605 -- Build a product pattern
606 mkProd_P :: US -- Base for unique names
607 -> [RdrName] -- List of variables to match
608 -> LPat RdrName -- Resulting product pattern
609 mkProd_P us [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
610 mkProd_P us vars = mkM1_P (foldBal prod appVars)
611 -- These M1s are meta-information for the constructor
613 appVars = map wrapArg_P vars
614 prod a b = prodDataCon_RDR `nlConPat` [a,b]
616 -- TODO: Produce a P0 when v is a parameter
617 wrapArg_P :: RdrName -> LPat RdrName
618 wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
619 -- This M1 is meta-information for the selector
622 mkGenericLocal :: US -> RdrName
623 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
625 mkGenericNames :: TyCon -> (RdrName, RdrName)
629 tc_name = tyConName tycon
630 tc_occ = nameOccName tc_name
631 tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name
632 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
633 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
635 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
636 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
638 mkM1_P :: LPat RdrName -> LPat RdrName
639 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
641 -- | Variant of foldr1 for producing balanced lists
642 foldBal :: (a -> a -> a) -> [a] -> a
643 foldBal op = foldBal' op (error "foldBal: empty list")
645 foldBal' :: (a -> a -> a) -> a -> [a] -> a
648 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
649 in foldBal' op x a `op` foldBal' op x b
653 %************************************************************************
655 \subsection{Generating the RHS of a generic default method}
657 %************************************************************************
659 Generating the Generic default method. Uses the bimaps to generate the
660 actual method. All of this is rather incomplete, but it would be nice
661 to make even this work. Example
668 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
671 op = <mkGenericRhs op a T>
673 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
675 toOp :: Op Trep -> Op T
676 fromOp :: Op T -> Op Trep
678 (the bimap) and then fill in the RHS with
683 Remember, we're generating a RenamedHsExpr, so the result of all this
684 will be fed to the type checker. So the 'op' on the RHS will be
685 at the representation type for T, Trep.
688 Note [Polymorphic methods]
689 ~~~~~~~~~~~~~~~~~~~~~~~~~~
690 Suppose the class op is polymorphic:
693 op :: forall b. Ord b => a -> b -> b
695 Then we can still generate a bimap with
697 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
699 and fill in the instance decl thus
704 By the time the type checker has done its stuff we'll get
707 op = \b. \dict::Ord b. toOp b (op Trep b dict)
709 Note [Higher rank methods]
710 ~~~~~~~~~~~~~~~~~~~~~~~~~~
711 Higher-rank method types don't work, because we'd generate a bimap that
712 needs impredicative polymorphism. In principle that should be possible
713 (with boxy types and all) but it would take a bit of working out. Here's
715 class ChurchEncode k where
717 -> (forall a b z. a -> b -> z) {- product -}
718 -> (forall a z. a -> z) {- left -}
719 -> (forall a z. a -> z) {- right -}
722 match {| Unit |} Unit unit prod left right = unit
723 match {| a :*: b |} (x :*: y) unit prod left right = prod x y
724 match {| a :+: b |} (Inl l) unit prod left right = left l
725 match {| a :+: b |} (Inr r) unit prod left right = right r
728 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
729 mkGenericRhs sel_id tyvar tycon
730 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
731 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
732 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
734 -- Initialising the "Environment" with the from/to functions
735 -- on the datatype (actually tycon) in question
736 (from_RDR, to_RDR) = mkGenericNames tycon
738 -- Instantiate the selector type, and strip off its class context
739 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
741 -- Do it again! This deals with the case where the method type
742 -- is polymorphic -- see Note [Polymorphic methods] above
743 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
745 -- Now we probably have a tycon in front
746 -- of us, quite probably a FunTyCon.
747 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
748 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
750 type EPEnv = (TyVar, -- The class type variable
751 EP (LHsExpr RdrName), -- The EP it maps to
752 [TyVar] -- Other in-scope tyvars; they have an identity EP
756 generate_bimap :: EPEnv
758 -> EP (LHsExpr RdrName)
759 -- Top level case - splitting the TyCon.
760 generate_bimap env@(tv,ep,local_tvs) ty
761 | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
762 = idEP -- A constant type
764 | Just tv1 <- getTyVar_maybe ty
765 = ASSERT( tv == tv1 ) ep -- The class tyvar
767 | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
768 = bimapTyCon tycon (map (generate_bimap env) ty_args)
771 = pprPanic "generate_bimap" (ppr ty)
774 bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
775 bimapTyCon tycon arg_eps
776 | tycon == funTyCon = bimapArrow arg_eps
777 | tycon == listTyCon = bimapList arg_eps
778 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
779 | otherwise = pprPanic "bimapTyCon" (ppr tycon)
782 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
783 bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
784 bimapArrow [ep1, ep2]
785 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
786 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
788 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
789 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
792 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
793 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
795 = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
796 toEP = mkHsLam [noLoc tuple_pat] to_body }
798 names = takeList eps gs_RDR
799 tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
800 eps_w_names = eps `zip` names
801 to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
802 from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
805 -- bimapList :: EP a b -> EP [a] [b]
806 bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
808 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
809 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
812 a_RDR, b_RDR :: RdrName
813 a_RDR = mkVarUnqual (fsLit "a")
814 b_RDR = mkVarUnqual (fsLit "b")
817 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
819 idEP :: EP (LHsExpr RdrName)
820 idEP = EP idexpr idexpr
822 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)