--- mkMcUnzipM m [t1, t2]
--- = (unzip_fn, \ys :: m (t1, t2) ->
--- ( liftM (selN1 :: (t1, t2) -> t1) ys
--- , liftM (selN2 :: (t1, t2) -> t2) ys
--- ))
---
-mkMcUnzipM :: CoreExpr
- -> Type -- m
- -> [Type] -- [a,b,c,..]
- -> DsM (Id, CoreExpr)
-mkMcUnzipM liftM_op m_ty elt_tys
- = do { ys <- newSysLocalDs monad_tuple_ty
- ; xs <- mapM newSysLocalDs elt_tys
- ; scrut <- newSysLocalDs tuple_tys
-
- ; unzip_fn <- newSysLocalDs unzip_fn_ty
-
- ; let -- Select one Id from our tuple
- selectExpr n = mkLams [scrut] $ mkTupleSelector xs (xs !! n) scrut (Var scrut)
- -- Apply 'selectVar' and 'ys' to 'liftM'
- tupleElem n = mkApps liftM_op
- -- Types (m is figured out by the type checker):
- -- liftM :: forall a b. (a -> b) -> m a -> m b
- [ Type tuple_tys, Type (elt_tys !! n)
- -- Arguments:
- , selectExpr n, Var ys ]
- -- The final expression with the big tuple
- unzip_body = mkBigCoreTup [ tupleElem n | n <- [0..length elt_tys - 1] ]
-
- ; return (unzip_fn, mkLams [ys] unzip_body) }
- where monad_tys = map (m_ty `mkAppTy`) elt_tys -- [m a,m b,m c,..]
- tuple_monad_tys = mkBigCoreTupTy monad_tys -- (m a,m b,m c,..)
- tuple_tys = mkBigCoreTupTy elt_tys -- (a,b,c,..)
- monad_tuple_ty = m_ty `mkAppTy` tuple_tys -- m (a,b,c,..)
- unzip_fn_ty = monad_tuple_ty `mkFunTy` tuple_monad_tys -- m (a,b,c,..) -> (m a,m b,m c,..)
-
--- Generate the `mzip` function for `ParStmt` in monad comprehensions, for
--- example:
---
--- mzip :: m t1
--- -> (m t2 -> m t3 -> m (t2, t3))
--- -> m (t1, (t2, t3))
---
--- mkMcZipM m [t1, t2, t3]
--- = (zip_fn, \(q1::t1) (q2::t2) (q3::t3) ->
--- mzip q1 (mzip q2 q3))
---
-mkMcZipM :: CoreExpr
- -> Type
- -> [Type]
- -> DsM (Id, CoreExpr)
-
-mkMcZipM mzip_op m_ty tys@(_:_:_) -- min. 2 types
- = do { (ids, t1, tuple_ty, zip_body) <- loop tys
- ; zip_fn <- newSysLocalDs $
- (m_ty `mkAppTy` t1)
- `mkFunTy`
- (m_ty `mkAppTy` tuple_ty)
- `mkFunTy`
- (m_ty `mkAppTy` mkBigCoreTupTy [t1, tuple_ty])
- ; return (zip_fn, mkLams ids zip_body) }
-
- where
- -- loop :: [Type] -> DsM ([Id], Type, [Type], CoreExpr)
- loop [t1, t2] = do -- last run of the `loop`
- { ids@[a,b] <- newSysLocalsDs (map (m_ty `mkAppTy`) [t1,t2])
- ; let zip_body = mkApps mzip_op [ Type t1, Type t2 , Var a, Var b ]
- ; return (ids, t1, t2, zip_body) }
-
- loop (t1:tr) = do
- { -- Get ty, ids etc from the "inner" zip
- (ids', t1', t2', zip_body') <- loop tr
-
- ; a <- newSysLocalDs $ m_ty `mkAppTy` t1
- ; let tuple_ty' = mkBigCoreTupTy [t1', t2']
- zip_body = mkApps mzip_op [ Type t1, Type tuple_ty', Var a, zip_body' ]
- ; return ((a:ids'), t1, tuple_ty', zip_body) }
-
--- This case should never happen:
-mkMcZipM _ _ tys = pprPanic "mkMcZipM: unexpected argument" (ppr tys)
-
+-- mkMcUnzipM fmap ys [t1, t2]
+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys
+-- , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+ -> SyntaxExpr TcId -- fmap
+ -> Id -- Of type n (a,b,c)
+ -> [Type] -- [a,b,c]
+ -> DsM CoreExpr -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+ = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+ = do { fmap_op' <- dsExpr fmap_op
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; let tup_ty = mkBigCoreTupTy elt_tys
+ ; tup_xs <- newSysLocalDs tup_ty
+
+ ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
+ [ Type tup_ty, Type (elt_tys !! i)
+ , mk_sel i, Var ys]
+
+ mk_sel n = Lam tup_xs $
+ mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
+
+ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }