Commit 4c8e0307 authored by Ross Paterson's avatar Ross Paterson

fix #5022: polymorphic definitions inside arrow rec

This is quite tricky, with examples like this:

import Control.Arrow

pRepeat :: a -> [a]
pRepeat =
    proc x -> do
      rec
        s <- returnA -< f_rec x:s       -- f_rec is monomorphic here
        let f_later y = y               -- f_later is polymorphic here
        _ <- returnA -< (f_later True, f_later 'a')
        let f_rec y = y                 -- f_rec is polymorphic here
      returnA -< f_later s              -- f_later is monomorphic here

Fixed the typechecking of arrow RecStmt to track changes to the monad
version.  It was simplest to add a field recS_later_rets corresponding
to recS_rec_rets.  It's only used for the arrow version, and always
empty for the monad version.  But I think it would be cleaner to put
the rec_ids and later_ids in a single list with supplementary info
saying how they're used.

Also fixed several glitches in the desugaring of arrow RecStmt.  The fact
that the monomorphic variables shadow their polymorphic counterparts is a
major pain.  Also a bit of general cleanup of DsArrows while I was there.
parent 44e18534
This diff is collapsed.
......@@ -928,10 +928,11 @@ data StmtLR idL idR
, recS_mfix_fn :: SyntaxExpr idR -- The mfix function
-- These fields are only valid after typechecking
, recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 with
-- recS_rec_ids, and are the
-- expressions that should be returned by
-- the recursion.
, recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
, recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
-- with recS_later_ids and recS_rec_ids,
-- and are the expressions that should be
-- returned by the recursion.
-- They may not quite be the Ids themselves,
-- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*,
......
......@@ -233,7 +233,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr, recS_later_rets = []
, recS_rec_rets = [], recS_ret_ty = placeHolderType }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
......
......@@ -348,25 +348,32 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
, recS_rec_ids = recNames }) res_ty thing_inside
= do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names }) res_ty thing_inside
= do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
; tcExtendIdEnv tup_ids $ do
{ (stmts', tup_rets)
<- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' ->
-- ToDo: res_ty not really right
do { rec_rets <- zipWithM tcCheckId recNames rec_tys
; later_ids <- tcLookupLocalIds laterNames
; return (later_ids, rec_rets) }
zipWithM tcCheckId tup_names tup_elt_tys
; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
; thing <- thing_inside res_ty
-- NB: The rec_ids for the recursive things
-- already scope over this part. This binding may shadow
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
; let rec_ids = takeList rec_names tup_ids
; later_ids <- tcLookupLocalIds later_names
; let rec_rets = takeList rec_names tup_rets
; let ret_table = zip tup_ids tup_rets
; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_later_rets = later_rets
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_ret_ty = res_ty }, thing)
}}
......
......@@ -792,7 +792,8 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
, recS_rec_rets = rets, recS_ret_ty = ret_ty })
, recS_later_rets = later_rets, recS_rec_rets = rec_rets
, recS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_ty <- zonkTcTypeToType env ret_ty
......@@ -803,12 +804,14 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
; (env2, new_segStmts) <- zonkStmts env1 segStmts
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
; new_rets <- mapM (zonkExpr env2) rets
; new_later_rets <- mapM (zonkExpr env2) later_rets
; new_rec_rets <- mapM (zonkExpr env2) rec_rets
; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
, recS_later_rets = new_later_rets
, recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
......
......@@ -832,7 +832,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
, recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
, recS_later_rets = [], recS_rec_rets = tup_rets
, recS_ret_ty = stmts_ty }, thing)
}}
tcDoStmt _ stmt _ _
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment