%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsListComp]{Desugaring list comprehensions}
\begin{code}
-#include "HsVersions.h"
-
module DsListComp ( dsListComp ) where
-IMP_Ubiq()
-IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
-import HsSyn ( Qualifier(..), HsExpr, HsBinds )
-import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) )
+import HsSyn ( Stmt(..), HsExpr )
+import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr )
import DsHsSyn ( outPatType )
import CoreSyn
import DsUtils
import CmdLineOpts ( opt_FoldrBuildOn )
-import CoreUtils ( coreExprType, mkCoreIfThenElse )
-import PrelVals ( mkBuild, foldrId )
-import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy )
-import TysPrim ( alphaTy )
+import CoreUtils ( coreExprType )
+import Var ( Id, TyVar )
+import Const ( Con(..) )
+import PrelInfo ( foldrId )
+import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
+import TysPrim ( alphaTyVar, alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
-import TyVar ( alphaTyVar )
import Match ( matchSimply )
-import Util ( panic )
+import Outputable
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
There will be at least one ``qualifier'' in the input.
\begin{code}
-dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
+dsListComp :: [TypecheckedStmt]
+ -> Type -- Type of list elements
+ -> DsM CoreExpr
+
+dsListComp quals elt_ty
+ | not opt_FoldrBuildOn -- Be boring
+ = deListComp quals nil_expr
-dsListComp expr quals
- = let
- expr_ty = coreExprType expr
+ | otherwise -- foldr/build lives!
+ = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
+ let
+ alpha_to_alpha = alphaTy `mkFunTy` alphaTy
+
+ n_ty = mkTyVarTy n_tyvar
+ c_ty = mkFunTys [elt_ty, n_ty] n_ty
+ g_ty = mkForAllTy alphaTyVar (
+ (elt_ty `mkFunTy` alpha_to_alpha)
+ `mkFunTy`
+ alpha_to_alpha
+ )
in
- if not opt_FoldrBuildOn then -- be boring
- deListComp expr quals (nIL_EXPR expr_ty)
-
- else -- foldr/build lives!
- new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) ->
- let
- alpha_to_alpha = alphaTy `mkFunTy` alphaTy
-
- c_ty = mkFunTys [expr_ty, n_ty] n_ty
- g_ty = mkForAllTy alphaTyVar (
- (expr_ty `mkFunTy` alpha_to_alpha)
- `mkFunTy`
- alpha_to_alpha
- )
- in
- newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
-
- dfListComp expr expr_ty
- c_ty c
- n_ty n
- quals `thenDs` \ result ->
-
- returnDs (mkBuild expr_ty n_tyvar c n g result)
- where
- nIL_EXPR ty = mkCon nilDataCon [] [ty] []
+ newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
- new_alpha_tyvar :: DsM (TyVar, Type)
- new_alpha_tyvar
- = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] ->
- returnDs (new_ty, mkTyVarTy new_ty)
+ dfListComp c_ty c
+ n_ty n
+ quals `thenDs` \ result ->
+
+ returnDs (mkBuild elt_ty n_tyvar c n g result)
+ where
+ nil_expr = mkNilExpr elt_ty
\end{code}
%************************************************************************
is the TE translation scheme. Note that we carry around the @L@ list
already desugared. @dsListComp@ does the top TE rule mentioned above.
+deListComp :: [TypecheckedStmt]
+ -> CoreExpr -> CoreExpr -- Cons and nil resp; can be copied freely
+ -> DsM CoreExpr
+
+deListComp [ReturnStmt expr] cons nil
+ = dsExpr expr `thenDs` \ expr' ->
+ returnDs (mkApps cons [expr', nil])
+
+deListComp (GuardStmt guard locn : quals) cons nil
+ = dsExpr guard `thenDs` \ guard' ->
+ deListComp quals cons nil `thenDs` \ rest' ->
+ returnDs (mkIfThenElse guard' rest' nil)
+
+deListComp (LetStmt binds : quals) cons nil
+ = deListComp quals cons nil `thenDs` \ rest' ->
+ dsLet binds rest'
+
+deListComp (BindStmt pat list locn : quals) cons nil
+ = dsExpr list `thenDs` \ list' ->
+ let
+ pat_ty = outPatType pat
+ nil_ty = coreExprType nil
+ in
+ newSysLocalsDs [pat_ty, nil_ty] `thenDs` \ [x,ys] ->
+
+ dsListComp quals cons (Var ys) `thenDs` \ rest ->
+ matchSimply (Var x) ListCompMatch pat
+ rest (Var ys) `thenDs` \ core_match ->
+ bindNonRecDs (mkLams [x,ys] fn_body) $ \ fn ->
+ dsListExpr list (Var fn) nil
+
+
+data FExpr = FEOther CoreExpr -- Default case
+ | FECons -- cons
+ | FEConsComposedWith CoreExpr -- (cons . e)
+ | FENil -- nil
+
+feComposeWith FECons g
+ = returnDs (FEConsComposedWith g)
+
+feComposeWith (FEOther f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEOther h)
+
+feComposeWith (FEConsComposedWith f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEConsComposedWith h)
+
+
+composeWith f g
+ = newSysLocalDs arg_ty `thenDs` \ x ->
+ returnDs (Lam x (App e (App f (Var x))))
+ where
+ arg_ty = case splitFunTy_maybe (coreExprType g) of
+ Just (arg_ty,_) -> arg_ty
+ other -> panic "feComposeWith"
+
+deListExpr :: TypecheckedHsExpr
+ -> FExpr -> FExpr -- Cons and nil expressions
+ -> DsM CoreExpr
+
+deListExpr cons nil (HsDoOut ListComp stmts _ _ _ result_ty src_loc)
+ = deListComp stmts cons nil
+
+deListExpr cons nil (HsVar map, _, [f,xs])
+ | goodInst var mapIdKey = dsExpr f `thenDs` \ f' ->
+ feComposeWith cons f' `thenDs` \ cons' ->
+ in
+ deListExpr xs cons' nil
+
+
+data HsExprForm = GoodForm What [Type] [TypecheckedHsExpr]
+ | BadForm
+
+data What = HsMap | HsConcat | HsFilter | HsZip | HsFoldr
+
+analyseListProducer (HsVar v) ty_args val_args
+ | good_inst mapIdKey 2 = GoodForm HsMap ty_args val_args
+ | good_inst concatIdKey 1 = GoodForm HsConcat ty_args val_args
+ | good_inst filterIdKey 2 = GoodForm HsFilter ty_args val_args
+ | good_id zipIdKey 2 = GoodForm HsZip ty_args val_args
+ | otherwise =
+ where
+ good_inst key arity = isInstIdOf key v && result_is_list && n_args == arity
+ good_id key arity = getUnique v == key && result_is_list && n_args == arity
+
+ n_args :: Int
+ n_args = length val_args
+
+ result_is_list = resultTyIsList (idType v) ty_args val_args
+
+resultTyIsList ty ty_args val_args
+ = go ty ty_args
+ where
+ go1 ty (_:tys) = case splitForAllTy_maybe ty of
+ Just (_,ty) -> go1 ty tys
+ Nothing -> False
+ go1 ty [] = go2 ty val_args
+
+ go2 ty (_:args) = case splitFunTy_maybe of
+ Just (_,ty) -> go2 ty args
+ Nothing -> False
+
+ go2 ty [] = case splitTyConApp_maybe of
+ Just (tycon, [_]) | tycon == listTyCon -> True
+ other -> False
+
+
\begin{code}
-deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
+deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
-deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above
- = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list]
+deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs (mkConApp consDataCon [Type (coreExprType core_expr), core_expr, list])
-deListComp expr (FilterQual filt : quals) list -- rule B above
- = dsExpr filt `thenDs` \ core_filt ->
- deListComp expr quals list `thenDs` \ core_rest ->
- returnDs ( mkCoreIfThenElse core_filt core_rest list )
+deListComp (GuardStmt guard locn : quals) list -- rule B above
+ = dsExpr guard `thenDs` \ core_guard ->
+ deListComp quals list `thenDs` \ core_rest ->
+ returnDs (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
-deListComp expr (LetQual binds : quals) list
- = dsBinds False binds `thenDs` \ core_binds ->
- deListComp expr quals list `thenDs` \ core_rest ->
- returnDs (mkCoLetsAny core_binds core_rest)
+deListComp (LetStmt binds : quals) list
+ = deListComp quals list `thenDs` \ core_rest ->
+ dsLet binds core_rest
-deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
+deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
let
u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing
res_ty = coreExprType core_list2
h_ty = u1_ty `mkFunTy` res_ty
in
- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
- `thenDs` \ [h', u1, u2, u3] ->
- {-
- Make the function h unfoldable by the deforester.
- Since it only occurs once in the body, we can't get
- an increase in code size by unfolding it.
- -}
+ newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
+
+ -- the "fail" value ...
let
- h = if False -- LATER: sw_chkr DoDeforest???
- then panic "deListComp:deforest"
- -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
- else h'
+ core_fail = App (Var h) (Var u3)
+ letrec_body = App (Var h) core_list1
in
- -- the "fail" value ...
- mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail ->
-
- deListComp expr quals core_fail `thenDs` \ rest_expr ->
-
- matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
-
- mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body ->
-
- returnDs (
- mkCoLetrecAny [
- ( h,
- (Lam (ValBinder u1)
- (Case (Var u1)
- (AlgAlts
- [(nilDataCon, [], core_list2),
- (consDataCon, [u2, u3], core_match)]
- NoDefault)))
- )] letrec_body
- )
+ deListComp quals core_fail `thenDs` \ rest_expr ->
+ matchSimply (Var u2) ListCompMatch pat
+ rest_expr core_fail `thenDs` \ core_match ->
+ let
+ rhs = Lam u1 $
+ Case (Var u1) u1 [(DataCon nilDataCon, [], core_list2),
+ (DataCon consDataCon, [u2, u3], core_match)]
+ in
+ returnDs (Let (Rec [(h, rhs)]) letrec_body)
\end{code}
%************************************************************************
_ b -> b) n l
\end{verbatim}
\begin{code}
-dfListComp :: CoreExpr -- the inside of the comp
- -> Type -- the type of the inside
- -> Type -> Id -- 'c'; its type and id
+dfListComp :: Type -> Id -- 'c'; its type and id
-> Type -> Id -- 'n'; its type and id
- -> [TypecheckedQual] -- the rest of the qual's
+ -> [TypecheckedStmt] -- the rest of the qual's
-> DsM CoreExpr
-dfListComp expr expr_ty c_ty c_id n_ty n_id []
- = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)]
+dfListComp c_ty c_id n_ty n_id [ReturnStmt expr]
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs (mkApps (Var c_id) [core_expr, Var n_id])
-dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
- = dsExpr filt `thenDs` \ core_filt ->
- dfListComp expr expr_ty c_ty c_id n_ty n_id quals
- `thenDs` \ core_rest ->
- returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
+dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals)
+ = dsExpr guard `thenDs` \ core_guard ->
+ dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ returnDs (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
- = panic "dfListComp:LetQual"
+dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
+ -- new in 1.3, local bindings
+ = dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ dsLet binds core_rest
-dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
+dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
-- evaluate the two lists
= dsExpr list1 `thenDs` \ core_list1 ->
-- build rest of the comprehesion
- dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest ->
+ dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr ->
+ matchSimply (Var p) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
returnDs (
- mkCoLetsAny
- [NonRec fn (mkValLam [p, b] core_expr),
+ mkLets
+ [NonRec fn (mkLams [p, b] core_expr),
NonRec lst core_list1]
(mkFoldr p_ty n_ty fn n_id lst)
)
+\end{code}
+
+
+@mkBuild@ is sugar for building a build!
+
+@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
+@ty@ is the type of the list.
+@tv@ is always a new type variable.
+@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
+ c :: a -> b -> b
+ n :: b
+ v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
+-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
+@e@ is the object right inside the @build@
+
+\begin{code}
+mkBuild :: Type
+ -> TyVar
+ -> Id
+ -> Id
+ -> Id
+ -> CoreExpr -- template
+ -> CoreExpr -- template
+
+mkBuild ty tv c n g expr
+ = Let (NonRec g (mkLams [tv, c,n] expr))
+ (mkApps (Var buildId) [Type ty, Var g])
+
+buildId = error "DsListComp: buildId"
mkFoldr a b f z xs
- = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
+ = mkApps (mkTyApps (Var foldrId) [a,b]) [Var f, Var z, Var xs]
\end{code}
+
projects / ghc-hetmet.git / blobdiff