[Git][ghc/ghc][wip/expand-do] 2 commits: expansion of a bind statement may not be as easy as it looks. T18324b.hs is a...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Sat Mar 25 01:30:02 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
c910643b by Apoorv Ingle at 2023-03-24T18:38:41-05:00
expansion of a bind statement may not be as easy as it looks. T18324b.hs is a an example. I think its some delicate interaction between quick look and type families
- - - - -
48266ae1 by Apoorv Ingle at 2023-03-24T20:29:08-05:00
do not add explicit return for `mfix` mdo blocks. This whole last stmt business is very messy.
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Module.hs
- testsuite/tests/rebindable/T18324.hs
- + testsuite/tests/rebindable/T18324b.hs
Changes:
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -345,11 +345,11 @@ subordinates env instMap decl = case decl of
InstD _ (ClsInstD _ d) -> let
data_fams = do
DataFamInstDecl { dfid_eqn =
- FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
+ (FamEqn { feqn_tycon = L l _
+ , feqn_rhs = defn } :: FamEqn GhcRn (HsDataDefn GhcRn))} <- unLoc <$> cid_datafam_insts d
[ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
ty_fams = do
- TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d
+ TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ } :: FamEqn GhcRn (LHsType GhcRn)) } <- unLoc <$> cid_tyfam_insts d
[ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]
in data_fams ++ ty_fams
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1203,6 +1203,8 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
-- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is displayed on the expanded expr and not on the unexpanded expr
expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+
expand_do_stmts do_flavour [L _ (LastStmt _ body _ ret_expr)]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
@@ -1226,7 +1228,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
-- the pattern binding x can fail
-- stmts ~~> stmt' let f pat = stmts'; f _ = fail ".."
-- -------------------------------------------------------
--- pat <- e ; stmts ~~> (Prelude.>>=) e f
+-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
return $ noLocA (foldl genHsApp bind_op -- (>>=)
@@ -1235,7 +1237,11 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
])
| otherwise = -- just use the polymorhpic bindop. TODO: Necessary?
- do expand_stmts <- expand_do_stmts do_or_lc lstmts
+-- stmts ~~> stmts'
+-- -------------------------------------------------------
+-- pat <- e ; stmts ~~> (Prelude.>>=) e (\ pat -> stmts')
+ do traceTc "expand_do_stmts: generic binop" empty
+ expand_stmts <- expand_do_stmts do_or_lc lstmts
return $ noLocA (genHsApps bindMName -- (Prelude.>>=)
[ e
, mkHsLam [pat] expand_stmts -- (\ x -> stmts')
@@ -1290,46 +1296,42 @@ expand_do_stmts do_or_lc
return_stmt :: ExprLStmt GhcRn
return_stmt = noLocA $ LastStmt noExtField
- (mkHsApp (noLocA return_fun)
- $ mkBigLHsTup (map nlHsVar all_ids) noExtField)
+ (-- mkHsApp (noLocA return_fun)
+ -- $
+ mkBigLHsTup (map nlHsVar all_ids) noExtField)
Nothing
(SyntaxExprRn return_fun)
do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
do_stmts = noLocA $ (unLoc rec_stmts) ++ [return_stmt]
do_block :: LHsExpr GhcRn
- do_block = noLocA $ HsDo noExtField (DoExpr Nothing) $ do_stmts
+ do_block = noLocA $ HsDo noExtField (MDoExpr Nothing) $ do_stmts
mfix_expr :: LHsExpr GhcRn
mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
-expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
+expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
--- -------------------------------------------------
--- ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+-- -------------------------------------------------------------------------
+-- [(<$>, e1), (<*>, e2)] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
--
-- Very similar to HsToCore.Expr.dsDo
-- args are [(<$>, e1), (<*>, e2), .., ]
--- mb_join is Maybe (join)
do { expr' <- expand_do_stmts do_or_lc lstmts
+ -- extracts pats and arg bodies (rhss) from args
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
- ; body <- foldrM match_args expr' pats_can_fail -- add blocks for failable patterns
+ -- add blocks for failable patterns
+ ; body_with_fails <- foldrM match_args expr' pats_can_fail
- ; let expand_ado_expr = foldl mk_app_call body (zip (map fst args) rhss)
- ; traceTc "expand_do_stmts: debug" $ (vcat [ text "stmt:" <+> ppr stmt
- , text "(pats,rhss):" <+> ppr (pats_can_fail, rhss)
- , text "expr':" <+> ppr expr'
- , text "args" <+> ppr args
- , text "final_ado" <+> ppr expand_ado_expr
- ])
+ -- builds (body <$> e1 <*> e2 ...)
+ ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
-
- -- pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" empty
+ -- wrap the expanded expression with a `join` if needed
; case mb_join of
Nothing -> return expand_ado_expr
- Just NoSyntaxExprRn -> return expand_ado_expr -- this is stupid
+ Just NoSyntaxExprRn -> return expand_ado_expr -- why can this happen?
Just (SyntaxExprRn join_op) -> return $ mkHsApp (noLocA join_op) expand_ado_expr
}
where
@@ -1343,18 +1345,18 @@ expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
- mk_app_call l (op, r) = case op of
- SyntaxExprRn op -> mkHsApps (noLocA op) [l, r]
- NoSyntaxExprRn -> pprPanic "expand_do_stmts: impossible happened first arg" (ppr op)
+ mk_apps l (op, r) =
+ case op of
+ SyntaxExprRn op -> mkHsApps (noLocA op) [l, r]
+ NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
- pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
+ pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
-- See See Note [Monad Comprehensions]
- pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
-
+ pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -701,7 +701,7 @@ tcRnHsBootDecls hsc_src decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_annds = _
- , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
+ , hs_valds = (XValBindsLR (NValBinds val_binds val_sigs) :: HsValBinds GhcRn ) })
<- rnTopSrcDecls first_group
-- The empty list is for extra dependencies coming from .hs-boot files
@@ -1485,7 +1485,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
- XValBindsLR (NValBinds deriv_binds deriv_sigs))
+ (XValBindsLR (NValBinds deriv_binds deriv_sigs) :: HsValBinds GhcRn))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -2,7 +2,6 @@
-- {-# LANGUAGE MonadComprehensions, RecursiveDo #-}
module Main where
-
type Id = forall a. a -> a
t :: IO Id
@@ -15,13 +14,6 @@ foo1 = t >>= \x -> return (p x)
foo2 = do { x <- t ; return (p x) }
-
-main = do x <- foo2
+main = do x <- foo1
putStrLn $ show x
-
-data D a b = D b b | E a a
-
-fffgg daa = case daa of
- D b1 b2 -> let
- x = do
=====================================
testsuite/tests/rebindable/T18324b.hs
=====================================
@@ -0,0 +1,88 @@
+{-# LANGUAGE GADTs, TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE EmptyDataDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T18324b where
+
+
+data L a e = L a e
+unLoc :: L a e -> e
+unLoc (L _ e) = e
+
+data B = B
+
+
+type family XRec p a = r | r -> a
+type instance XRec (GhcPass p) a = L (Anno a) a
+
+type family Anno a = b
+
+data GhcPass (pass :: Pass)
+data Pass = Rn
+
+type family IdGhcP (pass :: Pass) where
+ IdGhcP 'Rn = B
+
+
+type GhcRn = GhcPass 'Rn
+
+data LHsType pass
+
+data ClsInstDecl pass =
+ ClsInstDecl
+ { -- cid_tyfam_insts :: [LTyFamInstDecl pass]
+ -- ,
+ cid_datafam_insts :: [LDataFamInstDecl pass]
+ }
+
+
+-- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
+type LDataFamInstDecl pass = XRec pass ([FamEqn pass (HsDataDefn pass)])
+-- type TyFamDefltDecl = TyFamInstDecl
+
+type family IdP p
+type instance IdP (GhcPass p) = IdGhcP p
+
+type LIdP p = XRec p (IdP p)
+
+data HsDataDefn pass
+
+data FamEqn pass rhs
+ = FamEqn
+ { feqn_tycon :: LIdP pass
+
+-- LIdP (GhcRn) ~~>
+
+ , feqn_rhs :: rhs }
+
+-- type TyFamInstEqn pass = FamEqn pass (LHsType pass)
+
+-- data TyFamInstDecl pass
+-- = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
+
+
+fffggg :: ClsInstDecl GhcRn -> [Int]
+fffggg ddd = -- let
+ -- data_fams =
+ do
+ [FamEqn { feqn_tycon = L l _
+ , feqn_rhs = defn }] <- unLoc <$> cid_datafam_insts ddd
+ [ 0 ]
+ -- in
+ -- data_fams
+ -- ty_fams = do
+ -- TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts ddd
+ -- [ 0 ]
+ -- in data_fams ++ ty_fams
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0f732508aa4fd0fc23a6f9e51052b0413318154...48266ae1b014e3bf62ef1f9a54228dc682d500d3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0f732508aa4fd0fc23a6f9e51052b0413318154...48266ae1b014e3bf62ef1f9a54228dc682d500d3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230324/0410fdcc/attachment-0001.html>
More information about the ghc-commits
mailing list