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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  13 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  14 #else
  15 import {-# SOURCE #-} DsExpr ( dsExpr )
  16 import {-# SOURCE #-} DsBinds ( dsBinds )
  17 #endif
  18
  19 import HsSyn            ( Stmt(..), HsExpr, HsBinds )
  20 import TcHsSyn          ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) )
  21 import DsHsSyn          ( outPatType )
  22 import CoreSyn
  23
  24 import DsMonad          -- the monadery used in the desugarer
  25 import DsUtils
  26
  27 import CmdLineOpts      ( opt_FoldrBuildOn )
  28 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  29 import Id               ( SYN_IE(Id) )
  30 import PrelVals         ( mkBuild, foldrId )
  31 import Type             ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, SYN_IE(Type) )
  32 import TysPrim          ( alphaTy )
  33 import TysWiredIn       ( nilDataCon, consDataCon, listTyCon )
  34 import TyVar            ( alphaTyVar )
  35 import Match            ( matchSimply )
  36 import Util             ( panic )
  37 \end{code}
  38
  39 List comprehensions may be desugared in one of two ways: ``ordinary''
  40 (as you would expect if you read SLPJ's book) and ``with foldr/build
  41 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
  42
  43 There will be at least one ``qualifier'' in the input.
  44
  45 \begin{code}
  46 dsListComp :: [TypecheckedStmt]
  47            -> Type              -- Type of list elements
  48            -> DsM CoreExpr
  49
  50 dsListComp quals elt_ty
  51   | not opt_FoldrBuildOn                 -- Be boring
  52   = deListComp quals nil_expr
  53
  54   | otherwise                            -- foldr/build lives!
  55   = newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
  56     let
  57         alpha_to_alpha = alphaTy `mkFunTy` alphaTy
  58
  59         n_ty = mkTyVarTy n_tyvar
  60         c_ty = mkFunTys [elt_ty, n_ty] n_ty
  61         g_ty = mkForAllTy alphaTyVar (
  62                 (elt_ty `mkFunTy` alpha_to_alpha)
  63                 `mkFunTy`
  64                 alpha_to_alpha
  65            )
  66     in
  67     newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
  68
  69     dfListComp  c_ty c
  70                 n_ty n
  71                 quals       `thenDs` \ result ->
  72
  73     returnDs (mkBuild elt_ty n_tyvar c n g result)
  74   where
  75     nil_expr    = mkCon nilDataCon [] [elt_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 :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
 123
 124 deListComp [ReturnStmt expr] list               -- Figure 7.4, SLPJ, p 135, rule C above
 125   = dsExpr expr                 `thenDs` \ core_expr ->
 126     mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list]
 127
 128 deListComp (GuardStmt guard locn : quals) list  -- rule B above
 129   = dsExpr guard                `thenDs` \ core_guard ->
 130     deListComp quals list       `thenDs` \ core_rest ->
 131     returnDs (mkCoreIfThenElse core_guard core_rest list)
 132
 133 -- [e | let B, qs] = let B in [e | qs]
 134 deListComp (LetStmt binds : quals) list
 135   = dsBinds False{-don't auto scc-} binds       `thenDs` \ core_binds ->
 136     deListComp quals list                       `thenDs` \ core_rest ->
 137     returnDs (mkCoLetsAny core_binds core_rest)
 138
 139 deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
 140   = dsExpr list1                    `thenDs` \ core_list1 ->
 141     let
 142         u3_ty@u1_ty = coreExprType core_list1   -- two names, same thing
 143
 144         -- u1_ty is a [alpha] type, and u2_ty = alpha
 145         u2_ty = outPatType pat
 146
 147         res_ty = coreExprType core_list2
 148         h_ty   = u1_ty `mkFunTy` res_ty
 149     in
 150     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]  `thenDs` \ [h, u1, u2, u3] ->
 151
 152     -- the "fail" value ...
 153     mkAppDs (Var h) [VarArg (Var u3)]           `thenDs` \ core_fail ->
 154     deListComp quals core_fail                  `thenDs` \ rest_expr ->
 155     matchSimply (Var u2) ListCompMatch pat res_ty
 156                 rest_expr core_fail             `thenDs` \ core_match ->
 157     mkAppDs (Var h) [VarArg core_list1]         `thenDs` \ letrec_body ->
 158
 159     returnDs (
 160       mkCoLetrecAny [
 161       ( h,
 162         (Lam (ValBinder u1)
 163          (Case (Var u1)
 164             (AlgAlts
 165               [(nilDataCon,  [],        core_list2),
 166                (consDataCon, [u2, u3],  core_match)]
 167             NoDefault)))
 168       )] letrec_body
 169     )
 170 \end{code}
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 @dfListComp@ are the rules used with foldr/build turned on:
 179 \begin{verbatim}
 180 TE < [ e | ] >>          c n = c e n
 181 TE << [ e | b , q ] >>   c n = if b then TE << [ e | q ] >> c n else n
 182 TE << [ e | p <- l , q ] c n =  foldr
 183                         (\ TE << p >> b -> TE << [ e | q ] >> c b
 184                            _          b  -> b)  n l
 185 \end{verbatim}
 186 \begin{code}
 187 dfListComp :: Type -> Id                -- 'c'; its type and id
 188            -> Type -> Id                -- 'n'; its type and id
 189            -> [TypecheckedStmt]         -- the rest of the qual's
 190            -> DsM CoreExpr
 191
 192 dfListComp c_ty c_id n_ty n_id [ReturnStmt expr]
 193   = dsExpr expr                 `thenDs` \ core_expr ->
 194     mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)]
 195
 196 dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn  : quals)
 197   = dsExpr guard                                `thenDs` \ core_guard ->
 198     dfListComp c_ty c_id n_ty n_id quals        `thenDs` \ core_rest ->
 199     returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id))
 200
 201 dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
 202   -- new in 1.3, local bindings
 203   = dsBinds False{-don't auto scc-} binds        `thenDs` \ core_binds ->
 204     dfListComp c_ty c_id n_ty n_id quals         `thenDs` \ core_rest ->
 205     returnDs (mkCoLetsAny core_binds core_rest)
 206
 207 dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
 208     -- evaluate the two lists
 209   = dsExpr list1                                `thenDs` \ core_list1 ->
 210
 211     -- find the required type
 212
 213     let p_ty   = outPatType pat
 214         b_ty   = n_ty           -- alias b_ty to n_ty
 215         fn_ty  = mkFunTys [p_ty, b_ty] b_ty
 216         lst_ty = coreExprType core_list1
 217     in
 218
 219     -- create some new local id's
 220
 221     newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty]             `thenDs` \ [b,p,fn,lst] ->
 222
 223     -- build rest of the comprehesion
 224
 225     dfListComp c_ty c_id b_ty b quals                   `thenDs` \ core_rest ->
 226     -- build the pattern match
 227
 228     matchSimply (Var p) ListCompMatch pat b_ty core_rest (Var b)        `thenDs` \ core_expr ->
 229
 230     -- now build the outermost foldr, and return
 231
 232     returnDs (
 233       mkCoLetsAny
 234         [NonRec fn (mkValLam [p, b] core_expr),
 235          NonRec lst core_list1]
 236         (mkFoldr p_ty n_ty fn n_id lst)
 237     )
 238
 239 mkFoldr a b f z xs
 240   = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
 241 \end{code}