2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsListComp]{Desugaring list comprehensions}
7 #include "HsVersions.h"
9 module DsListComp ( dsListComp ) where
12 IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
14 import HsSyn ( Qual(..), HsExpr, HsBinds )
15 import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
16 import DsHsSyn ( outPatType )
19 import DsMonad -- the monadery used in the desugarer
22 import CmdLineOpts ( opt_FoldrBuildOn )
23 import CoreUtils ( coreExprType, mkCoreIfThenElse )
24 import PrelVals ( mkBuild, foldrId )
25 import Type ( mkTyVarTy, mkForAllTy, mkFunTys )
26 import TysPrim ( alphaTy )
27 import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
28 import TyVar ( alphaTyVar )
29 import Match ( matchSimply )
33 List comprehensions may be desugared in one of two ways: ``ordinary''
34 (as you would expect if you read SLPJ's book) and ``with foldr/build
35 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
37 There will be at least one ``qualifier'' in the input.
40 dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
44 expr_ty = coreExprType expr
46 if not opt_FoldrBuildOn then -- be boring
47 deListComp expr quals (nIL_EXPR expr_ty)
49 else -- foldr/build lives!
50 new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) ->
52 alpha_to_alpha = mkFunTys [alphaTy] alphaTy
54 c_ty = mkFunTys [expr_ty, n_ty] n_ty
55 g_ty = mkForAllTy alphaTyVar (
56 (mkFunTys [expr_ty, alpha_to_alpha] alpha_to_alpha))
58 newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
60 dfListComp expr expr_ty
63 quals `thenDs` \ result ->
65 returnDs (mkBuild expr_ty n_tyvar c n g result)
67 nIL_EXPR ty = mkCon nilDataCon [] [ty] []
69 new_alpha_tyvar :: DsM (TyVar, Type)
71 = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] ->
72 returnDs (new_ty, mkTyVarTy new_ty)
75 %************************************************************************
77 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
79 %************************************************************************
81 Just as in Phil's chapter~7 in SLPJ, using the rules for
82 optimally-compiled list comprehensions. This is what Kevin followed
83 as well, and I quite happily do the same. The TQ translation scheme
84 transforms a list of qualifiers (either boolean expressions or
85 generators) into a single expression which implements the list
86 comprehension. Because we are generating 2nd-order polymorphic
87 lambda-calculus, calls to NIL and CONS must be applied to a type
88 argument, as well as their usual value arguments.
90 TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
93 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
96 TQ << [ e | b , qs ] ++ L >> =
97 if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
100 TQ << [ e | p <- L1, qs ] ++ L2 >> =
106 (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
111 "h", "u1", "u2", and "u3" are new variables.
114 @deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
115 is the TE translation scheme. Note that we carry around the @L@ list
116 already desugared. @dsListComp@ does the top TE rule mentioned above.
119 deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
121 deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above
122 = mkConDs consDataCon [coreExprType expr] [expr, list]
124 deListComp expr (FilterQual filt : quals) list -- rule B above
125 = dsExpr filt `thenDs` \ core_filt ->
126 deListComp expr quals list `thenDs` \ core_rest ->
127 returnDs ( mkCoreIfThenElse core_filt core_rest list )
129 deListComp expr (LetQual binds : quals) list
130 = panic "deListComp:LetQual"
132 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
133 = dsExpr list1 `thenDs` \ core_list1 ->
135 u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing
137 -- u1_ty is a [alpha] type, and u2_ty = alpha
138 u2_ty = outPatType pat
140 res_ty = coreExprType core_list2
141 h_ty = mkFunTys [u1_ty] res_ty
143 newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
144 `thenDs` \ [h', u1, u2, u3] ->
146 Make the function h unfoldable by the deforester.
147 Since it only occurs once in the body, we can't get
148 an increase in code size by unfolding it.
151 h = if False -- LATER: sw_chkr DoDeforest???
152 then panic "deListComp:deforest"
153 -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
156 -- the "fail" value ...
157 mkAppDs (Var h) [] [Var u3] `thenDs` \ core_fail ->
159 deListComp expr quals core_fail `thenDs` \ rest_expr ->
161 matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
163 mkAppDs (Var h) [] [core_list1] `thenDs` \ letrec_body ->
171 [(nilDataCon, [], core_list2),
172 (consDataCon, [u2, u3], core_match)]
178 %************************************************************************
180 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
182 %************************************************************************
184 @dfListComp@ are the rules used with foldr/build turned on:
186 TE < [ e | ] >> c n = c e n
187 TE << [ e | b , q ] >> c n = if b then TE << [ e | q ] >> c n else n
188 TE << [ e | p <- l , q ] c n = foldr
189 (\ TE << p >> b -> TE << [ e | q ] >> c b
193 dfListComp :: CoreExpr -- the inside of the comp
194 -> Type -- the type of the inside
195 -> Type -> Id -- 'c'; its type and id
196 -> Type -> Id -- 'n'; its type and id
197 -> [TypecheckedQual] -- the rest of the qual's
200 dfListComp expr expr_ty c_ty c_id n_ty n_id []
201 = mkAppDs (Var c_id) [] [expr, Var n_id]
203 dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
204 = dsExpr filt `thenDs` \ core_filt ->
205 dfListComp expr expr_ty c_ty c_id n_ty n_id quals
206 `thenDs` \ core_rest ->
207 returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
209 dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
210 = panic "dfListComp:LetQual"
212 dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
213 -- evaluate the two lists
214 = dsExpr list1 `thenDs` \ core_list1 ->
216 -- find the required type
218 let p_ty = outPatType pat
219 b_ty = n_ty -- alias b_ty to n_ty
220 fn_ty = mkFunTys [p_ty, b_ty] b_ty
221 lst_ty = coreExprType core_list1
224 -- create some new local id's
226 newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty] `thenDs` \ [b,p,fn,lst] ->
228 -- build rest of the comprehesion
230 dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest ->
231 -- build the pattern match
233 matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr ->
235 -- now build the outermost foldr, and return
239 [NonRec fn (mkValLam [p, b] core_expr),
240 NonRec lst core_list1]
241 (mkFoldr p_ty n_ty fn n_id lst)
245 = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]