[Git][ghc/ghc][wip/expand-do] Start of HsExpand for HsDo Fixes for #18324

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
c4aadb28 by Apoorv Ingle at 2023-03-08T18:41:26-06:00
Start of HsExpand for HsDo Fixes for #18324

- - - - -


2 changed files:

- compiler/GHC/Rename/Expr.hs
- + testsuite/tests/rebindable/T18324.hs


Changes:

=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -433,7 +433,10 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
           rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
             (\ _ -> return ((), emptyFVs))
       ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
-      ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
+      ; let orig_do_block = HsDo noExtField do_or_lc (L l pp_stmts)
+            expd_do_block = expand_do_stmts pp_stmts
+      ; return ( mkExpandedExpr orig_do_block expd_do_block
+               , fvs1 `plusFV` fvs2 ) }
 
 -- ExplicitList: see Note [Handling overloaded and rebindable constructs]
 rnExpr (ExplicitList _ exps)
@@ -1165,7 +1168,7 @@ rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
                             else return (noSyntaxExpr, emptyFVs)
                             -- The 'return' in a LastStmt is used only
                             -- for MonadComp; and we don't want to report
-                            -- "non in scope: return" in other cases
+                            -- "not in scope: return" in other cases
                             -- #15607
 
         ; (thing,  fvs3) <- thing_inside []
@@ -2703,6 +2706,53 @@ mkExpandedExpr
   -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
 mkExpandedExpr a b = XExpr (HsExpanded a b)
 
+
+
+-- | Expand the Do statments so that it works fine with Quicklook
+--   See Note[Rebindable Do Expanding Statements]
+expand_do_stmts :: [ExprLStmt GhcRn] -> HsExpr GhcRn
+
+expand_do_stmts [L _ (LastStmt _ body _ NoSyntaxExprRn)]
+-- TODO: not sure about this maybe this never happens in a do block?
+-- This does happen in a list comprehension though
+--  = genHsApp (genHsVar returnMName) body
+  = unLoc body
+  
+expand_do_stmts [L l (LastStmt _ body _ (SyntaxExprRn ret))]
+--                      
+--    ------------------------------------------------
+--               return e  ~~> return e
+-- definitely works T18324.hs
+  = unLoc $ mkHsApp (L l ret) body
+
+expand_do_stmts ((L l (BindStmt _ x e)):lstmts)
+--                      stmts ~~> stmt'
+--    ------------------------------------------------
+--       x <- e ; stmts   ~~> (Prelude.>>=) e (\ x -> stmts' ) 
+  = genHsApps bindMName                                 -- (>>=)
+              [ e                                       --  e
+              , mkHsLam [x] (L l $ expand_do_stmts lstmts)    -- (\ x -> stmts')
+              ]
+-- expand_do_stmts ((L l (LetStmt _ x e)):lstmts) = undefined
+--                      stmts ~~> stmts'
+--    ------------------------------------------------
+--       let x = e ; stmts ~~> let x = e in stmts'
+
+expand_do_stmts ((L l (BodyStmt _ e (SyntaxExprRn f) _)):lstmts)
+--              stmts ~~> stmts'
+--    ----------------------------------------------
+--      e ; stmts ~~> (Prelude.>>) e (\ _ -> stmt')
+  = unLoc $ nlHsApp (nlHsApp (L l f)  -- (>>) See Note [BodyStmt]
+                             e
+                    )
+                     $ mkHsLam [] (L l $ expand_do_stmts lstmts)
+  
+-- expand_do_stmts ((L l (TransStmt {})):lstmts) = undefined
+-- expand_do_stmts ((L l (RecStmt {})):lstmts) = undefined
+
+-- expand_do_stmts (stmt@(L _ (ParStmt {})):_) = pprPanic "expand_do_stmts: impossible happened" $ ppr stmt
+expand_do_stmts stmt = pprPanic "expand_do_stmts: impossible happened" $ ppr stmt
+
 -----------------------------------------
 -- Bits and pieces for RecordDotSyntax.
 --


=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ImpredicativeTypes, DeriveAnyClass #-}
+module T18324 where
+
+
+type Id = forall a. a -> a
+
+t :: IO Id
+t = return id
+
+p :: Id -> (Bool, Int)
+p f = (f True, f 3)
+
+foo1 = t >>= \x -> return (p x)
+
+foo2 = do { x <- t ; return (p x) }
+
+
+-- data State a s = S (a, s) deriving (Functor, Applicative, Monad)
+
+-- update :: State a s -> (s -> s) -> State a s
+-- update (S (a, s)) f = S (a, f s)
+
+
+-- ts :: State Int Id
+-- ts = return id
+
+-- foo3 = do { x <- ts ; update ts ; return (p x) }
+



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c4aadb286a407e5af13657d5b970501196ac338f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c4aadb286a407e5af13657d5b970501196ac338f
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/20230308/176cfcf1/attachment-0001.html>