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(..) )
  14 import TcHsSyn          ( TypecheckedStmt )
  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 )
  25 import Type             ( mkTyVarTy, mkFunTys, mkFunTy, Type )
  26 import TysPrim          ( alphaTyVar )
  27 import TysWiredIn       ( nilDataCon, consDataCon )
  28 import Match            ( matchSimply )
  29 import PrelNames        ( foldrName, buildName )
  30 \end{code}
  31
  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).
  35
  36 There will be at least one ``qualifier'' in the input.
  37
  38 \begin{code}
  39 dsListComp :: [TypecheckedStmt]
  40            -> Type              -- Type of list elements
  41            -> DsM CoreExpr
  42
  43 dsListComp quals elt_ty
  44   | not opt_FoldrBuildOn                 -- Be boring
  45   = deListComp quals (mkNilExpr elt_ty)
  46
  47   | otherwise                            -- foldr/build lives!
  48   = newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
  49     let
  50         n_ty = mkTyVarTy n_tyvar
  51         c_ty = mkFunTys [elt_ty, n_ty] n_ty
  52     in
  53     newSysLocalsDs [c_ty,n_ty]          `thenDs` \ [c, n] ->
  54
  55     dfListComp c n quals                `thenDs` \ result ->
  56
  57     dsLookupGlobalValue buildName       `thenDs` \ build_id ->
  58     returnDs (Var build_id `App` Type elt_ty
  59                            `App` mkLams [n_tyvar, c, n] result)
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
  65 %*                                                                      *
  66 %************************************************************************
  67
  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.
  76 \begin{verbatim}
  77 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
  78
  79 (Rule C)
  80 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
  81
  82 (Rule B)
  83 TQ << [ e | b , qs ] ++ L >> =
  84     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
  85
  86 (Rule A')
  87 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
  88   letrec
  89     h = \ u1 ->
  90           case u1 of
  91             []        ->  TE << L2 >>
  92             (u2 : u3) ->
  93                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
  94                     [] (h u3)
  95   in
  96     h ( TE << L1 >> )
  97
  98 "h", "u1", "u2", and "u3" are new variables.
  99 \end{verbatim}
 100
 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.
 104
 105
 106 \begin{code}
 107 deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
 108
 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)
 112
 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)
 117
 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
 122
 123 deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
 124   = dsExpr list1                    `thenDs` \ core_list1 ->
 125     let
 126         u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 127
 128         -- u1_ty is a [alpha] type, and u2_ty = alpha
 129         u2_ty = outPatType pat
 130
 131         res_ty = exprType core_list2
 132         h_ty   = u1_ty `mkFunTy` res_ty
 133     in
 134     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]  `thenDs` \ [h, u1, u2, u3] ->
 135
 136     -- the "fail" value ...
 137     let
 138         core_fail   = App (Var h) (Var u3)
 139         letrec_body = App (Var h) core_list1
 140     in
 141     deListComp quals core_fail                  `thenDs` \ rest_expr ->
 142     matchSimply (Var u2) ListCompMatch pat
 143                 rest_expr core_fail             `thenDs` \ core_match ->
 144     let
 145         rhs = Lam u1 $
 146               Case (Var u1) u1 [(DataAlt nilDataCon,  [],       core_list2),
 147                                 (DataAlt consDataCon, [u2, u3], core_match)]
 148     in
 149     returnDs (Let (Rec [(h, rhs)]) letrec_body)
 150 \end{code}
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 @dfListComp@ are the rules used with foldr/build turned on:
 160
 161 \begin{verbatim}
 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
 166                                                   p -> TE[ e | q ] c b
 167                                                   _ -> b
 168                            in
 169                            foldr f n l
 170 \end{verbatim}
 171
 172 \begin{code}
 173 dfListComp :: Id -> Id                  -- 'c' and 'n'
 174            -> [TypecheckedStmt]         -- the rest of the qual's
 175            -> DsM CoreExpr
 176
 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])
 180
 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))
 185
 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
 190
 191 dfListComp c_id n_id (BindStmt pat list1 locn : quals)
 192     -- evaluate the two lists
 193   = dsExpr list1                                `thenDs` \ core_list1 ->
 194
 195     -- find the required type
 196     let x_ty   = outPatType pat
 197         b_ty   = idType n_id
 198     in
 199
 200     -- create some new local id's
 201     newSysLocalsDs [b_ty,x_ty]                  `thenDs` \ [b,x] ->
 202
 203     -- build rest of the comprehesion
 204     dfListComp c_id b quals                     `thenDs` \ core_rest ->
 205
 206     -- build the pattern match
 207     matchSimply (Var x) ListCompMatch pat core_rest (Var b)     `thenDs` \ core_expr ->
 208
 209     -- now build the outermost foldr, and return
 210     dsLookupGlobalValue foldrName               `thenDs` \ foldr_id ->
 211     returnDs (
 212       Var foldr_id `App` Type x_ty
 213                    `App` Type b_ty
 214                    `App` mkLams [x, b] core_expr
 215                    `App` Var n_id
 216                    `App` core_list1
 217     )
 218 \end{code}
 219
 220