ghc/compiler/deSugar/DsListComp.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[DsListComp]{Desugaring list comprehensions}
   5
   6 \begin{code}
   7 module DsListComp ( dsListComp ) where
   8
   9
  10 import AbsSyn           -- the stuff being desugared
  11 import PlainCore        -- the output of desugaring;
  12                         -- importing this module also gets all the
  13                         -- CoreSyn utility functions
  14 import DsMonad          -- the monadery used in the desugarer
  15
  16 import AbsPrel          ( mkFunTy, nilDataCon, consDataCon, listTyCon,
  17                           mkBuild, mkFoldr
  18                         )
  19 import AbsUniType       ( alpha_tv, alpha, mkTyVarTy, mkForallTy )
  20 import CmdLineOpts      ( GlobalSwitch(..) )
  21 import DsExpr           ( dsExpr )
  22 import DsUtils
  23 import Id               ( getIdInfo, replaceIdInfo )
  24 import IdInfo
  25 import Match            ( matchSimply )
  26 import Util
  27 \end{code}
  28
  29 List comprehensions may be desugared in one of two ways: ``ordinary''
  30 (as you would expect if you read SLPJ's book) and ``with foldr/build
  31 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
  32
  33 There will be at least one ``qualifier'' in the input.
  34
  35 \begin{code}
  36 dsListComp :: PlainCoreExpr -> [TypecheckedQual] -> DsM PlainCoreExpr
  37
  38 dsListComp expr quals
  39   = let  expr_ty    = typeOfCoreExpr expr
  40     in
  41     ifSwitchSetDs FoldrBuildOn (
  42         new_alpha_tyvar             `thenDs` \ (n_tyvar, n_ty) ->
  43         let
  44             c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
  45             g_ty = mkForallTy [alpha_tv] (
  46                         (expr_ty `mkFunTy` (alpha `mkFunTy` alpha))
  47                                  `mkFunTy` (alpha `mkFunTy` alpha))
  48         in
  49         newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
  50
  51         dfListComp expr expr_ty
  52                         c_ty c
  53                         n_ty n
  54                         quals       `thenDs` \ result ->
  55
  56         returnDs (mkBuild expr_ty n_tyvar c n g result)
  57
  58     ) {-else be boring-} (
  59         deListComp expr quals (nIL_EXPR expr_ty)
  60     )
  61   where
  62     nIL_EXPR ty = CoCon nilDataCon [ty] []
  63
  64     new_alpha_tyvar :: DsM (TyVar, UniType)
  65     new_alpha_tyvar
  66       = newTyVarsDs [alpha_tv]  `thenDs` \ [new_ty] ->
  67         returnDs (new_ty,mkTyVarTy new_ty)
  68 \end{code}
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 Just as in Phil's chapter~7 in SLPJ, using the rules for
  77 optimally-compiled list comprehensions.  This is what Kevin followed
  78 as well, and I quite happily do the same.  The TQ translation scheme
  79 transforms a list of qualifiers (either boolean expressions or
  80 generators) into a single expression which implements the list
  81 comprehension.  Because we are generating 2nd-order polymorphic
  82 lambda-calculus, calls to NIL and CONS must be applied to a type
  83 argument, as well as their usual value arguments.
  84 \begin{verbatim}
  85 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
  86
  87 (Rule C)
  88 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
  89
  90 (Rule B)
  91 TQ << [ e | b , qs ] ++ L >> =
  92     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
  93
  94 (Rule A')
  95 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
  96   letrec
  97     h = \ u1 ->
  98           case u1 of
  99             []        ->  TE << L2 >>
 100             (u2 : u3) ->
 101                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
 102                     [] (h u3)
 103   in
 104     h ( TE << L1 >> )
 105
 106 "h", "u1", "u2", and "u3" are new variables.
 107 \end{verbatim}
 108
 109 @deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
 110 is the TE translation scheme.  Note that we carry around the @L@ list
 111 already desugared.  @dsListComp@ does the top TE rule mentioned above.
 112
 113 \begin{code}
 114 deListComp :: PlainCoreExpr -> [TypecheckedQual] -> PlainCoreExpr -> DsM PlainCoreExpr
 115
 116 deListComp expr [] list         -- Figure 7.4, SLPJ, p 135, rule C above
 117   = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list]
 118
 119 deListComp expr ((FilterQual filt): quals) list -- rule B above
 120   = dsExpr filt                `thenDs` \ core_filt ->
 121     deListComp expr quals list `thenDs` \ core_rest ->
 122     returnDs ( mkCoreIfThenElse core_filt core_rest list )
 123
 124 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
 125   = dsExpr list1                    `thenDs` \ core_list1 ->
 126     let
 127         u3_ty@u1_ty = typeOfCoreExpr core_list1 -- two names, same thing
 128
 129         -- u1_ty is a [alpha] type, and u2_ty = alpha
 130         u2_ty = typeOfPat pat
 131
 132         res_ty = typeOfCoreExpr core_list2
 133         h_ty = mkFunTy u1_ty res_ty
 134     in
 135     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 136                                     `thenDs` \ [h', u1, u2, u3] ->
 137     {-
 138        Make the function h unfoldable by the deforester.
 139        Since it only occurs once in the body, we can't get
 140        an increase in code size by unfolding it.
 141     -}
 142 --  getSwitchCheckerDs              `thenDs` \ sw_chkr ->
 143     let
 144         h = if False -- LATER: sw_chkr DoDeforest???
 145             then replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
 146             else h'
 147     in
 148     -- the "fail" value ...
 149     mkCoAppDs (CoVar h) (CoVar u3)  `thenDs` \ core_fail ->
 150
 151     deListComp expr quals core_fail `thenDs` \ rest_expr ->
 152
 153     matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
 154
 155     mkCoAppDs (CoVar h) core_list1  `thenDs` \ letrec_body ->
 156
 157     returnDs (
 158       mkCoLetrecAny [
 159       ( h,
 160         (CoLam [ u1 ]
 161          (CoCase (CoVar u1)
 162             (CoAlgAlts
 163               [(nilDataCon,  [], core_list2),
 164                (consDataCon, [u2, u3], core_match)]
 165             CoNoDefault)))
 166       )] letrec_body
 167     )
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 @dfListComp@ are the rules used with foldr/build turned on:
 177 \begin{verbatim}
 178 TE < [ e | ] >>          c n = c e n
 179 TE << [ e | b , q ] >>   c n = if b then TE << [ e | q ] >> c n else n
 180 TE << [ e | p <- l , q ] c n =  foldr
 181                         (\ TE << p >> b -> TE << [ e | q ] >> c b
 182                            _          b  -> b)  n l
 183 \end{verbatim}
 184 \begin{code}
 185 dfListComp :: PlainCoreExpr             -- the inside of the comp
 186            -> UniType                   -- the type of the inside
 187            -> UniType -> Id             -- 'c'; its type and id
 188            -> UniType -> Id             -- 'n'; its type and id
 189            -> [TypecheckedQual]         -- the rest of the qual's
 190            -> DsM PlainCoreExpr
 191
 192 dfListComp expr expr_ty c_ty c_id n_ty n_id []
 193   = mkCoAppDs (CoVar c_id) expr   `thenDs` \ inner ->
 194     mkCoAppDs inner (CoVar n_id)
 195
 196 dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals)
 197   = dsExpr filt                                 `thenDs` \ core_filt ->
 198     dfListComp expr expr_ty c_ty c_id n_ty n_id quals
 199                                                 `thenDs` \ core_rest ->
 200     returnDs (mkCoreIfThenElse core_filt core_rest (CoVar n_id))
 201
 202 dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
 203     -- evaluate the two lists
 204   = dsExpr list1                                `thenDs` \ core_list1 ->
 205
 206     -- find the required type
 207
 208     let p_ty = typeOfPat pat
 209         b_ty = n_ty             -- alias b_ty to n_ty
 210         fn_ty = p_ty `mkFunTy` (b_ty `mkFunTy` b_ty)
 211         lst_ty = typeOfCoreExpr core_list1
 212     in
 213
 214     -- create some new local id's
 215
 216     newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty]             `thenDs` \ [b,p,fn,lst] ->
 217
 218     -- build rest of the comprehesion
 219
 220     dfListComp expr expr_ty c_ty c_id b_ty b quals      `thenDs` \ core_rest ->
 221     -- build the pattern match
 222
 223     matchSimply (CoVar p) pat b_ty core_rest (CoVar b)  `thenDs` \ core_expr ->
 224
 225     -- now build the outermost foldr, and return
 226
 227     returnDs (
 228       mkCoLetsAny
 229         [CoNonRec fn (CoLam [p,b] core_expr),
 230          CoNonRec lst core_list1]
 231         (mkFoldr p_ty n_ty fn n_id lst)
 232     )
 233 \end{code}
 234