{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
import GHC.Rename.Env ( irrefutableConLikeRn )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
import GHC.Hs
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Driver.DynFlags ( DynFlags, getDynFlags )
import GHC.Driver.Ppr (showPpr)
import GHC.Types.SrcLoc
import GHC.Types.Basic
import qualified GHC.LanguageExtensions as LangExt
import Data.List ((\\))
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts :: HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expandDoStmts HsDoFlavour
doFlav [ExprLStmt (GhcPass 'Renamed)]
stmts = do expanded_expr <- HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
doFlav [ExprLStmt (GhcPass 'Renamed)]
stmts
case expanded_expr of
L SrcSpanAnnA
_ (XExpr (PopErrCtxt LHsExpr (GhcPass 'Renamed)
e)) -> LocatedA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
e
LocatedA (HsExpr (GhcPass 'Renamed))
_ -> LocatedA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA (HsExpr (GhcPass 'Renamed))
expanded_expr
expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expand_do_stmts :: HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
ListComp [ExprLStmt (GhcPass 'Renamed)]
_ =
String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: impossible happened. ListComp" SDoc
forall doc. IsOutput doc => doc
empty
expand_do_stmts HsDoFlavour
_ [] = String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: impossible happened. Empty stmts" SDoc
forall doc. IsOutput doc => doc
empty
expand_do_stmts HsDoFlavour
_ (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
_ (TransStmt {})):[ExprLStmt (GhcPass 'Renamed)]
_) =
String -> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: TransStmt" (SDoc -> TcM (LHsExpr (GhcPass 'Renamed)))
-> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
stmt
expand_do_stmts HsDoFlavour
_ (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
_ (ParStmt {})):[ExprLStmt (GhcPass 'Renamed)]
_) =
String -> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: ParStmt" (SDoc -> TcM (LHsExpr (GhcPass 'Renamed)))
-> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
stmt
expand_do_stmts HsDoFlavour
_ (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
_ (XStmtLR ApplicativeStmt{})): [ExprLStmt (GhcPass 'Renamed)]
_) =
String -> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: Applicative Stmt" (SDoc -> TcM (LHsExpr (GhcPass 'Renamed)))
-> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
stmt
expand_do_stmts HsDoFlavour
_ [stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
loc (LastStmt XLastStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
_ (L SrcSpanAnnA
body_loc HsExpr (GhcPass 'Renamed)
body) Maybe Bool
_ SyntaxExpr (GhcPass 'Renamed)
ret_expr))]
| SyntaxExpr (GhcPass 'Renamed)
SyntaxExprRn
NoSyntaxExprRn <- SyntaxExpr (GhcPass 'Renamed)
ret_expr
= do String -> SDoc -> TcRn ()
traceTc String
"expand_do_stmts last" (SyntaxExprRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr (GhcPass 'Renamed)
SyntaxExprRn
ret_expr)
LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed)))
-> LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> ExprLStmt (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
mkExpandedStmtPopAt SrcSpanAnnA
loc ExprLStmt (GhcPass 'Renamed)
stmt HsExpr (GhcPass 'Renamed)
body
| SyntaxExprRn HsExpr (GhcPass 'Renamed)
ret <- SyntaxExpr (GhcPass 'Renamed)
ret_expr
= do String -> SDoc -> TcRn ()
traceTc String
"expand_do_stmts last" (SyntaxExprRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr (GhcPass 'Renamed)
SyntaxExprRn
ret_expr)
let expansion :: HsExpr (GhcPass 'Renamed)
expansion = HsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
genHsApp HsExpr (GhcPass 'Renamed)
ret (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
body_loc HsExpr (GhcPass 'Renamed)
body)
LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed)))
-> LHsExpr (GhcPass 'Renamed) -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> ExprLStmt (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
mkExpandedStmtPopAt SrcSpanAnnA
loc ExprLStmt (GhcPass 'Renamed)
stmt HsExpr (GhcPass 'Renamed)
expansion
expand_do_stmts HsDoFlavour
do_or_lc (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
loc (LetStmt XLetStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
_ HsLocalBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
bs)) : [ExprLStmt (GhcPass 'Renamed)]
lstmts) =
do expand_stmts <- HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
do_or_lc [ExprLStmt (GhcPass 'Renamed)]
lstmts
let expansion = HsLocalBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
genHsLet HsLocalBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
bs LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
expand_stmts
return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts HsDoFlavour
do_or_lc (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
loc (BindStmt XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
xbsrn LPat (GhcPass 'Renamed)
pat LocatedA (HsExpr (GhcPass 'Renamed))
e)): [ExprLStmt (GhcPass 'Renamed)]
lstmts)
| SyntaxExprRn HsExpr (GhcPass 'Renamed)
bind_op <- XBindStmtRn -> SyntaxExpr (GhcPass 'Renamed)
xbsrn_bindOp XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
XBindStmtRn
xbsrn
, FailOperator (GhcPass 'Renamed)
fail_op <- XBindStmtRn -> FailOperator (GhcPass 'Renamed)
xbsrn_failOp XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
XBindStmtRn
xbsrn
= do expand_stmts <- HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
do_or_lc [ExprLStmt (GhcPass 'Renamed)]
lstmts
failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op
let expansion = HsExpr (GhcPass 'Renamed)
-> [LHsExpr (GhcPass 'Renamed)] -> HsExpr (GhcPass 'Renamed)
genHsExpApps HsExpr (GhcPass 'Renamed)
bind_op
[ LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
e
, LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
failable_expr ]
return $ mkExpandedStmtPopAt loc stmt expansion
| Bool
otherwise
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: The impossible happened, missing bind operator from renamer" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stmt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
stmt)
expand_do_stmts HsDoFlavour
do_or_lc (stmt :: ExprLStmt (GhcPass 'Renamed)
stmt@(L SrcSpanAnnA
loc (BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
_ LocatedA (HsExpr (GhcPass 'Renamed))
e (SyntaxExprRn HsExpr (GhcPass 'Renamed)
then_op) SyntaxExpr (GhcPass 'Renamed)
_)) : [ExprLStmt (GhcPass 'Renamed)]
lstmts) =
do expand_stmts_expr <- HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
do_or_lc [ExprLStmt (GhcPass 'Renamed)]
lstmts
let expansion = HsExpr (GhcPass 'Renamed)
-> [LHsExpr (GhcPass 'Renamed)] -> HsExpr (GhcPass 'Renamed)
genHsExpApps HsExpr (GhcPass 'Renamed)
then_op
[ LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
e
, LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
expand_stmts_expr ]
return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts HsDoFlavour
do_or_lc
((L SrcSpanAnnA
loc (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnLW
stmts_loc [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rec_stmts
, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP (GhcPass 'Renamed)]
later_ids
, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP (GhcPass 'Renamed)]
local_ids
, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExprRn HsExpr (GhcPass 'Renamed)
bind_fun
, recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExprRn HsExpr (GhcPass 'Renamed)
mfix_fun
, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExprRn HsExpr (GhcPass 'Renamed)
return_fun
}))
: [ExprLStmt (GhcPass 'Renamed)]
lstmts) =
do expand_stmts <- HsDoFlavour
-> [ExprLStmt (GhcPass 'Renamed)]
-> TcM (LHsExpr (GhcPass 'Renamed))
expand_do_stmts HsDoFlavour
do_or_lc [ExprLStmt (GhcPass 'Renamed)]
lstmts
return $ mkHsApps (wrapGenSpan bind_fun)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr
, genHsLamDoExp do_or_lc [ mkBigLHsVarPatTup all_ids ]
expand_stmts
]
where
local_only_ids :: [Name]
local_only_ids = [IdP (GhcPass 'Renamed)]
[Name]
local_ids [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [IdP (GhcPass 'Renamed)]
[Name]
later_ids
all_ids :: [Name]
all_ids = [Name]
local_only_ids [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [IdP (GhcPass 'Renamed)]
[Name]
later_ids
return_stmt :: ExprLStmt GhcRn
return_stmt :: ExprLStmt (GhcPass 'Renamed)
return_stmt = StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XLastStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> Maybe Bool
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField
([LHsExpr (GhcPass 'Renamed)]
-> XExplicitTuple (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
[LHsExpr (GhcPass id)]
-> XExplicitTuple (GhcPass id) -> LHsExpr (GhcPass id)
mkBigLHsTup ((Name -> LocatedA (HsExpr (GhcPass 'Renamed)))
-> [Name] -> [LocatedA (HsExpr (GhcPass 'Renamed))]
forall a b. (a -> b) -> [a] -> [b]
map IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
Name -> LocatedA (HsExpr (GhcPass 'Renamed))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [Name]
all_ids) XExplicitTuple (GhcPass 'Renamed)
NoExtField
noExtField)
Maybe Bool
forall a. Maybe a
Nothing
(HsExpr (GhcPass 'Renamed) -> SyntaxExprRn
SyntaxExprRn HsExpr (GhcPass 'Renamed)
return_fun)
do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
do_stmts :: XRec (GhcPass 'Renamed) [ExprLStmt (GhcPass 'Renamed)]
do_stmts = SrcSpanAnnLW
-> [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLW
stmts_loc ([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))])
-> [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
forall a b. (a -> b) -> a -> b
$ [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
rec_stmts [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))
return_stmt]
do_block :: LHsExpr GhcRn
do_block :: LHsExpr (GhcPass 'Renamed)
do_block = SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr (GhcPass 'Renamed) -> LocatedA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XDo (GhcPass 'Renamed)
-> HsDoFlavour
-> XRec (GhcPass 'Renamed) [ExprLStmt (GhcPass 'Renamed)]
-> HsExpr (GhcPass 'Renamed)
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo (GhcPass 'Renamed)
NoExtField
noExtField HsDoFlavour
do_or_lc XRec (GhcPass 'Renamed) [ExprLStmt (GhcPass 'Renamed)]
do_stmts
mfix_expr :: LHsExpr GhcRn
mfix_expr :: LHsExpr (GhcPass 'Renamed)
mfix_expr = HsDoFlavour
-> [LPat (GhcPass 'Renamed)]
-> LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
HsDoFlavour
-> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
genHsLamDoExp HsDoFlavour
do_or_lc [ Pat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan (XLazyPat (GhcPass 'Renamed)
-> LPat (GhcPass 'Renamed) -> Pat (GhcPass 'Renamed)
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat (GhcPass 'Renamed)
NoExtField
noExtField (LPat (GhcPass 'Renamed) -> Pat (GhcPass 'Renamed))
-> LPat (GhcPass 'Renamed) -> Pat (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ [IdP (GhcPass 'Renamed)] -> LPat (GhcPass 'Renamed)
mkBigLHsVarPatTup [IdP (GhcPass 'Renamed)]
[Name]
all_ids) ]
(LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed))
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Renamed)
do_block
expand_do_stmts HsDoFlavour
_ [ExprLStmt (GhcPass 'Renamed)]
stmts = String -> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_do_stmts: impossible happened" (SDoc -> TcM (LHsExpr (GhcPass 'Renamed)))
-> SDoc -> TcM (LHsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ ([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [ExprLStmt (GhcPass 'Renamed)]
[GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(LocatedA (HsExpr (GhcPass 'Renamed))))]
stmts)
mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_failable_expr :: HsDoFlavour
-> LPat (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> FailOperator (GhcPass 'Renamed)
-> TcM (LHsExpr (GhcPass 'Renamed))
mk_failable_expr HsDoFlavour
doFlav pat :: LPat (GhcPass 'Renamed)
pat@(L SrcSpanAnnA
loc Pat (GhcPass 'Renamed)
_) LHsExpr (GhcPass 'Renamed)
expr FailOperator (GhcPass 'Renamed)
fail_op =
do { is_strict <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.Strict
; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
; let irrf_pat = Bool
-> (ConLikeP (GhcPass 'Renamed) -> Bool)
-> LPat (GhcPass 'Renamed)
-> Bool
forall (p :: Pass).
IsPass p =>
Bool -> (ConLikeP (GhcPass p) -> Bool) -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat Bool
is_strict (HasDebugCallStack =>
HscEnv -> GlobalRdrEnv -> CompleteMatches -> Name -> Bool
HscEnv -> GlobalRdrEnv -> CompleteMatches -> Name -> Bool
irrefutableConLikeRn HscEnv
hscEnv GlobalRdrEnv
rdrEnv CompleteMatches
comps) LPat (GhcPass 'Renamed)
pat
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, text "isIrrefutable:" <+> ppr irrf_pat
])
; if irrf_pat
then return $ genHsLamDoExp doFlav [pat] expr
else L loc <$> mk_fail_block doFlav pat expr fail_op
}
mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
mk_fail_block :: HsDoFlavour
-> LPat (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> FailOperator (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr (GhcPass 'Renamed))
mk_fail_block HsDoFlavour
doFlav pat :: LPat (GhcPass 'Renamed)
pat@(L SrcSpanAnnA
ploc Pat (GhcPass 'Renamed)
_) LHsExpr (GhcPass 'Renamed)
e (Just (SyntaxExprRn HsExpr (GhcPass 'Renamed)
fail_op)) =
do dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav)
(wrapGenSpan [ genHsCaseAltDoExp doFlav pat e
, fail_alt_case dflags pat fail_op
])
where
fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
fail_alt_case :: DynFlags
-> LPat (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
-> LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
fail_alt_case DynFlags
dflags LPat (GhcPass 'Renamed)
pat HsExpr (GhcPass 'Renamed)
fail_op = HsDoFlavour
-> LPat (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnCO,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
HsDoFlavour
-> LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
genHsCaseAltDoExp HsDoFlavour
doFlav LPat (GhcPass 'Renamed)
genWildPat (LocatedA (HsExpr (GhcPass 'Renamed))
-> LMatch
(GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ploc (DynFlags
-> LPat (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
fail_op_expr DynFlags
dflags LPat (GhcPass 'Renamed)
pat HsExpr (GhcPass 'Renamed)
fail_op)
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
fail_op_expr :: DynFlags
-> LPat (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
fail_op_expr DynFlags
dflags LPat (GhcPass 'Renamed)
pat HsExpr (GhcPass 'Renamed)
fail_op
= LPat (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
mkExpandedPatRn LPat (GhcPass 'Renamed)
pat (HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$
HsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
genHsApp HsExpr (GhcPass 'Renamed)
fail_op (DynFlags -> LPat (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
mk_fail_msg_expr DynFlags
dflags LPat (GhcPass 'Renamed)
pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr :: DynFlags -> LPat (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
mk_fail_msg_expr DynFlags
dflags LPat (GhcPass 'Renamed)
pat
= HsLit (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (HsLit (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed))
-> HsLit (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ String -> HsLit (GhcPass 'Renamed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String -> HsLit (GhcPass 'Renamed))
-> String -> HsLit (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pattern match failure in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsDoFlavour -> SDoc
pprHsDoFlavour (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
pat)
mk_fail_block HsDoFlavour
_ LPat (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_ FailOperator (GhcPass 'Renamed)
_ = String
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mk_fail_block: impossible happened" SDoc
forall doc. IsOutput doc => doc
empty