{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module GHC.Rename.Pat (
rnPat, rnPats, rnBindPat,
NameMaker, applyNameMaker,
localRecNameMaker, topRecNameMaker,
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
rnHsRecUpdFields,
CpsRn, liftCps, liftCpsWithCont,
rnLit, rnOverLit,
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( hsOverLitName )
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkUnusedRecordWildcard
, checkDupNames, checkDupAndShadowedNames
, wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier )
import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Avail ( greNameMangledName )
import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.List.SetOps( removeDups )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Literal ( inCharRange )
import GHC.Builtin.Types ( nilDataCon )
import GHC.Core.DataCon
import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad ( when, ap, guard, unless )
import Data.Foldable
import Data.Functor.Identity ( Identity (..) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ratio
import GHC.Types.FieldLabel (DuplicateRecordFields(..))
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
newtype CpsRn b = CpsRn { forall b.
CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
unCpsRn :: forall r. (b -> RnM (r, FreeVars))
-> RnM (r, FreeVars) }
deriving ((forall a b. (a -> b) -> CpsRn a -> CpsRn b)
-> (forall a b. a -> CpsRn b -> CpsRn a) -> Functor CpsRn
forall a b. a -> CpsRn b -> CpsRn a
forall a b. (a -> b) -> CpsRn a -> CpsRn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CpsRn a -> CpsRn b
fmap :: forall a b. (a -> b) -> CpsRn a -> CpsRn b
$c<$ :: forall a b. a -> CpsRn b -> CpsRn a
<$ :: forall a b. a -> CpsRn b -> CpsRn a
Functor)
instance Applicative CpsRn where
pure :: forall a. a -> CpsRn a
pure a
x = (forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn a
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\a -> RnM (r, FreeVars)
k -> a -> RnM (r, FreeVars)
k a
x)
<*> :: forall a b. CpsRn (a -> b) -> CpsRn a -> CpsRn b
(<*>) = CpsRn (a -> b) -> CpsRn a -> CpsRn b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad CpsRn where
(CpsRn forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
m) >>= :: forall a b. CpsRn a -> (a -> CpsRn b) -> CpsRn b
>>= a -> CpsRn b
mk = (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\b -> RnM (r, FreeVars)
k -> (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
m (\a
v -> CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
forall b.
CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
unCpsRn (a -> CpsRn b
mk a
v) b -> RnM (r, FreeVars)
k))
runCps :: CpsRn a -> RnM (a, FreeVars)
runCps :: forall a. CpsRn a -> RnM (a, FreeVars)
runCps (CpsRn forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
m) = (a -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
m (\a
r -> (a, FreeVars) -> RnM (a, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, FreeVars
emptyFVs))
liftCps :: RnM a -> CpsRn a
liftCps :: forall a. RnM a -> CpsRn a
liftCps RnM a
rn_thing = (forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn a
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\a -> RnM (r, FreeVars)
k -> RnM a
rn_thing RnM a -> (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> RnM (r, FreeVars)
k)
liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
liftCpsFV :: forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV RnM (a, FreeVars)
rn_thing = (forall r. (a -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn a
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\a -> RnM (r, FreeVars)
k -> do { (a
v,FreeVars
fvs1) <- RnM (a, FreeVars)
rn_thing
; (r
r,FreeVars
fvs2) <- a -> RnM (r, FreeVars)
k a
v
; (r, FreeVars) -> RnM (r, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
r, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) })
liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b
liftCpsWithCont :: forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
liftCpsWithCont = (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn
wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
wrapSrcSpanCps :: forall a b. (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
wrapSrcSpanCps a -> CpsRn b
fn (L SrcSpanAnnA
loc a
a)
= (forall r. (LocatedA b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (LocatedA b)
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\LocatedA b -> RnM (r, FreeVars)
k -> SrcSpanAnnA -> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (RnM (r, FreeVars) -> RnM (r, FreeVars))
-> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a b. (a -> b) -> a -> b
$
CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
forall b.
CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
unCpsRn (a -> CpsRn b
fn a
a) ((b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
forall a b. (a -> b) -> a -> b
$ \b
v ->
LocatedA b -> RnM (r, FreeVars)
k (SrcSpanAnnA -> b -> LocatedA b
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc b
v))
lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name)
lookupConCps :: GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
lookupConCps GenLocated (SrcAnn NameAnn) RdrName
con_rdr
= (forall r.
(LocatedN Name -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (LocatedN Name)
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\LocatedN Name -> RnM (r, FreeVars)
k -> do { LocatedN Name
con_name <- GenLocated (SrcAnn NameAnn) RdrName -> TcRn (LocatedN Name)
forall ann.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRnConstr GenLocated (SrcAnn NameAnn) RdrName
con_rdr
; (r
r, FreeVars
fvs) <- LocatedN Name -> RnM (r, FreeVars)
k LocatedN Name
con_name
; (r, FreeVars) -> RnM (r, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
r, FreeVars -> Name -> FreeVars
addOneFV FreeVars
fvs (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN Name
con_name)) })
data NameMaker
= LamMk
Bool
| LetMk
TopLevelFlag
MiniFixityEnv
topRecNameMaker :: MiniFixityEnv -> NameMaker
topRecNameMaker :: MiniFixityEnv -> NameMaker
topRecNameMaker MiniFixityEnv
fix_env = TopLevelFlag -> MiniFixityEnv -> NameMaker
LetMk TopLevelFlag
TopLevel MiniFixityEnv
fix_env
isTopRecNameMaker :: NameMaker -> Bool
isTopRecNameMaker :: NameMaker -> Bool
isTopRecNameMaker (LetMk TopLevelFlag
TopLevel MiniFixityEnv
_) = Bool
True
isTopRecNameMaker NameMaker
_ = Bool
False
localRecNameMaker :: MiniFixityEnv -> NameMaker
localRecNameMaker :: MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env = TopLevelFlag -> MiniFixityEnv -> NameMaker
LetMk TopLevelFlag
NotTopLevel MiniFixityEnv
fix_env
matchNameMaker :: HsMatchContext a -> NameMaker
matchNameMaker :: forall a. HsMatchContext a -> NameMaker
matchNameMaker HsMatchContext a
ctxt = Bool -> NameMaker
LamMk Bool
report_unused
where
report_unused :: Bool
report_unused = case HsMatchContext a
ctxt of
StmtCtxt (HsDoStmt HsDoFlavour
GhciStmtCtxt) -> Bool
False
HsMatchContext a
ThPatQuote -> Bool
False
HsMatchContext a
_ -> Bool
True
newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name)
newPatLName :: NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
newPatLName NameMaker
name_maker rdr_name :: GenLocated (SrcAnn NameAnn) RdrName
rdr_name@(L SrcAnn NameAnn
loc RdrName
_)
= do { Name
name <- NameMaker -> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn Name
newPatName NameMaker
name_maker GenLocated (SrcAnn NameAnn) RdrName
rdr_name
; LocatedN Name -> CpsRn (LocatedN Name)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
loc Name
name) }
newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name
newPatName :: NameMaker -> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn Name
newPatName (LamMk Bool
report_unused) GenLocated (SrcAnn NameAnn) RdrName
rdr_name
= (forall r. (Name -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn Name
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\ Name -> RnM (r, FreeVars)
thing_inside ->
do { GenLocated (SrcAnn NameAnn) RdrName -> RnM ()
warnForallIdentifier GenLocated (SrcAnn NameAnn) RdrName
rdr_name
; Name
name <- GenLocated (SrcAnn NameAnn) RdrName -> RnM Name
newLocalBndrRn GenLocated (SrcAnn NameAnn) RdrName
rdr_name
; (r
res, FreeVars
fvs) <- [Name] -> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name
name] (Name -> RnM (r, FreeVars)
thing_inside Name
name)
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
report_unused (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$ [Name] -> FreeVars -> RnM ()
warnUnusedMatches [Name
name] FreeVars
fvs
; (r, FreeVars) -> RnM (r, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, Name
name Name -> FreeVars -> FreeVars
`delFV` FreeVars
fvs) })
newPatName (LetMk TopLevelFlag
is_top MiniFixityEnv
fix_env) GenLocated (SrcAnn NameAnn) RdrName
rdr_name
= (forall r. (Name -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn Name
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\ Name -> RnM (r, FreeVars)
thing_inside ->
do { GenLocated (SrcAnn NameAnn) RdrName -> RnM ()
warnForallIdentifier GenLocated (SrcAnn NameAnn) RdrName
rdr_name
; Name
name <- case TopLevelFlag
is_top of
TopLevelFlag
NotTopLevel -> GenLocated (SrcAnn NameAnn) RdrName -> RnM Name
newLocalBndrRn GenLocated (SrcAnn NameAnn) RdrName
rdr_name
TopLevelFlag
TopLevel -> GenLocated (SrcAnn NameAnn) RdrName -> RnM Name
newTopSrcBinder GenLocated (SrcAnn NameAnn) RdrName
rdr_name
; [Name] -> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name
name] (RnM (r, FreeVars) -> RnM (r, FreeVars))
-> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a b. (a -> b) -> a -> b
$
MiniFixityEnv -> [Name] -> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
fix_env [Name
name] (RnM (r, FreeVars) -> RnM (r, FreeVars))
-> RnM (r, FreeVars) -> RnM (r, FreeVars)
forall a b. (a -> b) -> a -> b
$
Name -> RnM (r, FreeVars)
thing_inside Name
name })
rnPats :: Traversable f
=> HsMatchContext GhcRn
-> f (LPat GhcPs)
-> (f (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPats :: forall (f :: * -> *) a.
Traversable f =>
HsMatchContext GhcRn
-> f (LPat GhcPs)
-> (f (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPats HsMatchContext GhcRn
ctxt f (LPat GhcPs)
pats f (LPat GhcRn) -> RnM (a, FreeVars)
thing_inside
= do { (GlobalRdrEnv, LocalRdrEnv)
envs_before <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
; CpsRn (f (GenLocated SrcSpanAnnA (Pat GhcRn)))
-> forall r.
(f (GenLocated SrcSpanAnnA (Pat GhcRn)) -> RnM (r, FreeVars))
-> RnM (r, FreeVars)
forall b.
CpsRn b -> forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)
unCpsRn (NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
forall (f :: * -> *).
Traversable f =>
NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen (HsMatchContext GhcRn -> NameMaker
forall a. HsMatchContext a -> NameMaker
matchNameMaker HsMatchContext GhcRn
ctxt) f (LPat GhcPs)
pats) ((f (GenLocated SrcSpanAnnA (Pat GhcRn)) -> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> (f (GenLocated SrcSpanAnnA (Pat GhcRn)) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ f (GenLocated SrcSpanAnnA (Pat GhcRn))
pats' -> do
{
; let bndrs :: [IdP GhcRn]
bndrs = CollectFlag GhcRn -> [LPat GhcRn] -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (f (GenLocated SrcSpanAnnA (Pat GhcRn))
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (GenLocated SrcSpanAnnA (Pat GhcRn))
pats')
; SDoc -> RnM () -> RnM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
doc_pat (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
if HsMatchContext GhcRn -> Bool
forall p. HsMatchContext p -> Bool
isPatSynCtxt HsMatchContext GhcRn
ctxt
then [Name] -> RnM ()
checkDupNames [IdP GhcRn]
[Name]
bndrs
else (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames (GlobalRdrEnv, LocalRdrEnv)
envs_before [IdP GhcRn]
[Name]
bndrs
; f (LPat GhcRn) -> RnM (a, FreeVars)
thing_inside f (LPat GhcRn)
f (GenLocated SrcSpanAnnA (Pat GhcRn))
pats' } }
where
doc_pat :: SDoc
doc_pat = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsMatchContext GhcRn -> SDoc
forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
ctxt
{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
rnPat :: HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat :: forall a.
HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat HsMatchContext GhcRn
ctxt LPat GhcPs
pat LPat GhcRn -> RnM (a, FreeVars)
thing_inside
= HsMatchContext GhcRn
-> Identity (LPat GhcPs)
-> (Identity (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall (f :: * -> *) a.
Traversable f =>
HsMatchContext GhcRn
-> f (LPat GhcPs)
-> (f (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPats HsMatchContext GhcRn
ctxt (GenLocated SrcSpanAnnA (Pat GhcPs)
-> Identity (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> Identity a
Identity LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat) (LPat GhcRn -> RnM (a, FreeVars)
GenLocated SrcSpanAnnA (Pat GhcRn) -> RnM (a, FreeVars)
thing_inside (GenLocated SrcSpanAnnA (Pat GhcRn) -> RnM (a, FreeVars))
-> (Identity (GenLocated SrcSpanAnnA (Pat GhcRn))
-> GenLocated SrcSpanAnnA (Pat GhcRn))
-> Identity (GenLocated SrcSpanAnnA (Pat GhcRn))
-> RnM (a, FreeVars)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (GenLocated SrcSpanAnnA (Pat GhcRn))
-> GenLocated SrcSpanAnnA (Pat GhcRn)
forall a. Identity a -> a
runIdentity)
applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name)
applyNameMaker :: NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName -> TcRn (LocatedN Name)
applyNameMaker NameMaker
mk GenLocated (SrcAnn NameAnn) RdrName
rdr = do { (LocatedN Name
n, FreeVars
_fvs) <- CpsRn (LocatedN Name) -> RnM (LocatedN Name, FreeVars)
forall a. CpsRn a -> RnM (a, FreeVars)
runCps (NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
newPatLName NameMaker
mk GenLocated (SrcAnn NameAnn) RdrName
rdr)
; LocatedN Name -> TcRn (LocatedN Name)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedN Name
n }
rnBindPat :: NameMaker
-> LPat GhcPs
-> RnM (LPat GhcRn, FreeVars)
rnBindPat :: NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, FreeVars)
rnBindPat NameMaker
name_maker LPat GhcPs
pat = CpsRn (GenLocated SrcSpanAnnA (Pat GhcRn))
-> RnM (GenLocated SrcSpanAnnA (Pat GhcRn), FreeVars)
forall a. CpsRn a -> RnM (a, FreeVars)
runCps (NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
name_maker LPat GhcPs
pat)
rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen :: forall (f :: * -> *).
Traversable f =>
NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen NameMaker
mk = (GenLocated SrcSpanAnnA (Pat GhcPs)
-> CpsRn (GenLocated SrcSpanAnnA (Pat GhcRn)))
-> f (GenLocated SrcSpanAnnA (Pat GhcPs))
-> CpsRn (f (GenLocated SrcSpanAnnA (Pat GhcRn)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f b)
mapM (NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk)
rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
nm LPat GhcPs
lpat = (Pat GhcPs -> CpsRn (Pat GhcRn))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> CpsRn (GenLocated SrcSpanAnnA (Pat GhcRn))
forall a b. (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
wrapSrcSpanCps (NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen NameMaker
nm) LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lpat
rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen NameMaker
_ (WildPat XWildPat GhcPs
_) = Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcRn -> Pat GhcRn
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcRn
NoExtField
noExtField)
rnPatAndThen NameMaker
mk (ParPat XParPat GhcPs
x LHsToken "(" GhcPs
lpar LPat GhcPs
pat LHsToken ")" GhcPs
rpar) =
do { GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParPat GhcRn
-> LHsToken "(" GhcRn
-> LPat GhcRn
-> LHsToken ")" GhcRn
-> Pat GhcRn
forall p.
XParPat p -> LHsToken "(" p -> LPat p -> LHsToken ")" p -> Pat p
ParPat XParPat GhcPs
XParPat GhcRn
x LHsToken "(" GhcPs
LHsToken "(" GhcRn
lpar LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat' LHsToken ")" GhcPs
LHsToken ")" GhcRn
rpar) }
rnPatAndThen NameMaker
mk (LazyPat XLazyPat GhcPs
_ LPat GhcPs
pat) = do { GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLazyPat GhcRn -> LPat GhcRn -> Pat GhcRn
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcRn
NoExtField
noExtField LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat') }
rnPatAndThen NameMaker
mk (BangPat XBangPat GhcPs
_ LPat GhcPs
pat) = do { GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XBangPat GhcRn -> LPat GhcRn -> Pat GhcRn
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcRn
NoExtField
noExtField LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat') }
rnPatAndThen NameMaker
mk (VarPat XVarPat GhcPs
x (L SrcAnn NameAnn
l RdrName
rdr))
= do { SrcSpan
loc <- RnM SrcSpan -> CpsRn SrcSpan
forall a. RnM a -> CpsRn a
liftCps RnM SrcSpan
getSrcSpanM
; Name
name <- NameMaker -> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn Name
newPatName NameMaker
mk (SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NameAnn
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
rdr)
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
XVarPat GhcRn
x (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
l Name
name)) }
rnPatAndThen NameMaker
mk (SigPat XSigPat GhcPs
_ LPat GhcPs
pat HsPatSigType (NoGhcTc GhcPs)
sig)
= do { HsPatSigType GhcRn
sig' <- HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
rnHsPatSigTypeAndThen HsPatSigType (NoGhcTc GhcPs)
HsPatSigType GhcPs
sig
; GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XSigPat GhcRn
-> LPat GhcRn -> HsPatSigType (NoGhcTc GhcRn) -> Pat GhcRn
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcRn
NoExtField
noExtField LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat' HsPatSigType (NoGhcTc GhcRn)
HsPatSigType GhcRn
sig' ) }
where
rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
rnHsPatSigTypeAndThen HsPatSigType GhcPs
sig = (forall r.
(HsPatSigType GhcRn -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (HsPatSigType GhcRn)
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
liftCpsWithCont (HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (r, FreeVars))
-> RnM (r, FreeVars)
forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsPatSigTypeScoping
AlwaysBind HsDocContext
PatCtx HsPatSigType GhcPs
sig)
rnPatAndThen NameMaker
mk (LitPat XLitPat GhcPs
x HsLit GhcPs
lit)
| HsString XHsString GhcPs
src FastString
s <- HsLit GhcPs
lit
= do { Bool
ovlStr <- RnM Bool -> CpsRn Bool
forall a. RnM a -> CpsRn a
liftCps (Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings)
; if Bool
ovlStr
then NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen NameMaker
mk
(LocatedAn NoEpAnns (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs
mkNPat (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a an. a -> LocatedAn an a
noLocA (SourceText -> FastString -> HsOverLit GhcPs
mkHsIsString XHsString GhcPs
SourceText
src FastString
s))
Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn)
else CpsRn (Pat GhcRn)
normal_lit }
| Bool
otherwise = CpsRn (Pat GhcRn)
normal_lit
where
normal_lit :: CpsRn (Pat GhcRn)
normal_lit = do { RnM () -> CpsRn ()
forall a. RnM a -> CpsRn a
liftCps (HsLit GhcPs -> RnM ()
forall p. HsLit p -> RnM ()
rnLit HsLit GhcPs
lit); Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitPat GhcRn -> HsLit GhcRn -> Pat GhcRn
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcPs
XLitPat GhcRn
x (HsLit GhcPs -> HsLit GhcRn
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcPs
lit)) }
rnPatAndThen NameMaker
_ (NPat XNPat GhcPs
x (L SrcAnn NoEpAnns
l HsOverLit GhcPs
lit) Maybe (SyntaxExpr GhcPs)
mb_neg SyntaxExpr GhcPs
_eq)
= do { (HsOverLit GhcRn
lit', Maybe (HsExpr GhcRn)
mb_neg') <- RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn))
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn)))
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ HsOverLit GhcPs
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall t.
(XXOverLit t ~ DataConCantHappen) =>
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit GhcPs
lit
; Maybe SyntaxExprRn
mb_neg'
<- let negative :: IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
negative = do { (SyntaxExprRn
neg, FreeVars
fvs) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
negateName
; (Maybe SyntaxExprRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExprRn -> Maybe SyntaxExprRn
forall a. a -> Maybe a
Just SyntaxExprRn
neg, FreeVars
fvs) }
positive :: IOEnv (Env TcGblEnv TcLclEnv) (Maybe a, FreeVars)
positive = (Maybe a, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe a, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, FreeVars
emptyFVs)
in IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
-> CpsRn (Maybe SyntaxExprRn)
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
-> CpsRn (Maybe SyntaxExprRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
-> CpsRn (Maybe SyntaxExprRn)
forall a b. (a -> b) -> a -> b
$ case (Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
mb_neg , Maybe (HsExpr GhcRn)
mb_neg') of
(Maybe NoExtField
Nothing, Just HsExpr GhcRn
_ ) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
negative
(Just NoExtField
_ , Maybe (HsExpr GhcRn)
Nothing) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
negative
(Maybe NoExtField
Nothing, Maybe (HsExpr GhcRn)
Nothing) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
forall {a}. IOEnv (Env TcGblEnv TcLclEnv) (Maybe a, FreeVars)
positive
(Just NoExtField
_ , Just HsExpr GhcRn
_ ) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe SyntaxExprRn, FreeVars)
forall {a}. IOEnv (Env TcGblEnv TcLclEnv) (Maybe a, FreeVars)
positive
; SyntaxExprRn
eq' <- RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn))
-> RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
eqName
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNPat GhcRn
-> XRec GhcRn (HsOverLit GhcRn)
-> Maybe (SyntaxExpr GhcRn)
-> SyntaxExpr GhcRn
-> Pat GhcRn
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
NPat XNPat GhcPs
XNPat GhcRn
x (SrcAnn NoEpAnns
-> HsOverLit GhcRn
-> GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l HsOverLit GhcRn
lit') Maybe (SyntaxExpr GhcRn)
Maybe SyntaxExprRn
mb_neg' SyntaxExpr GhcRn
SyntaxExprRn
eq') }
rnPatAndThen NameMaker
mk (NPlusKPat XNPlusKPat GhcPs
_ XRec GhcPs (IdP GhcPs)
rdr (L SrcAnn NoEpAnns
l HsOverLit GhcPs
lit) HsOverLit GhcPs
_ SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_ )
= do { Name
new_name <- NameMaker -> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn Name
newPatName NameMaker
mk (GenLocated (SrcAnn NameAnn) RdrName
-> GenLocated (SrcAnn NameAnn) RdrName
forall a1 a2. LocatedAn a1 a2 -> LocatedN a2
l2n XRec GhcPs (IdP GhcPs)
GenLocated (SrcAnn NameAnn) RdrName
rdr)
; (HsOverLit GhcRn
lit', Maybe (HsExpr GhcRn)
_) <- RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn))
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn)))
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> CpsRn (HsOverLit GhcRn, Maybe (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ HsOverLit GhcPs
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall t.
(XXOverLit t ~ DataConCantHappen) =>
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit GhcPs
lit
; SyntaxExprRn
minus <- RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn))
-> RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
minusName
; SyntaxExprRn
ge <- RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn))
-> RnM (SyntaxExpr GhcRn, FreeVars) -> CpsRn (SyntaxExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
geName
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNPlusKPat GhcRn
-> LIdP GhcRn
-> XRec GhcRn (HsOverLit GhcRn)
-> HsOverLit GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> Pat GhcRn
forall p.
XNPlusKPat p
-> LIdP p
-> XRec p (HsOverLit p)
-> HsOverLit p
-> SyntaxExpr p
-> SyntaxExpr p
-> Pat p
NPlusKPat XNPlusKPat GhcRn
NoExtField
noExtField (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NameAnn
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcAnn NameAnn) -> SrcSpan -> SrcAnn NameAnn
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
nameSrcSpan Name
new_name) Name
new_name)
(SrcAnn NoEpAnns
-> HsOverLit GhcRn
-> GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l HsOverLit GhcRn
lit') HsOverLit GhcRn
lit' SyntaxExpr GhcRn
SyntaxExprRn
ge SyntaxExpr GhcRn
SyntaxExprRn
minus) }
rnPatAndThen NameMaker
mk (AsPat XAsPat GhcPs
_ XRec GhcPs (IdP GhcPs)
rdr LHsToken "@" GhcPs
at LPat GhcPs
pat)
= do { LocatedN Name
new_name <- NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
newPatLName NameMaker
mk XRec GhcPs (IdP GhcPs)
GenLocated (SrcAnn NameAnn) RdrName
rdr
; GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XAsPat GhcRn
-> LIdP GhcRn -> LHsToken "@" GhcRn -> LPat GhcRn -> Pat GhcRn
forall p. XAsPat p -> LIdP p -> LHsToken "@" p -> LPat p -> Pat p
AsPat XAsPat GhcRn
NoExtField
noExtField LIdP GhcRn
LocatedN Name
new_name LHsToken "@" GhcPs
LHsToken "@" GhcRn
at LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat') }
rnPatAndThen NameMaker
mk p :: Pat GhcPs
p@(ViewPat XViewPat GhcPs
_ LHsExpr GhcPs
expr LPat GhcPs
pat)
= do { RnM () -> CpsRn ()
forall a. RnM a -> CpsRn a
liftCps (RnM () -> CpsRn ()) -> RnM () -> CpsRn ()
forall a b. (a -> b) -> a -> b
$ do { Bool
vp_flag <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ViewPatterns
; Bool -> TcRnMessage -> RnM ()
checkErr Bool
vp_flag (Pat GhcPs -> TcRnMessage
TcRnIllegalViewPattern Pat GhcPs
p) }
; GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr' <- RnM (LHsExpr GhcRn, FreeVars) -> CpsRn (LHsExpr GhcRn)
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM (LHsExpr GhcRn, FreeVars) -> CpsRn (LHsExpr GhcRn))
-> RnM (LHsExpr GhcRn, FreeVars) -> CpsRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
; GenLocated SrcSpanAnnA (Pat GhcRn)
pat' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XViewPat GhcRn -> LHsExpr GhcRn -> LPat GhcRn -> Pat GhcRn
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat Maybe (HsExpr GhcRn)
XViewPat GhcRn
forall a. Maybe a
Nothing LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr' LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat') }
rnPatAndThen NameMaker
mk (ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
con HsConPatDetails GhcPs
args)
= case GenLocated (SrcAnn NameAnn) RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (ConLikeP GhcPs)
GenLocated (SrcAnn NameAnn) RdrName
con RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName (DataCon -> Name
dataConName DataCon
nilDataCon) of
Bool
True -> do { Bool
ol_flag <- RnM Bool -> CpsRn Bool
forall a. RnM a -> CpsRn a
liftCps (RnM Bool -> CpsRn Bool) -> RnM Bool -> CpsRn Bool
forall a b. (a -> b) -> a -> b
$ Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
; if Bool
ol_flag then NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen NameMaker
mk (XListPat GhcPs -> [LPat GhcPs] -> Pat GhcPs
forall p. XListPat p -> [LPat p] -> Pat p
ListPat XListPat GhcPs
EpAnn AnnList
forall a. EpAnn a
noAnn [])
else NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen NameMaker
mk XRec GhcPs (ConLikeP GhcPs)
GenLocated (SrcAnn NameAnn) RdrName
con HsConPatDetails GhcPs
args}
Bool
False -> NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen NameMaker
mk XRec GhcPs (ConLikeP GhcPs)
GenLocated (SrcAnn NameAnn) RdrName
con HsConPatDetails GhcPs
args
rnPatAndThen NameMaker
mk (ListPat XListPat GhcPs
_ [LPat GhcPs]
pats)
= do { Bool
opt_OverloadedLists <- RnM Bool -> CpsRn Bool
forall a. RnM a -> CpsRn a
liftCps (RnM Bool -> CpsRn Bool) -> RnM Bool -> CpsRn Bool
forall a b. (a -> b) -> a -> b
$ Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
; [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats' <- NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
forall (f :: * -> *).
Traversable f =>
NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen NameMaker
mk [LPat GhcPs]
pats
; if Bool -> Bool
not Bool
opt_OverloadedLists
then Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XListPat GhcRn -> [LPat GhcRn] -> Pat GhcRn
forall p. XListPat p -> [LPat p] -> Pat p
ListPat XListPat GhcRn
NoExtField
noExtField [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats')
else
do { (Name
to_list_name,FreeVars
_) <- RnM (Name, FreeVars) -> CpsRn (Name, FreeVars)
forall a. RnM a -> CpsRn a
liftCps (RnM (Name, FreeVars) -> CpsRn (Name, FreeVars))
-> RnM (Name, FreeVars) -> CpsRn (Name, FreeVars)
forall a b. (a -> b) -> a -> b
$ Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
toListName
; (Name
from_list_n_name,FreeVars
_) <- RnM (Name, FreeVars) -> CpsRn (Name, FreeVars)
forall a. RnM a -> CpsRn a
liftCps (RnM (Name, FreeVars) -> CpsRn (Name, FreeVars))
-> RnM (Name, FreeVars) -> CpsRn (Name, FreeVars)
forall a b. (a -> b) -> a -> b
$ Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
fromListNName
; let
lit_n :: IntegralLit
lit_n = Int -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)
hs_lit :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hs_lit = IntegralLit -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an. IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit IntegralLit
lit_n
inverse :: HsExpr GhcRn
inverse = Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps Name
from_list_n_name [LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
hs_lit]
rn_list_pat :: Pat GhcRn
rn_list_pat = XListPat GhcRn -> [LPat GhcRn] -> Pat GhcRn
forall p. XListPat p -> [LPat p] -> Pat p
ListPat XListPat GhcRn
NoExtField
noExtField [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats'
exp_expr :: LHsExpr GhcRn
exp_expr = Name -> LHsExpr GhcRn
genLHsVar Name
to_list_name
exp_list_pat :: Pat GhcRn
exp_list_pat = XViewPat GhcRn -> LHsExpr GhcRn -> LPat GhcRn -> Pat GhcRn
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
inverse) LHsExpr GhcRn
exp_expr (Pat GhcRn -> GenLocated SrcSpanAnnA (Pat GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan Pat GhcRn
rn_list_pat)
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> CpsRn (Pat GhcRn)) -> Pat GhcRn -> CpsRn (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ Pat GhcRn -> Pat GhcRn -> Pat GhcRn
mkExpandedPat Pat GhcRn
rn_list_pat Pat GhcRn
exp_list_pat }}
rnPatAndThen NameMaker
mk (TuplePat XTuplePat GhcPs
_ [LPat GhcPs]
pats Boxity
boxed)
= do { [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats' <- NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
forall (f :: * -> *).
Traversable f =>
NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen NameMaker
mk [LPat GhcPs]
pats
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTuplePat GhcRn -> [LPat GhcRn] -> Boxity -> Pat GhcRn
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat XTuplePat GhcRn
NoExtField
noExtField [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
pats' Boxity
boxed) }
rnPatAndThen NameMaker
mk (SumPat XSumPat GhcPs
_ LPat GhcPs
pat Int
alt Int
arity)
= do { GenLocated SrcSpanAnnA (Pat GhcRn)
pat <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XSumPat GhcRn -> LPat GhcRn -> Int -> Int -> Pat GhcRn
forall p. XSumPat p -> LPat p -> Int -> Int -> Pat p
SumPat XSumPat GhcRn
NoExtField
noExtField LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat Int
alt Int
arity)
}
rnPatAndThen NameMaker
mk (SplicePat XSplicePat GhcPs
_ HsUntypedSplice GhcPs
splice)
= do { (HsUntypedSplice GhcRn,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs)))
eith <- RnM
((HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)),
FreeVars)
-> CpsRn
(HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM
((HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)),
FreeVars)
-> CpsRn
(HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)))
-> RnM
((HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)),
FreeVars)
-> CpsRn
(HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
forall a b. (a -> b) -> a -> b
$ HsUntypedSplice GhcPs
-> RnM
((HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)),
FreeVars)
rnSplicePat HsUntypedSplice GhcPs
splice
; case (HsUntypedSplice GhcRn,
HsUntypedSpliceResult (GenLocated SrcSpanAnnA (Pat GhcPs)))
eith of
(HsUntypedSplice GhcRn
rn_splice, HsUntypedSpliceTop ThModFinalizers
mfs GenLocated SrcSpanAnnA (Pat GhcPs)
pat) ->
LPat GhcRn -> Pat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn
forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn)
-> (GenLocated SrcSpanAnnA (Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn))
-> GenLocated SrcSpanAnnA (Pat GhcRn)
-> Pat GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pat GhcRn -> Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn)
-> GenLocated SrcSpanAnnA (Pat GhcRn)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsUntypedSpliceResult (Pat GhcRn)
-> HsUntypedSplice GhcRn -> Pat GhcRn)
-> HsUntypedSplice GhcRn
-> HsUntypedSpliceResult (Pat GhcRn)
-> Pat GhcRn
forall a b c. (a -> b -> c) -> b -> a -> c
flip XSplicePat GhcRn -> HsUntypedSplice GhcRn -> Pat GhcRn
HsUntypedSpliceResult (Pat GhcRn)
-> HsUntypedSplice GhcRn -> Pat GhcRn
forall p. XSplicePat p -> HsUntypedSplice p -> Pat p
SplicePat HsUntypedSplice GhcRn
rn_splice (HsUntypedSpliceResult (Pat GhcRn) -> Pat GhcRn)
-> (Pat GhcRn -> HsUntypedSpliceResult (Pat GhcRn))
-> Pat GhcRn
-> Pat GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThModFinalizers -> Pat GhcRn -> HsUntypedSpliceResult (Pat GhcRn)
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ThModFinalizers
mfs)) (GenLocated SrcSpanAnnA (Pat GhcRn) -> Pat GhcRn)
-> CpsRn (GenLocated SrcSpanAnnA (Pat GhcRn)) -> CpsRn (Pat GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat
(HsUntypedSplice GhcRn
rn_splice, HsUntypedSpliceNested Name
splice_name) -> Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (XSplicePat GhcRn -> HsUntypedSplice GhcRn -> Pat GhcRn
forall p. XSplicePat p -> HsUntypedSplice p -> Pat p
SplicePat (Name -> HsUntypedSpliceResult (Pat GhcRn)
forall thing. Name -> HsUntypedSpliceResult thing
HsUntypedSpliceNested Name
splice_name) HsUntypedSplice GhcRn
rn_splice)
}
rnConPatAndThen :: NameMaker
-> LocatedN RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen :: NameMaker
-> GenLocated (SrcAnn NameAnn) RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen NameMaker
mk GenLocated (SrcAnn NameAnn) RdrName
con (PrefixCon [HsConPatTyArg (NoGhcTc GhcPs)]
tyargs [LPat GhcPs]
pats)
= do { LocatedN Name
con' <- GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
lookupConCps GenLocated (SrcAnn NameAnn) RdrName
con
; RnM () -> CpsRn ()
forall a. RnM a -> CpsRn a
liftCps RnM ()
check_lang_exts
; [HsConPatTyArg GhcRn]
tyargs' <- (HsConPatTyArg GhcPs -> CpsRn (HsConPatTyArg GhcRn))
-> [HsConPatTyArg GhcPs] -> CpsRn [HsConPatTyArg GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsConPatTyArg GhcPs -> CpsRn (HsConPatTyArg GhcRn)
rnConPatTyArg [HsConPatTyArg (NoGhcTc GhcPs)]
[HsConPatTyArg GhcPs]
tyargs
; [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats' <- NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
forall (f :: * -> *).
Traversable f =>
NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
rnLPatsAndThen NameMaker
mk [LPat GhcPs]
pats
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> CpsRn (Pat GhcRn)) -> Pat GhcRn -> CpsRn (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = XConPat GhcRn
NoExtField
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = XRec GhcRn (ConLikeP GhcRn)
LocatedN Name
con'
, pat_args :: HsConPatDetails GhcRn
pat_args = [HsConPatTyArg GhcRn]
-> [GenLocated SrcSpanAnnA (Pat GhcRn)]
-> HsConDetails
(HsConPatTyArg GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcRn))
(HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsConPatTyArg GhcRn]
tyargs' [GenLocated SrcSpanAnnA (Pat GhcRn)]
pats'
}
}
where
check_lang_exts :: RnM ()
check_lang_exts :: RnM ()
check_lang_exts = do
Bool
scoped_tyvars <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
Bool
type_app <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
scoped_tyvars Bool -> Bool -> Bool
&& Bool
type_app) (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$
case [HsConPatTyArg GhcPs] -> Maybe (HsConPatTyArg GhcPs)
forall a. [a] -> Maybe a
listToMaybe [HsConPatTyArg (NoGhcTc GhcPs)]
[HsConPatTyArg GhcPs]
tyargs of
Maybe (HsConPatTyArg GhcPs)
Nothing -> () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just HsConPatTyArg GhcPs
tyarg -> TcRnMessage -> RnM ()
addErr (TcRnMessage -> RnM ()) -> TcRnMessage -> RnM ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal visible type application in a pattern:"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (HsConPatTyArg GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsConPatTyArg GhcPs
tyarg))
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Both ScopedTypeVariables and TypeApplications are"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"required to use this feature")
rnConPatTyArg :: HsConPatTyArg GhcPs -> CpsRn (HsConPatTyArg GhcRn)
rnConPatTyArg (HsConPatTyArg LHsToken "@" GhcPs
at HsPatSigType GhcPs
t) = do
HsPatSigType GhcRn
t' <- (forall r.
(HsPatSigType GhcRn -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (HsPatSigType GhcRn)
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
liftCpsWithCont ((forall r.
(HsPatSigType GhcRn -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (HsPatSigType GhcRn))
-> (forall r.
(HsPatSigType GhcRn -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn (HsPatSigType GhcRn)
forall a b. (a -> b) -> a -> b
$ HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (r, FreeVars))
-> IOEnv (Env TcGblEnv TcLclEnv) (r, FreeVars)
forall r.
HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (r, FreeVars))
-> RnM (r, FreeVars)
rnHsPatSigTypeBindingVars HsDocContext
HsTypeCtx HsPatSigType GhcPs
t
HsConPatTyArg GhcRn -> CpsRn (HsConPatTyArg GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsToken "@" GhcRn -> HsPatSigType GhcRn -> HsConPatTyArg GhcRn
forall p. LHsToken "@" p -> HsPatSigType p -> HsConPatTyArg p
HsConPatTyArg LHsToken "@" GhcPs
LHsToken "@" GhcRn
at HsPatSigType GhcRn
t')
rnConPatAndThen NameMaker
mk GenLocated (SrcAnn NameAnn) RdrName
con (InfixCon LPat GhcPs
pat1 LPat GhcPs
pat2)
= do { LocatedN Name
con' <- GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
lookupConCps GenLocated (SrcAnn NameAnn) RdrName
con
; GenLocated SrcSpanAnnA (Pat GhcRn)
pat1' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat1
; GenLocated SrcSpanAnnA (Pat GhcRn)
pat2' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen NameMaker
mk LPat GhcPs
pat2
; Fixity
fixity <- RnM Fixity -> CpsRn Fixity
forall a. RnM a -> CpsRn a
liftCps (RnM Fixity -> CpsRn Fixity) -> RnM Fixity -> CpsRn Fixity
forall a b. (a -> b) -> a -> b
$ Name -> RnM Fixity
lookupFixityRn (LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc LocatedN Name
con')
; RnM (Pat GhcRn) -> CpsRn (Pat GhcRn)
forall a. RnM a -> CpsRn a
liftCps (RnM (Pat GhcRn) -> CpsRn (Pat GhcRn))
-> RnM (Pat GhcRn) -> CpsRn (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ LocatedN Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn LocatedN Name
con' Fixity
fixity LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat1' LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat2' }
rnConPatAndThen NameMaker
mk GenLocated (SrcAnn NameAnn) RdrName
con (RecCon HsRecFields GhcPs (LPat GhcPs)
rpats)
= do { LocatedN Name
con' <- GenLocated (SrcAnn NameAnn) RdrName -> CpsRn (LocatedN Name)
lookupConCps GenLocated (SrcAnn NameAnn) RdrName
con
; HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))
rpats' <- NameMaker
-> LocatedN Name
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
rnHsRecPatsAndThen NameMaker
mk LocatedN Name
con' HsRecFields GhcPs (LPat GhcPs)
rpats
; Pat GhcRn -> CpsRn (Pat GhcRn)
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> CpsRn (Pat GhcRn)) -> Pat GhcRn -> CpsRn (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcRn
pat_con_ext = XConPat GhcRn
NoExtField
noExtField
, pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con = XRec GhcRn (ConLikeP GhcRn)
LocatedN Name
con'
, pat_args :: HsConPatDetails GhcRn
pat_args = HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))
-> HsConDetails
(HsConPatTyArg GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcRn))
(HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn)))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))
rpats'
}
}
checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps SrcSpan
loc Maybe [Name]
dotdot_names =
(forall r. (() -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn ()
forall b.
(forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars))
-> CpsRn b
CpsRn (\() -> RnM (r, FreeVars)
thing -> do
(r
r, FreeVars
fvs) <- () -> RnM (r, FreeVars)
thing ()
SrcSpan -> FreeVars -> Maybe [Name] -> RnM ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
fvs Maybe [Name]
dotdot_names
(r, FreeVars) -> RnM (r, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
r, FreeVars
fvs) )
rnHsRecPatsAndThen :: NameMaker
-> LocatedN Name
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
rnHsRecPatsAndThen :: NameMaker
-> LocatedN Name
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
rnHsRecPatsAndThen NameMaker
mk (L SrcAnn NameAnn
_ Name
con)
hs_rec_fields :: HsRecFields GhcPs (LPat GhcPs)
hs_rec_fields@(HsRecFields { rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (XRec p RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
dd })
= do { [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))]
flds <- RnM
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))],
FreeVars)
-> CpsRn
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))]
forall a. RnM (a, FreeVars) -> CpsRn a
liftCpsFV (RnM
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))],
FreeVars)
-> CpsRn
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))])
-> RnM
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))],
FreeVars)
-> CpsRn
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))]
forall a b. (a -> b) -> a -> b
$ HsRecFieldContext
-> (SrcSpan -> RdrName -> Pat GhcPs)
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))
-> RnM
([LHsRecField GhcRn (GenLocated SrcSpanAnnA (Pat GhcPs))],
FreeVars)
forall arg.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields GhcPs (LocatedA arg)
-> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
rnHsRecFields (Name -> HsRecFieldContext
HsRecFieldPat Name
con) SrcSpan -> IdP GhcPs -> Pat GhcPs
SrcSpan -> RdrName -> Pat GhcPs
forall {p} {ann}.
(XVarPat p ~ NoExtField,
XRec p (IdP p) ~ GenLocated (SrcAnn ann) (IdP p)) =>
SrcSpan -> IdP p -> Pat p
mkVarPat
HsRecFields GhcPs (LPat GhcPs)
HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))
hs_rec_fields
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
flds' <- ((GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))),
Int)
-> CpsRn
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))))
-> [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))),
Int)]
-> CpsRn
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))),
Int)
-> CpsRn
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))))
rn_field ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))]
flds [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs)))]
-> [Int]
-> [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))),
Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
1..])
; Maybe [Name] -> CpsRn ()
check_unused_wildcard ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LPat GhcRn))]
-> GenLocated SrcSpan RecFieldsDotDot -> [IdP GhcRn]
forall {p} {l} {lhs} {l}.
CollectPass p =>
[GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
-> GenLocated l RecFieldsDotDot -> [IdP p]
implicit_binders [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LPat GhcRn))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
flds' (GenLocated SrcSpan RecFieldsDotDot -> [Name])
-> Maybe (GenLocated SrcSpan RecFieldsDotDot) -> Maybe [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (GenLocated SrcSpan RecFieldsDotDot)
dd)
; HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))
-> CpsRn (HsRecFields GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn)))
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRecFields { rec_flds :: [LHsRecField GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))]
rec_flds = [LHsRecField GhcRn (GenLocated SrcSpanAnnA (Pat GhcRn))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))]
flds', rec_dotdot :: Maybe (XRec GhcRn RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (XRec GhcRn RecFieldsDotDot)
dd }) }
where
mkVarPat :: SrcSpan -> IdP p -> Pat p
mkVarPat SrcSpan
l IdP p
n = XVarPat p -> XRec p (IdP p) -> Pat p
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat p
NoExtField
noExtField (SrcAnn ann -> IdP p -> GenLocated (SrcAnn ann) (IdP p)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn ann
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) IdP p
n)
rn_field :: (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))),
Int)
-> CpsRn
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))))
rn_field (L SrcSpanAnnA
l HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))
fld, Int
n') =
do { GenLocated SrcSpanAnnA (Pat GhcRn)
arg' <- NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen (Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> NameMaker -> RecFieldsDotDot -> NameMaker
forall {a} {l}.
Ord a =>
Maybe (GenLocated l a) -> NameMaker -> a -> NameMaker
nested_mk Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (GenLocated SrcSpan RecFieldsDotDot)
dd NameMaker
mk (Int -> RecFieldsDotDot
RecFieldsDotDot Int
n')) (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))
fld)
; GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))
-> CpsRn
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))))
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (Pat GhcPs))
fld { hfbRHS = arg' })) }
loc :: SrcSpan
loc = SrcSpan
-> (GenLocated SrcSpan RecFieldsDotDot -> SrcSpan)
-> Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> SrcSpan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SrcSpan
noSrcSpan GenLocated SrcSpan RecFieldsDotDot -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (GenLocated SrcSpan RecFieldsDotDot)
dd
implicit_binders :: [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
-> GenLocated l RecFieldsDotDot -> [IdP p]
implicit_binders [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
fs (GenLocated l RecFieldsDotDot -> RecFieldsDotDot
forall l e. GenLocated l e -> e
unLoc -> RecFieldsDotDot Int
n) = CollectFlag p -> [XRec p (Pat p)] -> [IdP p]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag p
forall p. CollectFlag p
CollNoDictBinders [XRec p (Pat p)]
implicit_pats
where
implicit_pats :: [XRec p (Pat p)]
implicit_pats = (GenLocated l (HsFieldBind lhs (XRec p (Pat p))) -> XRec p (Pat p))
-> [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
-> [XRec p (Pat p)]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind lhs (XRec p (Pat p)) -> XRec p (Pat p)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS (HsFieldBind lhs (XRec p (Pat p)) -> XRec p (Pat p))
-> (GenLocated l (HsFieldBind lhs (XRec p (Pat p)))
-> HsFieldBind lhs (XRec p (Pat p)))
-> GenLocated l (HsFieldBind lhs (XRec p (Pat p)))
-> XRec p (Pat p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (HsFieldBind lhs (XRec p (Pat p)))
-> HsFieldBind lhs (XRec p (Pat p))
forall l e. GenLocated l e -> e
unLoc) (Int
-> [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
-> [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
forall a. Int -> [a] -> [a]
drop Int
n [GenLocated l (HsFieldBind lhs (XRec p (Pat p)))]
fs)
check_unused_wildcard :: Maybe [Name] -> CpsRn ()
check_unused_wildcard = case NameMaker
mk of
LetMk{} -> CpsRn () -> Maybe [Name] -> CpsRn ()
forall a b. a -> b -> a
const (() -> CpsRn ()
forall a. a -> CpsRn a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
LamMk{} -> SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps SrcSpan
loc
nested_mk :: Maybe (GenLocated l a) -> NameMaker -> a -> NameMaker
nested_mk Maybe (GenLocated l a)
Nothing NameMaker
mk a
_ = NameMaker
mk
nested_mk (Just GenLocated l a
_) mk :: NameMaker
mk@(LetMk {}) a
_ = NameMaker
mk
nested_mk (Just (GenLocated l a -> a
forall l e. GenLocated l e -> e
unLoc -> a
n)) (LamMk Bool
report_unused) a
n'
= Bool -> NameMaker
LamMk (Bool
report_unused Bool -> Bool -> Bool
&& (a
n' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
n))
mkExpandedPat
:: Pat GhcRn
-> Pat GhcRn
-> Pat GhcRn
mkExpandedPat :: Pat GhcRn -> Pat GhcRn -> Pat GhcRn
mkExpandedPat Pat GhcRn
a Pat GhcRn
b = XXPat GhcRn -> Pat GhcRn
forall p. XXPat p -> Pat p
XPat (Pat GhcRn -> Pat GhcRn -> HsPatExpansion (Pat GhcRn) (Pat GhcRn)
forall a b. a -> b -> HsPatExpansion a b
HsPatExpanded Pat GhcRn
a Pat GhcRn
b)
data HsRecFieldContext
= HsRecFieldCon Name
| HsRecFieldPat Name
| HsRecFieldUpd
rnHsRecFields
:: forall arg.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields GhcPs (LocatedA arg)
-> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
rnHsRecFields :: forall arg.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields GhcPs (LocatedA arg)
-> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
rnHsRecFields HsRecFieldContext
ctxt SrcSpan -> RdrName -> arg
mk_arg (HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcPs (LocatedA arg)]
flds, rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (XRec p RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
dotdot })
= do { Bool
pun_ok <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedFieldPuns
; Bool
disambig_ok <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DisambiguateRecordFields
; let parent :: Maybe Name
parent = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
disambig_ok Maybe () -> Maybe Name -> Maybe Name
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mb_con
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
flds1 <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA arg))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA arg))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool
-> Maybe Name
-> LHsRecField GhcPs (LocatedA arg)
-> RnM (LHsRecField GhcRn (LocatedA arg))
rn_fld Bool
pun_ok Maybe Name
parent) [LHsRecField GhcPs (LocatedA arg)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA arg))]
flds
; (NonEmpty RdrName -> RnM ()) -> [NonEmpty RdrName] -> RnM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> RnM ()
addErr (TcRnMessage -> RnM ())
-> (NonEmpty RdrName -> TcRnMessage) -> NonEmpty RdrName -> RnM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecFieldContext -> NonEmpty RdrName -> TcRnMessage
dupFieldErr HsRecFieldContext
ctxt) [NonEmpty RdrName]
dup_flds
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
dotdot_flds <- Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> Maybe Name
-> [LHsRecField GhcRn (LocatedA arg)]
-> RnM [LHsRecField GhcRn (LocatedA arg)]
rn_dotdot Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (GenLocated SrcSpan RecFieldsDotDot)
dotdot Maybe Name
mb_con [LHsRecField GhcRn (LocatedA arg)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
flds1
; let all_flds :: [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
all_flds | [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
dotdot_flds = [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
flds1
| Bool
otherwise = [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
flds1 [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
dotdot_flds
; ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
all_flds, [Name] -> FreeVars
mkFVs ([LHsRecField GhcRn (LocatedA arg)] -> [Name]
forall arg. [LHsRecField GhcRn arg] -> [Name]
getFieldIds [LHsRecField GhcRn (LocatedA arg)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
all_flds)) }
where
mb_con :: Maybe Name
mb_con = case HsRecFieldContext
ctxt of
HsRecFieldCon Name
con -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
con
HsRecFieldPat Name
con -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
con
HsRecFieldContext
_ -> Maybe Name
forall a. Maybe a
Nothing
rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)
-> RnM (LHsRecField GhcRn (LocatedA arg))
rn_fld :: Bool
-> Maybe Name
-> LHsRecField GhcPs (LocatedA arg)
-> RnM (LHsRecField GhcRn (LocatedA arg))
rn_fld Bool
pun_ok Maybe Name
parent (L SrcSpanAnnA
l
(HsFieldBind
{ hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS =
(L SrcAnn NoEpAnns
loc (FieldOcc XCFieldOcc GhcPs
_ (L SrcAnn NameAnn
ll RdrName
lbl)))
, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = LocatedA arg
arg
, hfbPun :: forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun = Bool
pun }))
= do { Name
sel <- SrcAnn NoEpAnns -> RnM Name -> RnM Name
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc (RnM Name -> RnM Name) -> RnM Name -> RnM Name
forall a b. (a -> b) -> a -> b
$ Maybe Name -> RdrName -> RnM Name
lookupRecFieldOcc Maybe Name
parent RdrName
lbl
; LocatedA arg
arg' <- if Bool
pun
then do { Bool -> TcRnMessage -> RnM ()
checkErr Bool
pun_ok (Located RdrName -> TcRnMessage
TcRnIllegalFieldPunning (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc) RdrName
lbl))
; let arg_rdr :: RdrName
arg_rdr = OccName -> RdrName
mkRdrUnqual (RdrName -> OccName
rdrNameOcc RdrName
lbl)
; LocatedA arg -> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA arg)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> arg -> LocatedA arg
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) (SrcSpan -> RdrName -> arg
mk_arg (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc) RdrName
arg_rdr)) }
else LocatedA arg -> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA arg)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA arg
arg
; GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg)
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
hfbAnn = XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
hfbLHS = (SrcAnn NoEpAnns
-> FieldOcc GhcRn -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc (XCFieldOcc GhcRn -> XRec GhcRn RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcRn
Name
sel (SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
ll RdrName
lbl)))
, hfbRHS :: LocatedA arg
hfbRHS = LocatedA arg
arg'
, hfbPun :: Bool
hfbPun = Bool
pun })) }
rn_dotdot :: Maybe (Located RecFieldsDotDot)
-> Maybe Name
-> [LHsRecField GhcRn (LocatedA arg)]
-> RnM ([LHsRecField GhcRn (LocatedA arg)])
rn_dotdot :: Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> Maybe Name
-> [LHsRecField GhcRn (LocatedA arg)]
-> RnM [LHsRecField GhcRn (LocatedA arg)]
rn_dotdot (Just (L SrcSpan
loc (RecFieldsDotDot Int
n))) (Just Name
con) [LHsRecField GhcRn (LocatedA arg)]
flds
| Bool -> Bool
not (Name -> Bool
isUnboundName Name
con)
= Bool
-> RnM [LHsRecField GhcRn (LocatedA arg)]
-> RnM [LHsRecField GhcRn (LocatedA arg)]
forall a. HasCallStack => Bool -> a -> a
assert ([LHsRecField GhcRn (LocatedA arg)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
flds [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n) (RnM [LHsRecField GhcRn (LocatedA arg)]
-> RnM [LHsRecField GhcRn (LocatedA arg)])
-> RnM [LHsRecField GhcRn (LocatedA arg)]
-> RnM [LHsRecField GhcRn (LocatedA arg)]
forall a b. (a -> b) -> a -> b
$
do { Bool
dd_flag <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RecordWildCards
; Bool -> TcRnMessage -> RnM ()
checkErr Bool
dd_flag (HsRecFieldContext -> TcRnMessage
needFlagDotDot HsRecFieldContext
ctxt)
; (GlobalRdrEnv
rdr_env, LocalRdrEnv
lcl_env) <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
; [FieldLabel]
con_fields <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
con_fields) (TcRnMessage -> RnM ()
addErr (Name -> TcRnMessage
TcRnIllegalWildcardsInConstructor Name
con))
; let present_flds :: OccSet
present_flds = [OccName] -> OccSet
mkOccSet ([OccName] -> OccSet) -> [OccName] -> OccSet
forall a b. (a -> b) -> a -> b
$ (RdrName -> OccName) -> [RdrName] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> OccName
rdrNameOcc ([LHsRecField GhcRn (LocatedA arg)] -> [RdrName]
forall p arg. UnXRec p => [LHsRecField p arg] -> [RdrName]
getFieldLbls [LHsRecField GhcRn (LocatedA arg)]
flds)
arg_in_scope :: OccName -> Bool
arg_in_scope OccName
lbl = OccName -> RdrName
mkRdrUnqual OccName
lbl RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
lcl_env
([FieldLabel]
dot_dot_fields, [GlobalRdrElt]
dot_dot_gres)
= [(FieldLabel, GlobalRdrElt)] -> ([FieldLabel], [GlobalRdrElt])
forall a b. [(a, b)] -> ([a], [b])
unzip [ (FieldLabel
fl, GlobalRdrElt
gre)
| FieldLabel
fl <- [FieldLabel]
con_fields
, let lbl :: OccName
lbl = FastString -> OccName
mkVarOccFS (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fl)
, Bool -> Bool
not (OccName
lbl OccName -> OccSet -> Bool
`elemOccSet` OccSet
present_flds)
, Just GlobalRdrElt
gre <- [GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
lookupGRE_FieldLabel GlobalRdrEnv
rdr_env FieldLabel
fl]
, case HsRecFieldContext
ctxt of
HsRecFieldCon {} -> OccName -> Bool
arg_in_scope OccName
lbl
HsRecFieldContext
_other -> Bool
True ]
; [GlobalRdrElt] -> RnM ()
addUsedGREs [GlobalRdrElt]
dot_dot_gres
; let locn :: SrcSpanAnnA
locn = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ SrcSpanAnnA
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg)
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
hfbAnn = XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
hfbLHS
= SrcAnn NoEpAnns
-> FieldOcc GhcRn -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XCFieldOcc GhcRn -> XRec GhcRn RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcRn
Name
sel (SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NameAnn
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
arg_rdr))
, hfbRHS :: LocatedA arg
hfbRHS = SrcSpanAnnA -> arg -> LocatedA arg
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locn (SrcSpan -> RdrName -> arg
mk_arg SrcSpan
loc RdrName
arg_rdr)
, hfbPun :: Bool
hfbPun = Bool
False })
| FieldLabel
fl <- [FieldLabel]
dot_dot_fields
, let sel :: Name
sel = FieldLabel -> Name
flSelector FieldLabel
fl
, let arg_rdr :: RdrName
arg_rdr = FastString -> RdrName
mkVarUnqual (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fl) ] }
rn_dotdot Maybe (GenLocated SrcSpan RecFieldsDotDot)
_dotdot Maybe Name
_mb_con [LHsRecField GhcRn (LocatedA arg)]
_flds
= [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)) (LocatedA arg))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dup_flds :: [NE.NonEmpty RdrName]
([RdrName]
_, [NonEmpty RdrName]
dup_flds) = (RdrName -> RdrName -> Ordering)
-> [RdrName] -> ([RdrName], [NonEmpty RdrName])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([LHsRecField GhcPs (LocatedA arg)] -> [RdrName]
forall p arg. UnXRec p => [LHsRecField p arg] -> [RdrName]
getFieldLbls [LHsRecField GhcPs (LocatedA arg)]
flds)
rnHsRecUpdFields
:: [LHsRecUpdField GhcPs]
-> RnM ([LHsRecUpdField GhcRn], FreeVars)
rnHsRecUpdFields :: [LHsRecUpdField GhcPs] -> RnM ([LHsRecUpdField GhcRn], FreeVars)
rnHsRecUpdFields [LHsRecUpdField GhcPs]
flds
= do { Bool
pun_ok <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedFieldPuns
; DuplicateRecordFields
dup_fields_ok <- DynFlags -> DuplicateRecordFields
xopt_DuplicateRecordFields (DynFlags -> DuplicateRecordFields)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) DuplicateRecordFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds1, [FreeVars]
fvss) <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
[FreeVars])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Bool
-> DuplicateRecordFields
-> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld Bool
pun_ok DuplicateRecordFields
dup_fields_ok) [LHsRecUpdField GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds
; (NonEmpty RdrName -> RnM ()) -> [NonEmpty RdrName] -> RnM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> RnM ()
addErr (TcRnMessage -> RnM ())
-> (NonEmpty RdrName -> TcRnMessage) -> NonEmpty RdrName -> RnM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecFieldContext -> NonEmpty RdrName -> TcRnMessage
dupFieldErr HsRecFieldContext
HsRecFieldUpd) [NonEmpty RdrName]
dup_flds
; Bool -> RnM () -> RnM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsRecUpdField GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds) (RnM () -> RnM ()) -> RnM () -> RnM ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> RnM ()
addErr TcRnMessage
TcRnEmptyRecordUpdate
; ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds1, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvss) }
where
rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld :: Bool
-> DuplicateRecordFields
-> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld Bool
pun_ok DuplicateRecordFields
dup_fields_ok (L SrcSpanAnnA
l (HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcPs
f
, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
, hfbPun :: forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun = Bool
pun }))
= do { let lbl :: RdrName
lbl = AmbiguousFieldOcc GhcPs -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcPs
f
; AmbiguousResult
mb_sel <- SrcAnn NoEpAnns -> TcRn AmbiguousResult -> TcRn AmbiguousResult
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc (TcRn AmbiguousResult -> TcRn AmbiguousResult)
-> TcRn AmbiguousResult -> TcRn AmbiguousResult
forall a b. (a -> b) -> a -> b
$
DuplicateRecordFields -> RdrName -> TcRn AmbiguousResult
lookupRecFieldOcc_update DuplicateRecordFields
dup_fields_ok RdrName
lbl
; GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg' <- if Bool
pun
then do { Bool -> TcRnMessage -> RnM ()
checkErr Bool
pun_ok (Located RdrName -> TcRnMessage
TcRnIllegalFieldPunning (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc) RdrName
lbl))
; let arg_rdr :: RdrName
arg_rdr = OccName -> RdrName
mkRdrUnqual (RdrName -> OccName
rdrNameOcc RdrName
lbl)
; GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) (XVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField
(SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcAnn NameAnn
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) RdrName
arg_rdr))) }
else GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg'', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg'
; let (AmbiguousFieldOcc GhcRn
lbl', FreeVars
fvs') = case AmbiguousResult
mb_sel of
UnambiguousGre GreName
gname -> let sel_name :: Name
sel_name = GreName -> Name
greNameMangledName GreName
gname
in (XUnambiguous GhcRn -> XRec GhcRn RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> XRec pass RdrName -> AmbiguousFieldOcc pass
Unambiguous XUnambiguous GhcRn
Name
sel_name (SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcAnn NameAnn
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) RdrName
lbl), FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` Name
sel_name)
AmbiguousResult
AmbiguousFields -> (XAmbiguous GhcRn -> XRec GhcRn RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XAmbiguous pass -> XRec pass RdrName -> AmbiguousFieldOcc pass
Ambiguous XAmbiguous GhcRn
NoExtField
noExtField (SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcAnn NameAnn
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) RdrName
lbl), FreeVars
fvs)
; (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind { hfbAnn :: XHsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
hfbAnn = XHsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
hfbLHS = SrcAnn NoEpAnns
-> AmbiguousFieldOcc GhcRn
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcRn
lbl'
, hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg''
, hfbPun :: Bool
hfbPun = Bool
pun }), FreeVars
fvs') }
dup_flds :: [NE.NonEmpty RdrName]
([RdrName]
_, [NonEmpty RdrName]
dup_flds) = (RdrName -> RdrName -> Ordering)
-> [RdrName] -> ([RdrName], [NonEmpty RdrName])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls [LHsRecUpdField GhcPs]
flds)
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds :: forall arg. [LHsRecField GhcRn arg] -> [Name]
getFieldIds [LHsRecField GhcRn arg]
flds = (GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)
-> Name)
-> [GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)]
-> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg -> XCFieldOcc GhcRn
HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg -> Name
forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p
hsRecFieldSel (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg -> Name)
-> (GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)
-> HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)
-> GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)
-> HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg
forall l e. GenLocated l e -> e
unLoc) [LHsRecField GhcRn arg]
[GenLocated
SrcSpanAnnA (HsFieldBind (XRec GhcRn (FieldOcc GhcRn)) arg)]
flds
getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
getFieldLbls :: forall p arg. UnXRec p => [LHsRecField p arg] -> [RdrName]
getFieldLbls [LHsRecField p arg]
flds
= (LHsRecField p arg -> RdrName) -> [LHsRecField p arg] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @p (XRec p RdrName -> RdrName)
-> (LHsRecField p arg -> XRec p RdrName)
-> LHsRecField p arg
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc p -> XRec p RdrName
forall pass. FieldOcc pass -> XRec pass RdrName
foLabel (FieldOcc p -> XRec p RdrName)
-> (LHsRecField p arg -> FieldOcc p)
-> LHsRecField p arg
-> XRec p RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. UnXRec p => XRec p a -> a
unXRec @p (XRec p (FieldOcc p) -> FieldOcc p)
-> (LHsRecField p arg -> XRec p (FieldOcc p))
-> LHsRecField p arg
-> FieldOcc p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind (XRec p (FieldOcc p)) arg -> XRec p (FieldOcc p)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind (XRec p (FieldOcc p)) arg -> XRec p (FieldOcc p))
-> (LHsRecField p arg -> HsFieldBind (XRec p (FieldOcc p)) arg)
-> LHsRecField p arg
-> XRec p (FieldOcc p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. UnXRec p => XRec p a -> a
unXRec @p) [LHsRecField p arg]
flds
getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls [LHsRecUpdField GhcPs]
flds = (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> RdrName)
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (AmbiguousFieldOcc GhcPs -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcPs -> RdrName)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> AmbiguousFieldOcc GhcPs)
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
-> AmbiguousFieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
-> AmbiguousFieldOcc GhcPs)
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> AmbiguousFieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
unLoc) [LHsRecUpdField GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds
needFlagDotDot :: HsRecFieldContext -> TcRnMessage
needFlagDotDot :: HsRecFieldContext -> TcRnMessage
needFlagDotDot = RecordFieldPart -> TcRnMessage
TcRnIllegalWildcardsInRecord (RecordFieldPart -> TcRnMessage)
-> (HsRecFieldContext -> RecordFieldPart)
-> HsRecFieldContext
-> TcRnMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecFieldContext -> RecordFieldPart
toRecordFieldPart
dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
dupFieldErr :: HsRecFieldContext -> NonEmpty RdrName -> TcRnMessage
dupFieldErr HsRecFieldContext
ctxt = RecordFieldPart -> NonEmpty RdrName -> TcRnMessage
TcRnDuplicateFieldName (HsRecFieldContext -> RecordFieldPart
toRecordFieldPart HsRecFieldContext
ctxt)
toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart
toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart
toRecordFieldPart (HsRecFieldCon Name
n) = Name -> RecordFieldPart
RecordFieldConstructor Name
n
toRecordFieldPart (HsRecFieldPat Name
n) = Name -> RecordFieldPart
RecordFieldPattern Name
n
toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldPart
RecordFieldUpdate
rnLit :: HsLit p -> RnM ()
rnLit :: forall p. HsLit p -> RnM ()
rnLit (HsChar XHsChar p
_ Char
c) = Bool -> TcRnMessage -> RnM ()
checkErr (Char -> Bool
inCharRange Char
c) (Char -> TcRnMessage
TcRnCharLiteralOutOfRange Char
c)
rnLit HsLit p
_ = () -> RnM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
generalizeOverLitVal :: OverLitVal -> OverLitVal
generalizeOverLitVal :: OverLitVal -> OverLitVal
generalizeOverLitVal (HsFractional fl :: FractionalLit
fl@(FL {fl_text :: FractionalLit -> SourceText
fl_text=SourceText
src,fl_neg :: FractionalLit -> Bool
fl_neg=Bool
neg,fl_exp :: FractionalLit -> Integer
fl_exp=Integer
e}))
| Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
100 Bool -> Bool -> Bool
&& Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
100
, let val :: Rational
val = FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl
, Rational -> Integer
forall a. Ratio a -> a
denominator Rational
val Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = IntegralLit -> OverLitVal
HsIntegral (IL {il_text :: SourceText
il_text=SourceText
src,il_neg :: Bool
il_neg=Bool
neg,il_value :: Integer
il_value=Rational -> Integer
forall a. Ratio a -> a
numerator Rational
val})
generalizeOverLitVal OverLitVal
lit = OverLitVal
lit
isNegativeZeroOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool
isNegativeZeroOverLit :: forall t. (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool
isNegativeZeroOverLit HsOverLit t
lit
= case HsOverLit t -> OverLitVal
forall p. HsOverLit p -> OverLitVal
ol_val HsOverLit t
lit of
HsIntegral IntegralLit
i -> Integer
0 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== IntegralLit -> Integer
il_value IntegralLit
i Bool -> Bool -> Bool
&& IntegralLit -> Bool
il_neg IntegralLit
i
HsFractional FractionalLit
fl -> Rational
0 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== FractionalLit -> Rational
fl_signi FractionalLit
fl Bool -> Bool -> Bool
&& FractionalLit -> Bool
fl_neg FractionalLit
fl
OverLitVal
_ -> Bool
False
rnOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t ->
RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit :: forall t.
(XXOverLit t ~ DataConCantHappen) =>
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit t
origLit
= do { Bool
opt_NumDecimals <- Extension -> RnM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NumDecimals
; let { lit :: HsOverLit t
lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=OverLitVal
val})
| Bool
opt_NumDecimals = HsOverLit t
origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
| Bool
otherwise = HsOverLit t
origLit
}
; let std_name :: Name
std_name = OverLitVal -> Name
hsOverLitName OverLitVal
val
; (Name
from_thing_name, FreeVars
fvs1) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
std_name
; let rebindable :: Bool
rebindable = Name
from_thing_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
std_name
lit' :: HsOverLit GhcRn
lit' = HsOverLit t
lit { ol_ext = OverLitRn { ol_rebindable = rebindable
, ol_from_fun = noLocA from_thing_name } }
; if HsOverLit GhcRn -> Bool
forall t. (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool
isNegativeZeroOverLit HsOverLit GhcRn
lit'
then do { (HsExpr GhcRn
negate_name, FreeVars
fvs2) <- Name -> RnM (HsExpr GhcRn, FreeVars)
lookupSyntaxExpr Name
negateName
; ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsOverLit GhcRn
lit' { ol_val = negateOverLitVal val }, HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
negate_name)
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
else ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsOverLit GhcRn
lit', Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing), FreeVars
fvs1) }