[project @ 2000-06-09 23:28:34 by lewie]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsListComp.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[DsListComp]{Desugaring list comprehensions}
5
6 \begin{code}
7 module DsListComp ( dsListComp ) where
8
9 #include "HsVersions.h"
10
11 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
12
13 import HsSyn            ( Stmt(..), HsExpr )
14 import TcHsSyn          ( TypecheckedStmt, TypecheckedHsExpr )
15 import DsHsSyn          ( outPatType )
16 import CoreSyn
17
18 import DsMonad          -- the monadery used in the desugarer
19 import DsUtils
20
21 import CmdLineOpts      ( opt_FoldrBuildOn )
22 import CoreUtils        ( exprType, mkIfThenElse )
23 import Id               ( idType )
24 import Var              ( Id, TyVar )
25 import Type             ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
26 import TysPrim          ( alphaTyVar, alphaTy )
27 import TysWiredIn       ( nilDataCon, consDataCon, listTyCon )
28 import Match            ( matchSimply )
29 import Unique           ( foldrIdKey, buildIdKey )
30 import Outputable
31 \end{code}
32
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).
36
37 There will be at least one ``qualifier'' in the input.
38
39 \begin{code}
40 dsListComp :: [TypecheckedStmt] 
41            -> Type              -- Type of list elements
42            -> DsM CoreExpr
43
44 dsListComp quals elt_ty
45   | not opt_FoldrBuildOn                 -- Be boring
46   = deListComp quals (mkNilExpr elt_ty)
47
48   | otherwise                            -- foldr/build lives!
49   = newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
50     let
51         n_ty = mkTyVarTy n_tyvar
52         c_ty = mkFunTys [elt_ty, n_ty] n_ty
53     in
54     newSysLocalsDs [c_ty,n_ty]          `thenDs` \ [c, n] ->
55
56     dfListComp c n quals                `thenDs` \ result ->
57
58     dsLookupGlobalValue buildIdKey      `thenDs` \ build_id ->
59     returnDs (Var build_id `App` Type elt_ty 
60                            `App` mkLams [n_tyvar, c, n] result)
61 \end{code}
62
63 %************************************************************************
64 %*                                                                      *
65 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
66 %*                                                                      *
67 %************************************************************************
68
69 Just as in Phil's chapter~7 in SLPJ, using the rules for
70 optimally-compiled list comprehensions.  This is what Kevin followed
71 as well, and I quite happily do the same.  The TQ translation scheme
72 transforms a list of qualifiers (either boolean expressions or
73 generators) into a single expression which implements the list
74 comprehension.  Because we are generating 2nd-order polymorphic
75 lambda-calculus, calls to NIL and CONS must be applied to a type
76 argument, as well as their usual value arguments.
77 \begin{verbatim}
78 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
79
80 (Rule C)
81 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
82
83 (Rule B)
84 TQ << [ e | b , qs ] ++ L >> =
85     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
86
87 (Rule A')
88 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
89   letrec
90     h = \ u1 ->
91           case u1 of
92             []        ->  TE << L2 >>
93             (u2 : u3) ->
94                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
95                     [] (h u3)
96   in
97     h ( TE << L1 >> )
98
99 "h", "u1", "u2", and "u3" are new variables.
100 \end{verbatim}
101
102 @deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
103 is the TE translation scheme.  Note that we carry around the @L@ list
104 already desugared.  @dsListComp@ does the top TE rule mentioned above.
105
106
107 \begin{code}
108 deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
109
110 deListComp [ReturnStmt expr] list       -- Figure 7.4, SLPJ, p 135, rule C above
111   = dsExpr expr                 `thenDs` \ core_expr ->
112     returnDs (mkConsExpr (exprType core_expr) core_expr list)
113
114 deListComp (GuardStmt guard locn : quals) list  -- rule B above
115   = dsExpr guard                `thenDs` \ core_guard ->
116     deListComp quals list       `thenDs` \ core_rest ->
117     returnDs (mkIfThenElse core_guard core_rest list)
118
119 -- [e | let B, qs] = let B in [e | qs]
120 deListComp (LetStmt binds : quals) list
121   = deListComp quals list       `thenDs` \ core_rest ->
122     dsLet binds core_rest
123
124 deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
125   = dsExpr list1                    `thenDs` \ core_list1 ->
126     let
127         u3_ty@u1_ty = exprType core_list1       -- two names, same thing
128
129         -- u1_ty is a [alpha] type, and u2_ty = alpha
130         u2_ty = outPatType pat
131
132         res_ty = exprType core_list2
133         h_ty   = u1_ty `mkFunTy` res_ty
134     in
135     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]  `thenDs` \ [h, u1, u2, u3] ->
136
137     -- the "fail" value ...
138     let
139         core_fail   = App (Var h) (Var u3)
140         letrec_body = App (Var h) core_list1
141     in
142     deListComp quals core_fail                  `thenDs` \ rest_expr ->
143     matchSimply (Var u2) ListCompMatch pat
144                 rest_expr core_fail             `thenDs` \ core_match ->
145     let
146         rhs = Lam u1 $
147               Case (Var u1) u1 [(DataAlt nilDataCon,  [],       core_list2),
148                                 (DataAlt consDataCon, [u2, u3], core_match)]
149     in
150     returnDs (Let (Rec [(h, rhs)]) letrec_body)
151 \end{code}
152
153
154 %************************************************************************
155 %*                                                                      *
156 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
157 %*                                                                      *
158 %************************************************************************
159
160 @dfListComp@ are the rules used with foldr/build turned on:
161
162 \begin{verbatim}
163 TE[ e | ]            c n = c e n
164 TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
165 TE[ e | p <- l , q ] c n = let 
166                                 f = \ x b -> case x of
167                                                   p -> TE[ e | q ] c b
168                                                   _ -> b
169                            in
170                            foldr f n l
171 \end{verbatim}
172
173 \begin{code}
174 dfListComp :: Id -> Id                  -- 'c' and 'n'
175            -> [TypecheckedStmt]         -- the rest of the qual's
176            -> DsM CoreExpr
177
178 dfListComp c_id n_id [ReturnStmt expr]
179   = dsExpr expr                 `thenDs` \ core_expr ->
180     returnDs (mkApps (Var c_id) [core_expr, Var n_id])
181
182 dfListComp c_id n_id (GuardStmt guard locn  : quals)
183   = dsExpr guard                                `thenDs` \ core_guard ->
184     dfListComp c_id n_id quals  `thenDs` \ core_rest ->
185     returnDs (mkIfThenElse core_guard core_rest (Var n_id))
186
187 dfListComp c_id n_id (LetStmt binds : quals)
188   -- new in 1.3, local bindings
189   = dfListComp c_id n_id quals  `thenDs` \ core_rest ->
190     dsLet binds core_rest
191
192 dfListComp c_id n_id (BindStmt pat list1 locn : quals)
193     -- evaluate the two lists
194   = dsExpr list1                                `thenDs` \ core_list1 ->
195
196     -- find the required type
197     let x_ty   = outPatType pat
198         b_ty   = idType n_id
199     in
200
201     -- create some new local id's
202     newSysLocalsDs [b_ty,x_ty]                  `thenDs` \ [b,x] ->
203
204     -- build rest of the comprehesion
205     dfListComp c_id b quals                     `thenDs` \ core_rest ->
206
207     -- build the pattern match
208     matchSimply (Var x) ListCompMatch pat core_rest (Var b)     `thenDs` \ core_expr ->
209
210     -- now build the outermost foldr, and return
211     dsLookupGlobalValue foldrIdKey              `thenDs` \ foldr_id ->
212     returnDs (
213       Var foldr_id `App` Type x_ty 
214                    `App` Type b_ty
215                    `App` mkLams [x, b] core_expr
216                    `App` Var n_id
217                    `App` core_list1
218     )
219 \end{code}
220
221