Major refactoring of CoAxioms
[ghc.git] / compiler / typecheck / TcGenGenerics.lhs
1 %
2 % (c) The University of Glasgow 2011
3 %
4
5 The deriving code for the Generic class
6 (equivalent to the code in TcGenDeriv, for other classes)
7
8 \begin{code}
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16
17 module TcGenGenerics (canDoGenerics, gen_Generic_binds) where
18
19
20 import DynFlags
21 import HsSyn
22 import Type
23 import TcType
24 import TcGenDeriv
25 import DataCon
26 import TyCon
27 import FamInstEnv       ( FamInst, mkSynFamInst )
28 import Module           ( Module, moduleName, moduleNameString )
29 import IfaceEnv         ( newGlobalBinder )
30 import Name      hiding ( varName )
31 import RdrName
32 import BasicTypes
33 import TysWiredIn
34 import PrelNames
35 import InstEnv
36 import TcEnv
37 import MkId
38 import TcRnMonad
39 import HscTypes
40 import BuildTyCl
41 import SrcLoc
42 import Bag
43 import Outputable 
44 import FastString
45 import UniqSupply
46
47 #include "HsVersions.h"
48 \end{code}
49
50 %************************************************************************
51 %*                                                                      *
52 \subsection{Bindings for the new generic deriving mechanism}
53 %*                                                                      *
54 %************************************************************************
55
56 For the generic representation we need to generate:
57 \begin{itemize}
58 \item A Generic instance
59 \item A Rep type instance 
60 \item Many auxiliary datatypes and instances for them (for the meta-information)
61 \end{itemize}
62
63 \begin{code}
64 gen_Generic_binds :: TyCon -> Module
65                  -> TcM (LHsBinds RdrName, BagDerivStuff)
66 gen_Generic_binds tc mod = do
67         { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
68         ; metaInsts                <- genDtMeta (tc, metaTyCons)
69         ; return ( mkBindsRep tc
70                  ,           (DerivFamInst rep0TyInst)
71                    `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
72                    `unionBags` metaInsts)) }
73
74 genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst)
75 genGenericRepExtras tc mod =
76   do  uniqS <- newUniqueSupply
77       let
78         -- Uniques for everyone
79         (uniqD:uniqs) = uniqsFromSupply uniqS
80         (uniqsC,us) = splitAt (length tc_cons) uniqs
81         uniqsS :: [[Unique]] -- Unique supply for the S datatypes
82         uniqsS = mkUniqsS tc_arits us
83         mkUniqsS []    _  = []
84         mkUniqsS (n:t) us = case splitAt n us of
85                               (us1,us2) -> us1 : mkUniqsS t us2
86
87         tc_name   = tyConName tc
88         tc_cons   = tyConDataCons tc
89         tc_arits  = map dataConSourceArity tc_cons
90         
91         tc_occ    = nameOccName tc_name
92         d_occ     = mkGenD tc_occ
93         c_occ m   = mkGenC tc_occ m
94         s_occ m n = mkGenS tc_occ m n
95         d_name    = mkExternalName uniqD mod d_occ wiredInSrcSpan
96         c_names   = [ mkExternalName u mod (c_occ m) wiredInSrcSpan
97                       | (u,m) <- zip uniqsC [0..] ]
98         s_names   = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan 
99                         | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
100         
101         mkTyCon name = ASSERT( isExternalName name )
102                        buildAlgTyCon name [] [] distinctAbstractTyConRhs
103                                           NonRecursive False NoParentTyCon
104
105       let metaDTyCon  = mkTyCon d_name
106           metaCTyCons = map mkTyCon c_names
107           metaSTyCons =  [ [ mkTyCon s_name | s_name <- s_namesC ] 
108                          | s_namesC <- s_names ]
109
110           metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
111   
112       rep0_tycon <- tc_mkRepTyCon tc metaDts mod
113       
114       -- pprTrace "rep0" (ppr rep0_tycon) $
115       return (metaDts, rep0_tycon)
116
117 genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff
118 genDtMeta (tc,metaDts) =
119   do  loc <- getSrcSpanM
120       dflags <- getDOpts
121       dClas <- tcLookupClass datatypeClassName
122       let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
123       d_dfun_name <- new_dfun_name dClas tc
124       cClas <- tcLookupClass constructorClassName
125       c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
126       sClas <- tcLookupClass selectorClassName
127       s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
128                                                | _ <- x ] 
129                                              | x <- metaS metaDts ])
130       fix_env <- getFixityEnv
131
132       let
133         safeOverlap = safeLanguageOn dflags
134         (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
135         
136         -- Datatype
137         d_metaTycon = metaD metaDts
138         d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
139         d_binds = VanillaInst dBinds [] False
140         d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
141                     [ mkTyConTy d_metaTycon ]
142         d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
143         
144         -- Constructor
145         c_metaTycons = metaC metaDts
146         c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
147                   | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
148         c_binds = [ VanillaInst c [] False | c <- cBinds ]
149         c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
150                                [ mkTyConTy c ]
151         c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
152                    | (is,bs) <- myZip1 c_insts c_binds ]
153         
154         -- Selector
155         s_metaTycons = metaS metaDts
156         s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
157                                                   NoOverlap safeOverlap))
158                     (myZip2 s_metaTycons s_dfun_names)
159         s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
160         s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
161                                [ mkTyConTy s ]
162         s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
163                                                              , iBinds = bs})))
164                        (myZip2 s_insts s_binds)
165        
166         myZip1 :: [a] -> [b] -> [(a,b)]
167         myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
168         
169         myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
170         myZip2 l1 l2 =
171           ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
172             [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
173         
174       return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst))
175 \end{code}
176
177 %************************************************************************
178 %*                                                                      *
179 \subsection{Generating representation types}
180 %*                                                                      *
181 %************************************************************************
182
183 \begin{code}
184 canDoGenerics :: TyCon -> Maybe SDoc
185 -- Called on source-code data types, to see if we should generate
186 -- generic functions for them.
187 -- Nothing == yes
188 -- Just s  == no, because of `s`
189
190 canDoGenerics tycon
191   =  mergeErrors (
192           -- We do not support datatypes with context
193               (if (not (null (tyConStupidTheta tycon)))
194                 then (Just (ppr tycon <+> text "must not have a datatype context"))
195                 else Nothing)
196           -- We don't like type families
197             : (if (isFamilyTyCon tycon)
198                 then (Just (ppr tycon <+> text "must not be a family instance"))
199                 else Nothing)
200           -- See comment below
201             : (map bad_con (tyConDataCons tycon)))
202   where
203         -- If any of the constructor has an unboxed type as argument,
204         -- then we can't build the embedding-projection pair, because
205         -- it relies on instantiating *polymorphic* sum and product types
206         -- at the argument types of the constructors
207     bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
208                   then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
209                   else (if (not (isVanillaDataCon dc))
210                           then (Just (ppr dc <+> text "must be a vanilla data constructor"))
211                           else Nothing)
212
213         -- Nor can we do the job if it's an existential data constructor,
214         -- Nor if the args are polymorphic types (I don't think)
215     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
216     
217     mergeErrors :: [Maybe SDoc] -> Maybe SDoc
218     mergeErrors []           = Nothing
219     mergeErrors ((Just s):t) = case mergeErrors t of
220                                  Nothing -> Just s
221                                  Just s' -> Just (s <> text ", and" $$ s')
222     mergeErrors (Nothing :t) = mergeErrors t
223 \end{code}
224
225 %************************************************************************
226 %*                                                                      *
227 \subsection{Generating the RHS of a generic default method}
228 %*                                                                      *
229 %************************************************************************
230
231 \begin{code}
232 type US = Int   -- Local unique supply, just a plain Int
233 type Alt = (LPat RdrName, LHsExpr RdrName)
234
235 -- Bindings for the Generic instance
236 mkBindsRep :: TyCon -> LHsBinds RdrName
237 mkBindsRep tycon = 
238     unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
239   `unionBags`
240     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
241       where
242         from_matches  = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
243         to_matches    = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
244         loc           = srcLocSpan (getSrcLoc tycon)
245         datacons      = tyConDataCons tycon
246
247         -- Recurse over the sum first
248         from_alts, to_alts :: [Alt]
249         (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
250         
251 --------------------------------------------------------------------------------
252 -- The type instance synonym and synonym
253 --       type instance Rep (D a b) = Rep_D a b
254 --       type Rep_D a b = ...representation type for D ...
255 --------------------------------------------------------------------------------
256
257 tc_mkRepTyCon :: TyCon            -- The type to generate representation for
258                -> MetaTyCons      -- Metadata datatypes to refer to
259                -> Module          -- Used as the location of the new RepTy
260                -> TcM FamInst     -- Generated representation0 coercion
261 tc_mkRepTyCon tycon metaDts mod = 
262 -- Consider the example input tycon `D`, where data D a b = D_ a
263   do { -- `rep0` = GHC.Generics.Rep (type family)
264        rep0 <- tcLookupTyCon repTyConName
265
266        -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
267      ; rep0Ty <- tc_mkRepTy tycon metaDts
268     
269        -- `rep_name` is a name we generate for the synonym
270      ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
271                      (nameSrcSpan (tyConName tycon))
272
273      ; let -- `tyvars` = [a,b]
274            tyvars  = tyConTyVars tycon
275
276            -- `appT` = D a b
277            appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
278      ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
279      }
280
281
282
283 --------------------------------------------------------------------------------
284 -- Type representation
285 --------------------------------------------------------------------------------
286
287 tc_mkRepTy :: -- The type to generate representation for
288                TyCon 
289                -- Metadata datatypes to refer to
290             -> MetaTyCons 
291                -- Generated representation0 type
292             -> TcM Type
293 tc_mkRepTy tycon metaDts = 
294   do
295     d1    <- tcLookupTyCon d1TyConName
296     c1    <- tcLookupTyCon c1TyConName
297     s1    <- tcLookupTyCon s1TyConName
298     nS1   <- tcLookupTyCon noSelTyConName
299     rec0  <- tcLookupTyCon rec0TyConName
300     par0  <- tcLookupTyCon par0TyConName
301     u1    <- tcLookupTyCon u1TyConName
302     v1    <- tcLookupTyCon v1TyConName
303     plus  <- tcLookupTyCon sumTyConName
304     times <- tcLookupTyCon prodTyConName
305     
306     let mkSum' a b = mkTyConApp plus  [a,b]
307         mkProd a b = mkTyConApp times [a,b]
308         mkRec0 a   = mkTyConApp rec0  [a]
309         mkPar0 a   = mkTyConApp par0  [a]
310         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
311         mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a) 
312                                                  (null (dataConFieldLabels a))]
313         -- This field has no label
314         mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
315         -- This field has a  label
316         mkS False d a = mkTyConApp s1 [d, a]
317         
318         sumP [] = mkTyConTy v1
319         sumP l  = ASSERT (length metaCTyCons == length l)
320                     foldBal mkSum' [ mkC i d a
321                                    | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
322         -- The Bool is True if this constructor has labelled fields
323         prod :: Int -> [Type] -> Bool -> Type
324         prod i [] _ = ASSERT (length metaSTyCons > i)
325                         ASSERT (length (metaSTyCons !! i) == 0)
326                           mkTyConTy u1
327         prod i l b  = ASSERT (length metaSTyCons > i)
328                         ASSERT (length l == length (metaSTyCons !! i))
329                           foldBal mkProd [ arg d t b
330                                          | (d,t) <- zip (metaSTyCons !! i) l ]
331         
332         arg :: Type -> Type -> Bool -> Type
333         arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
334         -- Argument is not a type variable, use Rec0
335         recOrPar t Nothing  = mkRec0 t
336         -- Argument is a type variable, use Par0
337         recOrPar t (Just _) = mkPar0 t
338         
339         metaDTyCon  = mkTyConTy (metaD metaDts)
340         metaCTyCons = map mkTyConTy (metaC metaDts)
341         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
342         
343     return (mkD tycon)
344
345 --------------------------------------------------------------------------------
346 -- Meta-information
347 --------------------------------------------------------------------------------
348
349 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
350                                metaD :: TyCon
351                                -- One meta datatype per constructor
352                              , metaC :: [TyCon]
353                                -- One meta datatype per selector per constructor
354                              , metaS :: [[TyCon]] }
355                              
356 instance Outputable MetaTyCons where
357   ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
358                                    
359 metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
360 metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
361
362
363 -- Bindings for Datatype, Constructor, and Selector instances
364 mkBindsMetaD :: FixityEnv -> TyCon 
365              -> ( LHsBinds RdrName      -- Datatype instance
366                 , [LHsBinds RdrName]    -- Constructor instances
367                 , [[LHsBinds RdrName]]) -- Selector instances
368 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
369       where
370         mkBag l = foldr1 unionBags 
371                     [ unitBag (L loc (mkFunBind (L loc name) matches)) 
372                         | (name, matches) <- l ]
373         dtBinds       = mkBag [ (datatypeName_RDR, dtName_matches)
374                               , (moduleName_RDR, moduleName_matches)]
375
376         allConBinds   = map conBinds datacons
377         conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
378                               ++ ifElseEmpty (dataConIsInfix c)
379                                    [ (conFixity_RDR, conFixity_matches c) ]
380                               ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
381                                    [ (conIsRecord_RDR, conIsRecord_matches c) ]
382                               )
383
384         ifElseEmpty p x = if p then x else []
385         fixity c      = case lookupFixity fix_env (dataConName c) of
386                           Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
387                           Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
388                           Fixity n InfixN -> buildFix n notAssocDataCon_RDR
389         buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
390                                                      , nlHsIntLit (toInteger n)]
391
392         allSelBinds   = map (map selBinds) datasels
393         selBinds s    = mkBag [(selName_RDR, selName_matches s)]
394
395         loc           = srcLocSpan (getSrcLoc tycon)
396         mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
397         datacons      = tyConDataCons tycon
398         datasels      = map dataConFieldLabels datacons
399
400         dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName 
401                            $ tycon
402         moduleName_matches = mkStringLHS . moduleNameString . moduleName 
403                            . nameModule . tyConName $ tycon
404
405         conName_matches     c = mkStringLHS . showPpr . nameOccName
406                               . dataConName $ c
407         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
408         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
409
410         selName_matches     s = mkStringLHS (showPpr (nameOccName s))
411
412
413 --------------------------------------------------------------------------------
414 -- Dealing with sums
415 --------------------------------------------------------------------------------
416
417 mkSum :: US          -- Base for generating unique names
418       -> TyCon       -- The type constructor
419       -> [DataCon]   -- The data constructors
420       -> ([Alt],     -- Alternatives for the T->Trep "from" function
421           [Alt])     -- Alternatives for the Trep->T "to" function
422
423 -- Datatype without any constructors
424 mkSum _us tycon [] = ([from_alt], [to_alt])
425   where
426     from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
427     to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
428                -- These M1s are meta-information for the datatype
429     makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
430     errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
431     errMsgTo = "No values for empty datatype " ++ showPpr tycon
432
433 -- Datatype with at least one constructor
434 mkSum us _tycon datacons =
435   unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
436
437 -- Build the sum for a particular constructor
438 mk1Sum :: US        -- Base for generating unique names
439        -> Int       -- The index of this constructor
440        -> Int       -- Total number of constructors
441        -> DataCon   -- The data constructor
442        -> (Alt,     -- Alternative for the T->Trep "from" function
443            Alt)     -- Alternative for the Trep->T "to" function
444 mk1Sum us i n datacon = (from_alt, to_alt)
445   where
446     n_args = dataConSourceArity datacon -- Existentials already excluded
447
448     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
449     us'          = us + n_args
450
451     datacon_rdr  = getRdrName datacon
452     app_exp      = nlHsVarApps datacon_rdr datacon_vars
453     
454     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
455     from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
456     
457     to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
458                  -- These M1s are meta-information for the datatype
459     to_alt_rhs = app_exp
460
461 -- Generates the L1/R1 sum pattern
462 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
463 genLR_P i n p
464   | n == 0       = error "impossible"
465   | n == 1       = p
466   | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
467   | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
468                      where m = div n 2
469
470 -- Generates the L1/R1 sum expression
471 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
472 genLR_E i n e
473   | n == 0       = error "impossible"
474   | n == 1       = e
475   | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
476   | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
477                      where m = div n 2
478
479 --------------------------------------------------------------------------------
480 -- Dealing with products
481 --------------------------------------------------------------------------------
482
483 -- Build a product expression
484 mkProd_E :: US              -- Base for unique names
485          -> [RdrName]       -- List of variables matched on the lhs
486          -> LHsExpr RdrName -- Resulting product expression
487 mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
488 mkProd_E _ vars = mkM1_E (foldBal prod appVars)
489                    -- These M1s are meta-information for the constructor
490   where
491     appVars = map wrapArg_E vars
492     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
493
494 wrapArg_E :: RdrName -> LHsExpr RdrName
495 wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
496               -- This M1 is meta-information for the selector
497
498 -- Build a product pattern
499 mkProd_P :: US                  -- Base for unique names
500                -> [RdrName]     -- List of variables to match
501                -> LPat RdrName  -- Resulting product pattern
502 mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
503 mkProd_P _ vars = mkM1_P (foldBal prod appVars)
504                    -- These M1s are meta-information for the constructor
505   where
506     appVars = map wrapArg_P vars
507     prod a b = prodDataCon_RDR `nlConPat` [a,b]
508     
509 wrapArg_P :: RdrName -> LPat RdrName
510 wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
511               -- This M1 is meta-information for the selector
512
513 mkGenericLocal :: US -> RdrName
514 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
515
516 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
517 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
518
519 mkM1_P :: LPat RdrName -> LPat RdrName
520 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
521
522 -- | Variant of foldr1 for producing balanced lists
523 foldBal :: (a -> a -> a) -> [a] -> a
524 foldBal op = foldBal' op (error "foldBal: empty list")
525
526 foldBal' :: (a -> a -> a) -> a -> [a] -> a
527 foldBal' _  x []  = x
528 foldBal' _  _ [y] = y
529 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
530                     in foldBal' op x a `op` foldBal' op x b
531
532 \end{code}