2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsListComp]{Desugaring list comprehensions}
7 module DsListComp ( dsListComp ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
13 import HsSyn ( Stmt(..) )
14 import TcHsSyn ( TypecheckedStmt )
15 import DsHsSyn ( outPatType )
18 import DsMonad -- the monadery used in the desugarer
21 import CmdLineOpts ( opt_FoldrBuildOn )
22 import CoreUtils ( exprType, mkIfThenElse )
25 import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type )
26 import TysPrim ( alphaTyVar )
27 import TysWiredIn ( nilDataCon, consDataCon )
28 import Match ( matchSimply )
29 import PrelNames ( foldrIdKey, buildIdKey )
32 List comprehensions may be desugared in one of two ways: ``ordinary''
33 (as you would expect if you read SLPJ's book) and ``with foldr/build
34 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
36 There will be at least one ``qualifier'' in the input.
39 dsListComp :: [TypecheckedStmt]
40 -> Type -- Type of list elements
43 dsListComp quals elt_ty
44 | not opt_FoldrBuildOn -- Be boring
45 = deListComp quals (mkNilExpr elt_ty)
47 | otherwise -- foldr/build lives!
48 = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
50 n_ty = mkTyVarTy n_tyvar
51 c_ty = mkFunTys [elt_ty, n_ty] n_ty
53 newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
55 dfListComp c n quals `thenDs` \ result ->
57 dsLookupGlobalValue buildIdKey `thenDs` \ build_id ->
58 returnDs (Var build_id `App` Type elt_ty
59 `App` mkLams [n_tyvar, c, n] result)
62 %************************************************************************
64 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
66 %************************************************************************
68 Just as in Phil's chapter~7 in SLPJ, using the rules for
69 optimally-compiled list comprehensions. This is what Kevin followed
70 as well, and I quite happily do the same. The TQ translation scheme
71 transforms a list of qualifiers (either boolean expressions or
72 generators) into a single expression which implements the list
73 comprehension. Because we are generating 2nd-order polymorphic
74 lambda-calculus, calls to NIL and CONS must be applied to a type
75 argument, as well as their usual value arguments.
77 TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
80 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
83 TQ << [ e | b , qs ] ++ L >> =
84 if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
87 TQ << [ e | p <- L1, qs ] ++ L2 >> =
93 (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
98 "h", "u1", "u2", and "u3" are new variables.
101 @deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
102 is the TE translation scheme. Note that we carry around the @L@ list
103 already desugared. @dsListComp@ does the top TE rule mentioned above.
107 deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
109 deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
110 = dsExpr expr `thenDs` \ core_expr ->
111 returnDs (mkConsExpr (exprType core_expr) core_expr list)
113 deListComp (GuardStmt guard locn : quals) list -- rule B above
114 = dsExpr guard `thenDs` \ core_guard ->
115 deListComp quals list `thenDs` \ core_rest ->
116 returnDs (mkIfThenElse core_guard core_rest list)
118 -- [e | let B, qs] = let B in [e | qs]
119 deListComp (LetStmt binds : quals) list
120 = deListComp quals list `thenDs` \ core_rest ->
121 dsLet binds core_rest
123 deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
124 = dsExpr list1 `thenDs` \ core_list1 ->
126 u3_ty@u1_ty = exprType core_list1 -- two names, same thing
128 -- u1_ty is a [alpha] type, and u2_ty = alpha
129 u2_ty = outPatType pat
131 res_ty = exprType core_list2
132 h_ty = u1_ty `mkFunTy` res_ty
134 newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
136 -- the "fail" value ...
138 core_fail = App (Var h) (Var u3)
139 letrec_body = App (Var h) core_list1
141 deListComp quals core_fail `thenDs` \ rest_expr ->
142 matchSimply (Var u2) ListCompMatch pat
143 rest_expr core_fail `thenDs` \ core_match ->
146 Case (Var u1) u1 [(DataAlt nilDataCon, [], core_list2),
147 (DataAlt consDataCon, [u2, u3], core_match)]
149 returnDs (Let (Rec [(h, rhs)]) letrec_body)
153 %************************************************************************
155 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
157 %************************************************************************
159 @dfListComp@ are the rules used with foldr/build turned on:
162 TE[ e | ] c n = c e n
163 TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
164 TE[ e | p <- l , q ] c n = let
165 f = \ x b -> case x of
173 dfListComp :: Id -> Id -- 'c' and 'n'
174 -> [TypecheckedStmt] -- the rest of the qual's
177 dfListComp c_id n_id [ReturnStmt expr]
178 = dsExpr expr `thenDs` \ core_expr ->
179 returnDs (mkApps (Var c_id) [core_expr, Var n_id])
181 dfListComp c_id n_id (GuardStmt guard locn : quals)
182 = dsExpr guard `thenDs` \ core_guard ->
183 dfListComp c_id n_id quals `thenDs` \ core_rest ->
184 returnDs (mkIfThenElse core_guard core_rest (Var n_id))
186 dfListComp c_id n_id (LetStmt binds : quals)
187 -- new in 1.3, local bindings
188 = dfListComp c_id n_id quals `thenDs` \ core_rest ->
189 dsLet binds core_rest
191 dfListComp c_id n_id (BindStmt pat list1 locn : quals)
192 -- evaluate the two lists
193 = dsExpr list1 `thenDs` \ core_list1 ->
195 -- find the required type
196 let x_ty = outPatType pat
200 -- create some new local id's
201 newSysLocalsDs [b_ty,x_ty] `thenDs` \ [b,x] ->
203 -- build rest of the comprehesion
204 dfListComp c_id b quals `thenDs` \ core_rest ->
206 -- build the pattern match
207 matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
209 -- now build the outermost foldr, and return
210 dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id ->
212 Var foldr_id `App` Type x_ty
214 `App` mkLams [x, b] core_expr