X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=2292aedc12a46fbcbee517201108f9f913599059;hp=99a5dab44acfc332acd4dc698f3b21c17d0da93e;hb=7836349556deef66f1b1d06fe8e9c7c0b841f0d0;hpb=79b22beb4d2eca1877d99d55838ba6ce69658405 diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 99a5dab..2292aed 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -34,12 +34,9 @@ import Type import TysWiredIn import Match import PrelNames -import PrelInfo import SrcLoc import Outputable import FastString - -import Control.Monad ( liftM2 ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -95,12 +92,12 @@ dsInnerListComp (stmts, bndrs) = do -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do - (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders) - usingExpr' <- dsLExpr usingExpr +dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) + = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders) + ; usingExpr' <- dsLExpr usingExpr - using_args <- - case maybeByExpr of + ; using_args <- + case maybeByExpr of Nothing -> return [expr] Just byExpr -> do byExpr' <- dsLExpr byExpr @@ -111,16 +108,15 @@ dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do return [Lam tuple_binder byExprWrapper, expr] - let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args) - - let pat = mkBigLHsVarPatTup binders - return (inner_list_expr, pat) + ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args) + pat = mkBigLHsVarPatTup binders + ; return (inner_list_expr, pat) } -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do +dsGroupStmt (GroupStmt stmts binderMap by using) = do let (fromBinders, toBinders) = unzip binderMap fromBindersTypes = map idType fromBinders @@ -129,23 +125,19 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do toBindersTupleType = mkBigCoreTupTy toBindersTypes -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, fromBindersTupleType) <- dsInnerListComp (stmts, fromBinders) + (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - (usingExpr', usingArgs) <- - case groupByClause of - GroupByNothing usingExpr -> liftM2 (,) (dsLExpr usingExpr) (return [expr]) - GroupBySomething usingExpr byExpr -> do - usingExpr' <- dsLExpr (either id noLoc usingExpr) - - byExpr' <- dsLExpr byExpr - - us <- newUniqueSupply - [fromBindersTuple] <- newSysLocalsDs [fromBindersTupleType] - let byExprWrapper = mkTupleCase us fromBinders byExpr' fromBindersTuple (Var fromBindersTuple) - - return (usingExpr', [Lam fromBindersTuple byExprWrapper, expr]) + usingExpr' <- dsLExpr (either id noLoc using) + usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; us <- newUniqueSupply + ; [from_tup_id] <- newSysLocalsDs [from_tup_ty] + ; let by_wrap = mkTupleCase us fromBinders by_e' + from_tup_id (Var from_tup_id) + ; return [Lam from_tup_id by_wrap, expr] } -- Create an unzip function for the appropriate arity and element types and find "map" (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes @@ -153,12 +145,12 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' ((Type fromBindersTupleType) : usingArgs) + inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs) -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! unzipped_inner_list_expr = mkApps (Var map_id) - [Type (mkListTy fromBindersTupleType), Type toBindersTupleType, Var unzip_fn, inner_list_expr] + [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr] -- Then finally we bind the unzip function around that expression bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr @@ -270,11 +262,11 @@ deListComp (LetStmt binds : quals) body list = do core_rest <- deListComp quals body list dsLocalBinds binds core_rest -deListComp (stmt@(TransformStmt _ _ _) : quals) body list = do +deListComp (stmt@(TransformStmt {}) : quals) body list = do (inner_list_expr, pat) <- dsTransformStmt stmt deBindComp pat inner_list_expr quals body list -deListComp (stmt@(GroupStmt _ _) : quals) body list = do +deListComp (stmt@(GroupStmt {}) : quals) body list = do (inner_list_expr, pat) <- dsGroupStmt stmt deBindComp pat inner_list_expr quals body list @@ -362,12 +354,12 @@ dfListComp c_id n_id (LetStmt binds : quals) body = do core_rest <- dfListComp c_id n_id quals body dsLocalBinds binds core_rest -dfListComp c_id n_id (stmt@(TransformStmt _ _ _) : quals) body = do +dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do (inner_list_expr, pat) <- dsTransformStmt stmt -- Anyway, we bind the newly transformed list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals body -dfListComp c_id n_id (stmt@(GroupStmt _ _) : quals) body = do +dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do (inner_list_expr, pat) <- dsGroupStmt stmt -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals body @@ -604,7 +596,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do -- dePArrComp (LetStmt ds : qs) body pa cea = do mapP <- dsLookupGlobalId mapPName - let xs = map unLoc (collectLocalBinders ds) + let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) @@ -642,7 +634,7 @@ dePArrParComp qss body = do -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = do -- first statement - let res_expr = mkLHsVarTup xs + let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined parStmts qss (mkLHsVarPatTup xs) cqs --- @@ -651,7 +643,7 @@ dePArrParComp qss body = do zipP <- dsLookupGlobalId zipPName let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea - res_expr = mkLHsVarTup xs + res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]