ghc/compiler/deSugar/DsListComp.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsListComp]{Desugaring list comprehensions}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module DsListComp ( dsListComp ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  13
  14 import HsSyn            ( Qualifier(..), HsExpr, HsBinds )
  15 import TcHsSyn          ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) )
  16 import DsHsSyn          ( outPatType )
  17 import CoreSyn
  18
  19 import DsMonad          -- the monadery used in the desugarer
  20 import DsUtils
  21
  22 import CmdLineOpts      ( opt_FoldrBuildOn )
  23 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  24 import PrelVals         ( mkBuild, foldrId )
  25 import Type             ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy )
  26 import TysPrim          ( alphaTy )
  27 import TysWiredIn       ( nilDataCon, consDataCon, listTyCon )
  28 import TyVar            ( alphaTyVar )
  29 import Match            ( matchSimply )
  30 import Util             ( panic )
  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 :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
  41
  42 dsListComp expr quals
  43   = let
  44         expr_ty = coreExprType expr
  45     in
  46     if not opt_FoldrBuildOn then -- be boring
  47         deListComp expr quals (nIL_EXPR expr_ty)
  48
  49     else -- foldr/build lives!
  50         new_alpha_tyvar             `thenDs` \ (n_tyvar, n_ty) ->
  51         let
  52             alpha_to_alpha = alphaTy `mkFunTy` alphaTy
  53
  54             c_ty = mkFunTys [expr_ty, n_ty] n_ty
  55             g_ty = mkForAllTy alphaTyVar (
  56                         (expr_ty `mkFunTy` alpha_to_alpha)
  57                         `mkFunTy`
  58                         alpha_to_alpha
  59                    )
  60         in
  61         newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
  62
  63         dfListComp expr expr_ty
  64                         c_ty c
  65                         n_ty n
  66                         quals       `thenDs` \ result ->
  67
  68         returnDs (mkBuild expr_ty n_tyvar c n g result)
  69   where
  70     nIL_EXPR ty = mkCon nilDataCon [] [ty] []
  71
  72     new_alpha_tyvar :: DsM (TyVar, Type)
  73     new_alpha_tyvar
  74       = newTyVarsDs [alphaTyVar]    `thenDs` \ [new_ty] ->
  75         returnDs (new_ty, mkTyVarTy new_ty)
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 Just as in Phil's chapter~7 in SLPJ, using the rules for
  85 optimally-compiled list comprehensions.  This is what Kevin followed
  86 as well, and I quite happily do the same.  The TQ translation scheme
  87 transforms a list of qualifiers (either boolean expressions or
  88 generators) into a single expression which implements the list
  89 comprehension.  Because we are generating 2nd-order polymorphic
  90 lambda-calculus, calls to NIL and CONS must be applied to a type
  91 argument, as well as their usual value arguments.
  92 \begin{verbatim}
  93 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
  94
  95 (Rule C)
  96 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
  97
  98 (Rule B)
  99 TQ << [ e | b , qs ] ++ L >> =
 100     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
 101
 102 (Rule A')
 103 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
 104   letrec
 105     h = \ u1 ->
 106           case u1 of
 107             []        ->  TE << L2 >>
 108             (u2 : u3) ->
 109                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
 110                     [] (h u3)
 111   in
 112     h ( TE << L1 >> )
 113
 114 "h", "u1", "u2", and "u3" are new variables.
 115 \end{verbatim}
 116
 117 @deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
 118 is the TE translation scheme.  Note that we carry around the @L@ list
 119 already desugared.  @dsListComp@ does the top TE rule mentioned above.
 120
 121 \begin{code}
 122 deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
 123
 124 deListComp expr [] list         -- Figure 7.4, SLPJ, p 135, rule C above
 125   = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list]
 126
 127 deListComp expr (FilterQual filt : quals) list  -- rule B above
 128   = dsExpr filt                `thenDs` \ core_filt ->
 129     deListComp expr quals list `thenDs` \ core_rest ->
 130     returnDs ( mkCoreIfThenElse core_filt core_rest list )
 131
 132 -- [e | let B, qs] = let B in [e | qs]
 133 deListComp expr (LetQual binds : quals) list
 134   = dsBinds False binds         `thenDs` \ core_binds ->
 135     deListComp expr quals list  `thenDs` \ core_rest ->
 136     returnDs (mkCoLetsAny core_binds core_rest)
 137
 138 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
 139   = dsExpr list1                    `thenDs` \ core_list1 ->
 140     let
 141         u3_ty@u1_ty = coreExprType core_list1   -- two names, same thing
 142
 143         -- u1_ty is a [alpha] type, and u2_ty = alpha
 144         u2_ty = outPatType pat
 145
 146         res_ty = coreExprType core_list2
 147         h_ty   = u1_ty `mkFunTy` res_ty
 148     in
 149     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 150                                     `thenDs` \ [h', u1, u2, u3] ->
 151     {-
 152        Make the function h unfoldable by the deforester.
 153        Since it only occurs once in the body, we can't get
 154        an increase in code size by unfolding it.
 155     -}
 156     let
 157         h = if False -- LATER: sw_chkr DoDeforest???
 158             then panic "deListComp:deforest"
 159                  -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
 160             else h'
 161     in
 162     -- the "fail" value ...
 163     mkAppDs (Var h) [VarArg (Var u3)]  `thenDs` \ core_fail ->
 164
 165     deListComp expr quals core_fail `thenDs` \ rest_expr ->
 166
 167     matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
 168
 169     mkAppDs (Var h) [VarArg core_list1]  `thenDs` \ letrec_body ->
 170
 171     returnDs (
 172       mkCoLetrecAny [
 173       ( h,
 174         (Lam (ValBinder u1)
 175          (Case (Var u1)
 176             (AlgAlts
 177               [(nilDataCon,  [], core_list2),
 178                (consDataCon, [u2, u3], core_match)]
 179             NoDefault)))
 180       )] letrec_body
 181     )
 182 \end{code}
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 @dfListComp@ are the rules used with foldr/build turned on:
 191 \begin{verbatim}
 192 TE < [ e | ] >>          c n = c e n
 193 TE << [ e | b , q ] >>   c n = if b then TE << [ e | q ] >> c n else n
 194 TE << [ e | p <- l , q ] c n =  foldr
 195                         (\ TE << p >> b -> TE << [ e | q ] >> c b
 196                            _          b  -> b)  n l
 197 \end{verbatim}
 198 \begin{code}
 199 dfListComp :: CoreExpr          -- the inside of the comp
 200            -> Type                      -- the type of the inside
 201            -> Type -> Id                -- 'c'; its type and id
 202            -> Type -> Id                -- 'n'; its type and id
 203            -> [TypecheckedQual]         -- the rest of the qual's
 204            -> DsM CoreExpr
 205
 206 dfListComp expr expr_ty c_ty c_id n_ty n_id []
 207   = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)]
 208
 209 dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
 210   = dsExpr filt                                 `thenDs` \ core_filt ->
 211     dfListComp expr expr_ty c_ty c_id n_ty n_id quals
 212                                                 `thenDs` \ core_rest ->
 213     returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
 214
 215 dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
 216   -- new in 1.3, local bindings
 217   = dsBinds False binds                               `thenDs` \ core_binds ->
 218     dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
 219     returnDs ( mkCoLetsAny core_binds core_rest )
 220
 221 dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
 222     -- evaluate the two lists
 223   = dsExpr list1                                `thenDs` \ core_list1 ->
 224
 225     -- find the required type
 226
 227     let p_ty   = outPatType pat
 228         b_ty   = n_ty           -- alias b_ty to n_ty
 229         fn_ty  = mkFunTys [p_ty, b_ty] b_ty
 230         lst_ty = coreExprType core_list1
 231     in
 232
 233     -- create some new local id's
 234
 235     newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty]             `thenDs` \ [b,p,fn,lst] ->
 236
 237     -- build rest of the comprehesion
 238
 239     dfListComp expr expr_ty c_ty c_id b_ty b quals      `thenDs` \ core_rest ->
 240     -- build the pattern match
 241
 242     matchSimply (Var p) pat b_ty core_rest (Var b)      `thenDs` \ core_expr ->
 243
 244     -- now build the outermost foldr, and return
 245
 246     returnDs (
 247       mkCoLetsAny
 248         [NonRec fn (mkValLam [p, b] core_expr),
 249          NonRec lst core_list1]
 250         (mkFoldr p_ty n_ty fn n_id lst)
 251     )
 252
 253 mkFoldr a b f z xs
 254   = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
 255 \end{code}