[Git][ghc/ghc][wip/expand-do] - fixed rec with mfix, make sure fail is used for pattern failures
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Mar 17 23:25:41 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
3a188995 by Apoorv Ingle at 2023-03-17T18:25:27-05:00
- fixed rec with mfix, make sure fail is used for pattern failures
- Lexer fails with missing MonadFail instance for P. Looks like a qualified name problem correct instance not being imported problem
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- testsuite/tests/rebindable/T18324.hs
- testsuite/tests/rebindable/all.T
- + testsuite/tests/rebindable/pattern-fails.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1055,11 +1055,12 @@ data HsExpansion orig expanded
= HsExpanded orig expanded
deriving Data
--- | Just print the original expression (the @a@).
+-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- (ppr orig)
+ -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ -- (ppr orig)
+ = ppr orig <+> braces (text "Expansion:" <+> ppr expanded)
{-
@@ -1961,6 +1962,13 @@ matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
matchDoContextErrString ListComp = text "list comprehension"
matchDoContextErrString MonadComp = text "monad comprehension"
+instance Outputable HsDoFlavour where
+ ppr (DoExpr m) = text "DoExpr" <+> parens (ppr m)
+ ppr (MDoExpr m) = text "MDoExpr" <+> parens (ppr m)
+ ppr GhciStmtCtxt = text "GhciStmtCtxt"
+ ppr ListComp = text "ListComp"
+ ppr MonadComp = text "MonadComp"
+
pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Fixity
import GHC.Types.Id.Make
+import GHC.Types.Basic(Origin(..))
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
@@ -76,7 +77,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import Data.List (unzip4, minimumBy)
+import Data.List (unzip4, minimumBy, (\\))
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
@@ -432,12 +433,25 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
= do { ((stmts1, _), fvs1) <-
rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
(\ _ -> return ((), emptyFVs))
- ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
+ ; ((pp_stmts, fvs2), is_app_do) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
; 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 ) }
-
+ ; return $ case do_or_lc of
+ DoExpr {} -> (if is_app_do
+ -- TODO i don't want to thing about applicative stmt rearrangements yet
+ then orig_do_block
+ else let expd_do_block = expand_do_stmts do_or_lc pp_stmts
+ in mkExpandedExpr orig_do_block expd_do_block
+ , fvs1 `plusFV` fvs2 )
+ MDoExpr {} -> (if is_app_do
+ -- TODO i don't want to thing about applicative stmt rearrangements yet
+ then orig_do_block
+ else let expd_do_block = expand_do_stmts do_or_lc pp_stmts
+ in mkExpandedExpr orig_do_block expd_do_block
+ , fvs1 `plusFV` fvs2 )
+ _ -> (orig_do_block, fvs1 `plusFV` fvs2)
+ -- ListComp -> (orig_do_block, fvs1 `plusFV` fvs2)
+ -- GhciStmtCtxt -> (orig_do_block, fvs1 `plusFV` fvs2)
+ }
-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
rnExpr (ExplicitList _ exps)
= do { (exps', fvs) <- rnExprs exps
@@ -1060,7 +1074,7 @@ rnStmts ctxt rnBody stmts thing_inside
postProcessStmtsForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
- -> RnM ([ExprLStmt GhcRn], FreeVars)
+ -> RnM (([ExprLStmt GhcRn], FreeVars), Bool) -- True <=> applicative do statement
postProcessStmtsForApplicativeDo ctxt stmts
= do {
-- rearrange the statements using ApplicativeStmt if
@@ -1074,8 +1088,10 @@ postProcessStmtsForApplicativeDo ctxt stmts
; in_th_bracket <- isBrackStage <$> getStage
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
- ; rearrangeForApplicativeDo ctxt stmts }
- else noPostProcessStmts (HsDoStmt ctxt) stmts }
+ ; ado_stmts_and_fvs <- rearrangeForApplicativeDo ctxt stmts
+ ; return (ado_stmts_and_fvs, True) }
+ else do { do_stmts_and_fvs <- noPostProcessStmts (HsDoStmt ctxt) stmts
+ ; return (do_stmts_and_fvs, False) } }
-- | strip the FreeVars annotations from statements
noPostProcessStmts
@@ -2710,51 +2726,145 @@ mkExpandedExpr a b = XExpr (HsExpanded a b)
-- | Expand the Do statments so that it works fine with Quicklook
-- See Note[Rebindable Do Expanding Statements]
--- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is still displayed on the expanded expr and not on the unexpanded expr
--- 2. Need to figure out the exact cases where this function needs to be called. It fails on lists
--- 3. Convert let statements into expanded version.
--- 4. hopefully the co-recursive cases won't get affected by this expansion
-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))]
---
+-- 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] -> HsExpr GhcRn
+
+expand_do_stmts do_flavour [L _ (LastStmt _ body _ NoSyntaxExprRn)]
+ -- if it is a last statement of a list comprehension, we need to explicitly return it -- See Note [TODO]
+ -- genHsApp (genHsVar returnMName) body
+ | ListComp <- do_flavour
+ = genHsApp (genHsVar returnMName) body
+ | MonadComp <- do_flavour
+ = unLoc body -- genHsApp (genHsVar returnMName) body
+ | otherwise
+ -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
+ = unLoc body
+
+expand_do_stmts _ [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)
+ = unLoc $ mkHsApp (noLocA ret) body
+
+expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn x e)): lstmts)
+ | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
+ , Just (SyntaxExprRn fail_op) <- xbsrn_failOp xbsrn =
+-- the pattern binding x can fail
+-- stmts ~~> stmt' let f x = stmts'; f _ = fail ".."
+-- -------------------------------------------------------
+-- x <- e ; stmts ~~> (Prelude.>>=) e f
+
+ foldl genHsApp bind_op -- (>>=)
+ [ e
+ , noLocA $ failable_expr x (expand_do_stmts do_or_lc lstmts) fail_op
+ ]
+ | SyntaxExprRn bop <- xbsrn_bindOp xbsrn
+ , Nothing <- xbsrn_failOp xbsrn = -- irrefutable pattern so no failure
-- 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
+-- x <- e ; stmts ~~> (Prelude.>>=) e (\ x -> stmts')
+ foldl genHsApp bop -- (>>=)
+ [ e
+ , mkHsLam [x] (noLocA $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
+ ]
+
+ | otherwise = -- just use the polymorhpic bindop. TODO: Necessary?
+ genHsApps bindMName -- (Prelude.>>=)
+ [ e
+ , mkHsLam [x] (noLocA $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
+ ]
+
+ where
+ failable_expr :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+ failable_expr pat expr fail_op = HsLam noExtField $
+ mkMatchGroup Generated
+ (noLocA [ mkHsCaseAlt pat (noLocA expr)
+ , mkHsCaseAlt nlWildPatName
+ (noLocA $ genHsApp fail_op
+ (nlHsLit $ mkHsString "fail pattern")) ])
+
+expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
+ HsLet NoExtField noHsTok bnds noHsTok
+ $ noLocA (expand_do_stmts do_or_lc lstmts)
-expand_do_stmts ((L l (BodyStmt _ e (SyntaxExprRn f) _)):lstmts)
+
+expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- stmts ~~> stmts'
-- ----------------------------------------------
--- e ; stmts ~~> (Prelude.>>) e (\ _ -> stmt')
- = unLoc $ nlHsApp (nlHsApp (L l f) -- (>>) See Note [BodyStmt]
+-- e ; stmts ~~> (Prelude.>>) e stmt'
+ unLoc $ nlHsApp (nlHsApp (noLocA 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
+ $ (noLocA $ expand_do_stmts do_or_lc lstmts)
+
+expand_do_stmts do_or_lc ((L l (RecStmt { recS_stmts = rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ -- use it explicitly
+ -- at the end of expanded rec block
+ }))
+ : lstmts) =
+-- See Note [Typing a RecStmt]
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------------------------
+-- rec { later_ids, local_ids, rec_block } ; stmts
+-- ~~> (Prelude.>>=) (mfix (\[ local_ids ++ later_ids ]
+-- -> do { rec_stmts
+-- ; return (later_ids, local_ids) } ))
+-- (\ [ local_ids ++ later_ids ] -> stmts')
+
+ genHsApps bindMName -- (Prelude.>>=)
+ [ (noLocA mfix_fun) `mkHsApp` mfix_expr -- mfix (do block)
+ , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x -> stmts')
+ (L l $ expand_do_stmts do_or_lc lstmts)
+ ]
+ where
+ local_only_ids = local_ids \\ later_ids -- get unique local rec ids; local rec ids and later ids overlap
+ all_ids = local_only_ids ++ later_ids -- put local ids before return ids
+
+ return_stmt :: ExprLStmt GhcRn
+ return_stmt = noLocA $ LastStmt 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
+ mfix_expr :: LHsExpr GhcRn
+ mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
+
+expand_do_stmts _ (stmt@(L _ (RecStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened RecStmt" $ ppr stmt
+
+
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+-- See See Note [Monad Comprehensions]
+-- Parallel statements only appear in
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------------------------
+-- ; stmts
+-- ~~> (Prelude.>>=) (mfix (\[ local_ids ++ later_ids ]
+-- -> do { rec_stmts
+-- ; return (later_ids, local_ids) } ))
+-- (\ [ local_ids ++ later_ids ] -> stmts')
+ pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt {})):_) =
+-- See Note [Applicative BodyStmt]
+
+ pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" $ ppr stmt
+
+expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE ImpredicativeTypes, DeriveAnyClass #-}
-module T18324 where
+-- {-# LANGUAGE MonadComprehensions, RecursiveDo #-}
+module Main where
type Id = forall a. a -> a
@@ -15,14 +16,6 @@ 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) }
-
+main = do x <- foo2
+ putStrLn $ show x
+
=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -42,3 +42,5 @@ test('T14670', expect_broken(14670), compile, [''])
test('T19167', normal, compile, [''])
test('T19918', normal, compile_and_run, [''])
test('T20126', normal, compile_fail, [''])
+test('T18324', normal, compile_and_run, [''])
+test('pattern-fails', normal, compile_and_run, [''])
=====================================
testsuite/tests/rebindable/pattern-fails.hs
=====================================
@@ -0,0 +1,9 @@
+module Main where
+
+
+main :: IO ()
+main = putStrLn . show $ qqq ['c']
+
+qqq :: [a] -> Maybe (a, [a])
+qqq ts = do { (a:b:as) <- Just ts
+ ; return (a, as) }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a18899588f4480a0cdb50cf5d5b78fc92123f8e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a18899588f4480a0cdb50cf5d5b78fc92123f8e
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/20230317/5c70e429/attachment-0001.html>
More information about the ghc-commits
mailing list