%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsListComp]{Desugaring list comprehensions}
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
-import HsSyn ( Stmt(..), HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr , 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 Id ( Id )
-import PrelVals ( mkBuild, foldrId )
+import CoreUtils ( coreExprType )
+import Var ( Id, TyVar )
+import Const ( Con(..) )
+import PrelInfo ( foldrId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
-import TysPrim ( alphaTy )
+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''
returnDs (mkBuild elt_ty n_tyvar c n g result)
where
- nil_expr = mkCon nilDataCon [elt_ty] []
+ 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 :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
= dsExpr expr `thenDs` \ core_expr ->
- mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list]
+ returnDs (mkConApp consDataCon [Type (coreExprType core_expr), core_expr, list])
deListComp (GuardStmt guard locn : quals) list -- rule B above
= dsExpr guard `thenDs` \ core_guard ->
deListComp quals list `thenDs` \ core_rest ->
- returnDs (mkCoreIfThenElse core_guard core_rest list)
+ returnDs (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list
- = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- deListComp quals list `thenDs` \ core_rest ->
- returnDs (mkCoLetsAny core_binds core_rest)
+ = deListComp quals list `thenDs` \ core_rest ->
+ dsLet binds core_rest
deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
-- the "fail" value ...
- mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail ->
+ let
+ core_fail = App (Var h) (Var u3)
+ letrec_body = App (Var h) core_list1
+ in
deListComp quals core_fail `thenDs` \ rest_expr ->
- matchSimply (Var u2) ListCompMatch pat res_ty
+ matchSimply (Var u2) ListCompMatch pat
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
- )
+ 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}
%************************************************************************
dfListComp c_ty c_id n_ty n_id [ReturnStmt expr]
= dsExpr expr `thenDs` \ core_expr ->
- mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)]
+ returnDs (mkApps (Var c_id) [core_expr, 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 (mkCoreIfThenElse core_guard core_rest (Var n_id))
+ returnDs (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
-- new in 1.3, local bindings
- = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
- returnDs (mkCoLetsAny core_binds core_rest)
+ = dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ dsLet binds core_rest
dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
-- evaluate the two lists
dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var p) ListCompMatch 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