{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Bind (
rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMethodBinds, renameSigs,
rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv,
HsSigCtxt(..),
rejectBootDecls,
localCompletePragmas
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Rename.HsType
import GHC.Rename.Pat
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( mapFvRn
, checkDupRdrNames
, warnUnusedLocalBinds
, checkUnusedRecordWildcard
, checkDupAndShadowedNames, bindLocalNamesFV
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Driver.DynFlags
import GHC.Unit.Module
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
import GHC.Data.List.SetOps ( findDupsEq )
import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) )
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.CompleteMatch
import GHC.Types.Unique.Set
import GHC.Data.Maybe ( orElse, mapMaybe )
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Types.Unique.DSet (mkUniqDSet)
import GHC.Data.BooleanFormula (bfTraverse)
rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds GhcPs
-> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
fix_env HsValBinds GhcPs
binds
= NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS (MiniFixityEnv -> NameMaker
topRecNameMaker MiniFixityEnv
fix_env) HsValBinds GhcPs
binds
rnTopBindsLHSBoot :: MiniFixityEnv
-> HsValBinds GhcPs
-> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHSBoot :: MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHSBoot MiniFixityEnv
fix_env HsValBinds GhcPs
binds
= do { topBinds <- MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
fix_env HsValBinds GhcPs
binds
; case topBinds of
ValBinds XValBinds GhcRn GhcPs
x LHsBindsLR GhcRn GhcPs
mbinds [XRec GhcPs (Sig GhcPs)]
sigs ->
do { HsBootOrSig
-> (NonEmpty (LocatedA (HsBindLR GhcRn GhcPs)) -> BadBootDecls)
-> [LocatedA (HsBindLR GhcRn GhcPs)]
-> TcM ()
forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> TcM ()
rejectBootDecls HsBootOrSig
HsBoot NonEmpty (LHsBindLR GhcRn GhcPs) -> BadBootDecls
NonEmpty (LocatedA (HsBindLR GhcRn GhcPs)) -> BadBootDecls
BootBindsPs LHsBindsLR GhcRn GhcPs
[LocatedA (HsBindLR GhcRn GhcPs)]
mbinds
; HsValBindsLR GhcRn GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XValBinds GhcRn GhcPs
-> LHsBindsLR GhcRn GhcPs
-> [XRec GhcPs (Sig GhcPs)]
-> HsValBindsLR GhcRn GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcRn GhcPs
x [] [XRec GhcPs (Sig GhcPs)]
sigs) }
HsValBindsLR GhcRn GhcPs
_ -> String -> SDoc -> RnM (HsValBindsLR GhcRn GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnTopBindsLHSBoot" (HsValBindsLR GhcRn GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBindsLR GhcRn GhcPs
topBinds) }
rejectBootDecls :: HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> TcM ()
rejectBootDecls :: forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> TcM ()
rejectBootDecls HsBootOrSig
_ NonEmpty (LocatedA decl) -> BadBootDecls
_ [] = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
rejectBootDecls HsBootOrSig
hsc_src NonEmpty (LocatedA decl) -> BadBootDecls
what (decl :: LocatedA decl
decl@(L SrcSpanAnnA
loc decl
_) : [LocatedA decl]
decls)
= SrcSpan -> TcRnMessage -> TcM ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc)
(TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ HsBootOrSig -> BadBootDecls -> TcRnMessage
TcRnIllegalHsBootOrSigDecl HsBootOrSig
hsc_src
(NonEmpty (LocatedA decl) -> BadBootDecls
what (NonEmpty (LocatedA decl) -> BadBootDecls)
-> NonEmpty (LocatedA decl) -> BadBootDecls
forall a b. (a -> b) -> a -> b
$ LocatedA decl
decl LocatedA decl -> [LocatedA decl] -> NonEmpty (LocatedA decl)
forall a. a -> [a] -> NonEmpty a
:| [LocatedA decl]
decls)
rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
rnTopBindsBoot :: NameSet
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnTopBindsBoot NameSet
bound_names (ValBinds XValBinds GhcRn GhcPs
_ LHsBindsLR GhcRn GhcPs
_ [XRec GhcPs (Sig GhcPs)]
sigs)
= do { (sigs', fvs) <- HsSigCtxt
-> [XRec GhcPs (Sig GhcPs)] -> RnM ([LSig GhcRn], NameSet)
renameSigs (NameSet -> HsSigCtxt
HsBootCtxt NameSet
bound_names) [XRec GhcPs (Sig GhcPs)]
sigs
; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
rnTopBindsBoot NameSet
_ HsValBindsLR GhcRn GhcPs
b = String -> SDoc -> RnM (HsValBinds GhcRn, DefUses)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnTopBindsBoot" (HsValBindsLR GhcRn GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBindsLR GhcRn GhcPs
b)
rnLocalBindsAndThen :: HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen :: forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalBindsAndThen (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x) HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside =
HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside (XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
XEmptyLocalBinds GhcRn GhcRn
x) NameSet
emptyNameSet
rnLocalBindsAndThen (HsValBinds XHsValBinds GhcPs GhcPs
x HsValBinds GhcPs
val_binds) HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside
= HsValBinds GhcPs
-> (HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
forall result.
HsValBinds GhcPs
-> (HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalValBindsAndThen HsValBinds GhcPs
val_binds ((HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet))
-> (HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
forall a b. (a -> b) -> a -> b
$ \ HsValBinds GhcRn
val_binds' ->
HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside (XHsValBinds GhcRn GhcRn -> HsValBinds GhcRn -> HsLocalBinds GhcRn
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
XHsValBinds GhcRn GhcRn
x HsValBinds GhcRn
val_binds')
rnLocalBindsAndThen (HsIPBinds XHsIPBinds GhcPs GhcPs
x HsIPBinds GhcPs
binds) HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside = do
(binds',fv_binds) <- HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, NameSet)
rnIPBinds HsIPBinds GhcPs
binds
(thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
return (thing, fvs_thing `plusFV` fv_binds)
rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, NameSet)
rnIPBinds (IPBinds XIPBinds GhcPs
_ [LIPBind GhcPs]
ip_binds ) = do
(ip_binds', fvs_s) <- (GenLocated SrcSpanAnnA (IPBind GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (IPBind GhcRn), NameSet))
-> [GenLocated SrcSpanAnnA (IPBind GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (IPBind GhcRn)], [NameSet])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((IPBind GhcPs -> TcM (IPBind GhcRn, NameSet))
-> GenLocated SrcSpanAnnA (IPBind GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (IPBind GhcRn), NameSet)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA IPBind GhcPs -> TcM (IPBind GhcRn, NameSet)
rnIPBind) [LIPBind GhcPs]
[GenLocated SrcSpanAnnA (IPBind GhcPs)]
ip_binds
return (IPBinds noExtField ip_binds', plusFVs fvs_s)
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
rnIPBind :: IPBind GhcPs -> TcM (IPBind GhcRn, NameSet)
rnIPBind (IPBind XCIPBind GhcPs
_ XRec GhcPs HsIPName
n LHsExpr GhcPs
expr) = do
(expr',fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr LHsExpr GhcPs
expr
return (IPBind noExtField n expr', fvExpr)
rnLocalValBindsLHS :: MiniFixityEnv
-> HsValBinds GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS :: MiniFixityEnv
-> HsValBinds GhcPs -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
fix_env HsValBinds GhcPs
binds
= do { binds' <- NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS (MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env) HsValBinds GhcPs
binds
; let bound_names = CollectFlag GhcRn -> HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) idR.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)]
collectHsValBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsValBindsLR GhcRn GhcPs
binds'
; envs <- getRdrEnvs
; checkDupAndShadowedNames envs bound_names
; return (bound_names, binds') }
rnValBindsLHS :: NameMaker
-> HsValBinds GhcPs
-> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS :: NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS NameMaker
topP (ValBinds XValBinds GhcPs GhcPs
x LHsBindsLR GhcPs GhcPs
mbinds [XRec GhcPs (Sig GhcPs)]
sigs)
= do { mbinds' <- (GenLocated SrcSpanAnnA (HsBind GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsBindLR GhcRn GhcPs)))
-> [GenLocated SrcSpanAnnA (HsBind GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LocatedA (HsBindLR GhcRn GhcPs)]
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 ((HsBind GhcPs -> TcM (HsBindLR GhcRn GhcPs))
-> GenLocated SrcSpanAnnA (HsBind GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (LocatedA (HsBindLR GhcRn GhcPs))
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA (NameMaker -> SDoc -> HsBind GhcPs -> TcM (HsBindLR GhcRn GhcPs)
rnBindLHS NameMaker
topP SDoc
doc)) LHsBindsLR GhcPs GhcPs
[GenLocated SrcSpanAnnA (HsBind GhcPs)]
mbinds
; return $ ValBinds x mbinds' sigs }
where
bndrs :: [IdP GhcPs]
bndrs = CollectFlag GhcPs -> LHsBindsLR GhcPs GhcPs -> [IdP GhcPs]
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders CollectFlag GhcPs
forall p. CollectFlag p
CollNoDictBinders LHsBindsLR GhcPs GhcPs
mbinds
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the binding group for:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (RdrName -> SDoc) -> [RdrName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcPs]
[RdrName]
bndrs
rnValBindsLHS NameMaker
_ HsValBinds GhcPs
b = String -> SDoc -> RnM (HsValBindsLR GhcRn GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnValBindsLHSFromDoc" (HsValBinds GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcPs
b)
rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS HsSigCtxt
ctxt (ValBinds XValBinds GhcRn GhcPs
_ LHsBindsLR GhcRn GhcPs
mbinds [XRec GhcPs (Sig GhcPs)]
sigs)
= do { (sigs', sig_fvs) <- HsSigCtxt
-> [XRec GhcPs (Sig GhcPs)] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
ctxt [XRec GhcPs (Sig GhcPs)]
sigs
; let localCompletePrags = [LSig GhcRn] -> CompleteMatches
localCompletePragmas [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs'
; updGblEnv (\TcGblEnv
gblEnv -> TcGblEnv
gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $
do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds
; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
; let patsyn_fvs = (PatSynBind GhcRn GhcRn -> NameSet -> NameSet)
-> NameSet -> [PatSynBind GhcRn GhcRn] -> NameSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
unionNameSet (NameSet -> NameSet -> NameSet)
-> (PatSynBind GhcRn GhcRn -> NameSet)
-> PatSynBind GhcRn GhcRn
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSynBind GhcRn GhcRn -> XPSB GhcRn GhcRn
PatSynBind GhcRn GhcRn -> NameSet
forall idL idR. PatSynBind idL idR -> XPSB idL idR
psb_ext) NameSet
emptyNameSet ([PatSynBind GhcRn GhcRn] -> NameSet)
-> [PatSynBind GhcRn GhcRn] -> NameSet
forall a b. (a -> b) -> a -> b
$
[(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
forall id.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds GhcRn)]
anal_binds
valbind'_dus = DefUses
anal_dus DefUses -> DefUses -> DefUses
`plusDU` NameSet -> DefUses
usesOnly NameSet
sig_fvs
DefUses -> DefUses -> DefUses
`plusDU` NameSet -> DefUses
usesOnly NameSet
patsyn_fvs
; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } }
rnValBindsRHS HsSigCtxt
_ HsValBindsLR GhcRn GhcPs
b = String -> SDoc -> RnM (HsValBinds GhcRn, DefUses)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnValBindsRHS" (HsValBindsLR GhcRn GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBindsLR GhcRn GhcPs
b)
rnLocalValBindsRHS :: NameSet
-> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS :: NameSet
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS NameSet
bound_names HsValBindsLR GhcRn GhcPs
binds
= HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (NameSet -> HsSigCtxt
LocalBindCtxt NameSet
bound_names) HsValBindsLR GhcRn GhcPs
binds
rnLocalValBindsAndThen
:: HsValBinds GhcPs
-> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalValBindsAndThen :: forall result.
HsValBinds GhcPs
-> (HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalValBindsAndThen binds :: HsValBinds GhcPs
binds@(ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
_ [XRec GhcPs (Sig GhcPs)]
sigs) HsValBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside
= do {
new_fixities <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv [ SrcSpanAnnA
-> FixitySig GhcPs -> GenLocated SrcSpanAnnA (FixitySig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FixitySig GhcPs
sig
| L SrcSpanAnnA
loc (FixSig XFixSig GhcPs
_ FixitySig GhcPs
sig) <- [XRec GhcPs (Sig GhcPs)]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs]
; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
; bindLocalNamesFV bound_names $
addLocalFixities new_fixities bound_names $ do
{
(binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
; (result, result_fvs) <- thing_inside binds' (allUses dus)
; let real_uses = DefUses -> NameSet -> NameSet
findUses DefUses
dus NameSet
result_fvs
rec_uses = HsValBinds GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]
forall (idR :: Pass).
HsValBindsLR GhcRn (GhcPass idR)
-> [(SrcSpan, [ImplicitFieldBinders])]
hsValBindsImplicits HsValBinds GhcRn
binds'
implicit_uses = [Name] -> NameSet
mkNameSet ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$ ((SrcSpan, [ImplicitFieldBinders]) -> [Name])
-> [(SrcSpan, [ImplicitFieldBinders])] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ImplicitFieldBinders -> [Name])
-> [ImplicitFieldBinders] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ImplicitFieldBinders -> [Name]
implFlBndr_binders ([ImplicitFieldBinders] -> [Name])
-> ((SrcSpan, [ImplicitFieldBinders]) -> [ImplicitFieldBinders])
-> (SrcSpan, [ImplicitFieldBinders])
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan, [ImplicitFieldBinders]) -> [ImplicitFieldBinders]
forall a b. (a, b) -> b
snd)
([(SrcSpan, [ImplicitFieldBinders])] -> [Name])
-> [(SrcSpan, [ImplicitFieldBinders])] -> [Name]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, [ImplicitFieldBinders])]
rec_uses
; mapM_ (\(SrcSpan
loc, [ImplicitFieldBinders]
ns) ->
SrcSpan -> NameSet -> Maybe [ImplicitFieldBinders] -> TcM ()
checkUnusedRecordWildcard SrcSpan
loc NameSet
real_uses ([ImplicitFieldBinders] -> Maybe [ImplicitFieldBinders]
forall a. a -> Maybe a
Just [ImplicitFieldBinders]
ns))
rec_uses
; warnUnusedLocalBinds bound_names
(real_uses `unionNameSet` implicit_uses)
; let
all_uses = DefUses -> NameSet
allUses DefUses
dus NameSet -> NameSet -> NameSet
`plusFV` NameSet
result_fvs
; return (result, all_uses) }}
rnLocalValBindsAndThen HsValBinds GhcPs
bs HsValBinds GhcRn -> NameSet -> RnM (result, NameSet)
_ = String -> SDoc -> RnM (result, NameSet)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnLocalValBindsAndThen" (HsValBinds GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcPs
bs)
rnBindLHS :: NameMaker
-> SDoc
-> HsBind GhcPs
-> RnM (HsBindLR GhcRn GhcPs)
rnBindLHS :: NameMaker -> SDoc -> HsBind GhcPs -> TcM (HsBindLR GhcRn GhcPs)
rnBindLHS NameMaker
name_maker SDoc
_ bind :: HsBind GhcPs
bind@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcPs
pat, pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcPs
pat_mult })
= do
(pat',pat'_fvs) <- NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, NameSet)
rnBindPat NameMaker
name_maker LPat GhcPs
pat
(pat_mult', mult'_fvs) <- rnHsMultAnn pat_mult
return (bind { pat_lhs = pat', pat_ext = pat'_fvs `plusFV` mult'_fvs, pat_mult = pat_mult' })
rnBindLHS NameMaker
name_maker SDoc
_ bind :: HsBind GhcPs
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcPs
rdr_name })
= do { name <- NameMaker -> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
applyNameMaker NameMaker
name_maker LIdP GhcPs
LocatedN RdrName
rdr_name
; return (bind { fun_id = name
, fun_ext = noExtField }) }
rnBindLHS NameMaker
name_maker SDoc
_ (PatSynBind XPatSynBind GhcPs GhcPs
x psb :: PatSynBind GhcPs GhcPs
psb@PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = LIdP GhcPs
rdrname })
| NameMaker -> Bool
isTopRecNameMaker NameMaker
name_maker
= do { (RdrName -> TcM ()) -> LocatedN RdrName -> TcM ()
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM RdrName -> TcM ()
checkConName LIdP GhcPs
LocatedN RdrName
rdrname
; name <-
LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
LocatedN RdrName
rdrname
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
| Bool
otherwise
= do { TcRnMessage -> TcM ()
addErr TcRnMessage
localPatternSynonymErr
; name <- NameMaker -> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
applyNameMaker NameMaker
name_maker LIdP GhcPs
LocatedN RdrName
rdrname
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
where
localPatternSynonymErr :: TcRnMessage
localPatternSynonymErr :: TcRnMessage
localPatternSynonymErr = LIdP GhcPs -> TcRnMessage
TcRnIllegalPatSynDecl LIdP GhcPs
rdrname
rnBindLHS NameMaker
_ SDoc
_ HsBind GhcPs
b = String -> SDoc -> TcM (HsBindLR GhcRn GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnBindHS" (HsBind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcPs
b)
rnLBind :: (Name -> [Name])
-> LHsBindLR GhcRn GhcPs
-> RnM (LHsBind GhcRn, [Name], Uses)
rnLBind :: (Name -> [Name])
-> LHsBindLR GhcRn GhcPs -> RnM (LHsBind GhcRn, [Name], NameSet)
rnLBind Name -> [Name]
sig_fn (L SrcSpanAnnA
loc HsBindLR GhcRn GhcPs
bind)
= SrcSpanAnnA
-> RnM (LHsBind GhcRn, [Name], NameSet)
-> RnM (LHsBind GhcRn, [Name], NameSet)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (RnM (LHsBind GhcRn, [Name], NameSet)
-> RnM (LHsBind GhcRn, [Name], NameSet))
-> RnM (LHsBind GhcRn, [Name], NameSet)
-> RnM (LHsBind GhcRn, [Name], NameSet)
forall a b. (a -> b) -> a -> b
$
do { (bind', bndrs, dus) <- (Name -> [Name])
-> HsBindLR GhcRn GhcPs
-> RnM (HsBindLR GhcRn GhcRn, [Name], NameSet)
rnBind Name -> [Name]
sig_fn HsBindLR GhcRn GhcPs
bind
; return (L loc bind', bndrs, dus) }
rnBind :: (Name -> [Name])
-> HsBindLR GhcRn GhcPs
-> RnM (HsBind GhcRn, [Name], Uses)
rnBind :: (Name -> [Name])
-> HsBindLR GhcRn GhcPs
-> RnM (HsBindLR GhcRn GhcRn, [Name], NameSet)
rnBind Name -> [Name]
_ bind :: HsBindLR GhcRn GhcPs
bind@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcRn
pat
, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcPs (LHsExpr GhcPs)
grhss
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind GhcRn GhcPs
pat_fvs })
= do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
; let all_fvs = XPatBind GhcRn GhcPs
NameSet
pat_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
rhs_fvs
fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
all_fvs
bndrs = CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat
bind' = HsBindLR GhcRn GhcPs
bind { pat_rhs = grhss'
, pat_ext = fvs' }
; whenWOptM Opt_WarnUnusedPatternBinds $
when (null bndrs && not (isOkNoBindPattern pat)) $
addTcRnDiagnostic (TcRnUnusedPatternBinds bind')
; fvs' `seq`
return (bind', bndrs, all_fvs) }
rnBind Name -> [Name]
sig_fn bind :: HsBindLR GhcRn GhcPs
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = XRec GhcRn (IdP GhcRn)
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcPs (LHsExpr GhcPs)
matches })
= do { let plain_name :: Name
plain_name = GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc XRec GhcRn (IdP GhcRn)
GenLocated SrcSpanAnnN Name
name
; (matches', rhs_fvs) <- [Name]
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV (Name -> [Name]
sig_fn Name
plain_name) (RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)),
NameSet))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall a b. (a -> b) -> a -> b
$
HsMatchContextRn
-> (LocatedA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (HsExpr GhcPs))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs XRec GhcRn (IdP GhcRn)
GenLocated SrcSpanAnnN Name
name AnnFunRhs
forall a. NoAnn a => a
noAnn)
LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
LocatedA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), NameSet)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (LocatedA (HsExpr GhcPs))
matches
; let is_infix = HsBindLR GhcRn GhcPs -> Bool
forall (p1 :: Pass) (p2 :: Pass).
HsBindLR (GhcPass p1) (GhcPass p2) -> Bool
isInfixFunBind HsBindLR GhcRn GhcPs
bind
; when is_infix $ checkPrecMatch plain_name matches'
; mod <- getModule
; let fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
rhs_fvs
; fvs' `seq`
return (bind { fun_matches = matches'
, fun_ext = fvs' },
[plain_name], rhs_fvs)
}
rnBind Name -> [Name]
sig_fn (PatSynBind XPatSynBind GhcRn GhcPs
x PatSynBind GhcRn GhcPs
bind)
= do { (bind', name, fvs) <- (Name -> [Name])
-> PatSynBind GhcRn GhcPs
-> RnM (PatSynBind GhcRn GhcRn, [Name], NameSet)
rnPatSynBind Name -> [Name]
sig_fn PatSynBind GhcRn GhcPs
bind
; return (PatSynBind x bind', name, fvs) }
rnBind Name -> [Name]
_ (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcRn GhcPs
x }) = DataConCantHappen -> RnM (HsBindLR GhcRn GhcRn, [Name], NameSet)
forall a. DataConCantHappen -> a
dataConCantHappen XVarBind GhcRn GhcPs
DataConCantHappen
x
isOkNoBindPattern :: LPat GhcRn -> Bool
isOkNoBindPattern :: LPat GhcRn -> Bool
isOkNoBindPattern (L SrcSpanAnnA
_ Pat GhcRn
pat) =
case Pat GhcRn
pat of
WildPat{} -> Bool
True
BangPat {} -> Bool
True
Pat GhcRn
p -> Pat GhcRn -> Bool
patternContainsSplice Pat GhcRn
p
where
lpatternContainsSplice :: LPat GhcRn -> Bool
lpatternContainsSplice :: LPat GhcRn -> Bool
lpatternContainsSplice (L SrcSpanAnnA
_ Pat GhcRn
p) = Pat GhcRn -> Bool
patternContainsSplice Pat GhcRn
p
patternContainsSplice :: Pat GhcRn -> Bool
patternContainsSplice :: Pat GhcRn -> Bool
patternContainsSplice Pat GhcRn
p =
case Pat GhcRn
p of
SplicePat (HsUntypedSpliceTop ThModFinalizers
_ Pat GhcRn
p) HsUntypedSplice GhcRn
_ -> Pat GhcRn -> Bool
patternContainsSplice Pat GhcRn
p
SplicePat (HsUntypedSpliceNested {}) HsUntypedSplice GhcRn
_ -> Bool
True
VarPat {} -> Bool
False
WildPat {} -> Bool
False
LitPat {} -> Bool
False
NPat {} -> Bool
False
NPlusKPat {} -> Bool
False
BangPat XBangPat GhcRn
_ LPat GhcRn
lp -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
LazyPat XLazyPat GhcRn
_ LPat GhcRn
lp -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
AsPat XAsPat GhcRn
_ XRec GhcRn (IdP GhcRn)
_ LPat GhcRn
lp -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
ParPat XParPat GhcRn
_ LPat GhcRn
lp -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
ViewPat XViewPat GhcRn
_ LHsExpr GhcRn
_ LPat GhcRn
lp -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
OrPat XOrPat GhcRn
_ NonEmpty (LPat GhcRn)
lps -> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> NonEmpty (GenLocated SrcSpanAnnA (Pat GhcRn)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcRn -> Bool
GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool
lpatternContainsSplice NonEmpty (LPat GhcRn)
NonEmpty (GenLocated SrcSpanAnnA (Pat GhcRn))
lps
SigPat XSigPat GhcRn
_ LPat GhcRn
lp HsPatSigType (NoGhcTc GhcRn)
_ -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
ListPat XListPat GhcRn
_ [LPat GhcRn]
lps -> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcRn -> Bool
GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool
lpatternContainsSplice [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
lps
TuplePat XTuplePat GhcRn
_ [LPat GhcRn]
lps Boxity
_ -> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcRn -> Bool
GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool
lpatternContainsSplice [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
lps
SumPat XSumPat GhcRn
_ LPat GhcRn
lp ConTag
_ ConTag
_ -> LPat GhcRn -> Bool
lpatternContainsSplice LPat GhcRn
lp
ConPat XConPat GhcRn
_ XRec GhcRn (ConLikeP GhcRn)
_ HsConPatDetails GhcRn
cpd -> (GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcRn -> Bool
GenLocated SrcSpanAnnA (Pat GhcRn) -> Bool
lpatternContainsSplice (HsConPatDetails GhcRn -> [LPat GhcRn]
forall p. UnXRec p => HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails GhcRn
cpd)
XPat (HsPatExpanded Pat GhcRn
_orig Pat GhcRn
new) -> Pat GhcRn -> Bool
patternContainsSplice Pat GhcRn
new
EmbTyPat{} -> Bool
True
InvisPat{} -> Bool
True
depAnalBinds :: [(LHsBind GhcRn, [Name], Uses)]
-> ([(RecFlag, LHsBinds GhcRn)], DefUses)
depAnalBinds :: [(LHsBind GhcRn, [Name], NameSet)]
-> ([(RecFlag, LHsBinds GhcRn)], DefUses)
depAnalBinds [(LHsBind GhcRn, [Name], NameSet)]
binds_w_dus
= ((SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]))
-> [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)])]
forall a b. (a -> b) -> [a] -> [b]
map SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)])
forall {a} {b} {c}. SCC (a, b, c) -> (RecFlag, [a])
get_binds [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
sccs, [DefUse] -> DefUses
forall a. [a] -> OrdList a
toOL ([DefUse] -> DefUses) -> [DefUse] -> DefUses
forall a b. (a -> b) -> a -> b
$ (SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> DefUse)
-> [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
-> [DefUse]
forall a b. (a -> b) -> [a] -> [b]
map SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> DefUse
forall {a}. SCC (a, [Name], NameSet) -> DefUse
get_du [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
sccs)
where
sccs :: [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
sccs = ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> [Name])
-> ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name],
NameSet)
-> [Name])
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name],
NameSet)]
-> [SCC
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
forall node.
(node -> [Name]) -> (node -> [Name]) -> [node] -> [SCC node]
depAnal (\(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
_, [Name]
defs, NameSet
_) -> [Name]
defs)
(\(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
_, [Name]
_, NameSet
uses) -> NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet NameSet
uses)
[(LHsBind GhcRn, [Name], NameSet)]
[(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
binds_w_dus
get_binds :: SCC (a, b, c) -> (RecFlag, [a])
get_binds (AcyclicSCC (a
bind, b
_, c
_)) = (RecFlag
NonRecursive, [a
bind])
get_binds (CyclicSCC [(a, b, c)]
binds_w_dus) = (RecFlag
Recursive, [a
b | (a
b,b
_,c
_) <- [(a, b, c)]
binds_w_dus])
get_du :: SCC (a, [Name], NameSet) -> DefUse
get_du (AcyclicSCC (a
_, [Name]
bndrs, NameSet
uses)) = (NameSet -> Maybe NameSet
forall a. a -> Maybe a
Just ([Name] -> NameSet
mkNameSet [Name]
bndrs), NameSet
uses)
get_du (CyclicSCC [(a, [Name], NameSet)]
binds_w_dus) = (NameSet -> Maybe NameSet
forall a. a -> Maybe a
Just NameSet
defs, NameSet
uses)
where
defs :: NameSet
defs = [Name] -> NameSet
mkNameSet [Name
b | (a
_,[Name]
bs,NameSet
_) <- [(a, [Name], NameSet)]
binds_w_dus, Name
b <- [Name]
bs]
uses :: NameSet
uses = [NameSet] -> NameSet
unionNameSets [NameSet
u | (a
_,[Name]
_,NameSet
u) <- [(a, [Name], NameSet)]
binds_w_dus]
mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
mkScopedTvFn :: [LSig GhcRn] -> Name -> [Name]
mkScopedTvFn [LSig GhcRn]
sigs = \Name
n -> NameEnv [Name] -> Name -> Maybe [Name]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [Name]
env Name
n Maybe [Name] -> [Name] -> [Name]
forall a. Maybe a -> a -> a
`orElse` []
where
env :: NameEnv [Name]
env = (LSig GhcRn -> Maybe ([GenLocated SrcSpanAnnN Name], [Name]))
-> [LSig GhcRn] -> NameEnv [Name]
forall a.
(LSig GhcRn -> Maybe ([GenLocated SrcSpanAnnN Name], a))
-> [LSig GhcRn] -> NameEnv a
mkHsSigEnv LSig GhcRn -> Maybe ([GenLocated SrcSpanAnnN Name], [Name])
get_scoped_tvs [LSig GhcRn]
sigs
get_scoped_tvs :: LSig GhcRn -> Maybe ([LocatedN Name], [Name])
get_scoped_tvs :: LSig GhcRn -> Maybe ([GenLocated SrcSpanAnnN Name], [Name])
get_scoped_tvs (L SrcSpanAnnA
_ (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [XRec GhcRn (IdP GhcRn)]
names LHsSigType GhcRn
sig_ty))
= ([GenLocated SrcSpanAnnN Name], [Name])
-> Maybe ([GenLocated SrcSpanAnnN Name], [Name])
forall a. a -> Maybe a
Just ([XRec GhcRn (IdP GhcRn)]
[GenLocated SrcSpanAnnN Name]
names, LHsSigType GhcRn -> [Name]
hsScopedTvs LHsSigType GhcRn
sig_ty)
get_scoped_tvs (L SrcSpanAnnA
_ (TypeSig XTypeSig GhcRn
_ [XRec GhcRn (IdP GhcRn)]
names LHsSigWcType GhcRn
sig_ty))
= ([GenLocated SrcSpanAnnN Name], [Name])
-> Maybe ([GenLocated SrcSpanAnnN Name], [Name])
forall a. a -> Maybe a
Just ([XRec GhcRn (IdP GhcRn)]
[GenLocated SrcSpanAnnN Name]
names, LHsSigWcType GhcRn -> [Name]
hsWcScopedTvs LHsSigWcType GhcRn
sig_ty)
get_scoped_tvs (L SrcSpanAnnA
_ (PatSynSig XPatSynSig GhcRn
_ [XRec GhcRn (IdP GhcRn)]
names LHsSigType GhcRn
sig_ty))
= ([GenLocated SrcSpanAnnN Name], [Name])
-> Maybe ([GenLocated SrcSpanAnnN Name], [Name])
forall a. a -> Maybe a
Just ([XRec GhcRn (IdP GhcRn)]
[GenLocated SrcSpanAnnN Name]
names, LHsSigType GhcRn -> [Name]
hsScopedTvs LHsSigType GhcRn
sig_ty)
get_scoped_tvs LSig GhcRn
_ = Maybe ([GenLocated SrcSpanAnnN Name], [Name])
forall a. Maybe a
Nothing
makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv [LFixitySig GhcPs]
decls = (MiniFixityEnv
-> GenLocated SrcSpanAnnA (FixitySig GhcPs) -> RnM MiniFixityEnv)
-> MiniFixityEnv
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> RnM MiniFixityEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
MiniFixityEnv
-> GenLocated SrcSpanAnnA (FixitySig GhcPs) -> RnM MiniFixityEnv
add_one_sig MiniFixityEnv
emptyMiniFixityEnv [LFixitySig GhcPs]
[GenLocated SrcSpanAnnA (FixitySig GhcPs)]
decls
where
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig MiniFixityEnv
env (L SrcSpanAnnA
loc (FixitySig XFixitySig GhcPs
ns_spec [LIdP GhcPs]
names Fixity
fixity)) =
(MiniFixityEnv
-> (SrcSpan, SrcSpan, RdrName, Fixity, NamespaceSpecifier)
-> RnM MiniFixityEnv)
-> MiniFixityEnv
-> [(SrcSpan, SrcSpan, RdrName, Fixity, NamespaceSpecifier)]
-> RnM MiniFixityEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM MiniFixityEnv
-> (SrcSpan, SrcSpan, RdrName, Fixity, NamespaceSpecifier)
-> RnM MiniFixityEnv
add_one MiniFixityEnv
env [ (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc,SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
name_loc,RdrName
name,Fixity
fixity, XFixitySig GhcPs
NamespaceSpecifier
ns_spec)
| L SrcSpanAnnN
name_loc RdrName
name <- [LIdP GhcPs]
[LocatedN RdrName]
names ]
add_one :: MiniFixityEnv
-> (SrcSpan, SrcSpan, RdrName, Fixity, NamespaceSpecifier)
-> RnM MiniFixityEnv
add_one MiniFixityEnv
env (SrcSpan
loc, SrcSpan
name_loc, RdrName
name, Fixity
fixity, NamespaceSpecifier
ns_spec) = do
{
let { fs :: FastString
fs = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
name)
; fix_item :: GenLocated SrcSpan Fixity
fix_item = SrcSpan -> Fixity -> GenLocated SrcSpan Fixity
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Fixity
fixity};
case NamespaceSpecifier
-> MiniFixityEnv -> FastString -> Maybe (GenLocated SrcSpan Fixity)
search_for_dups NamespaceSpecifier
ns_spec MiniFixityEnv
env FastString
fs of
Maybe (GenLocated SrcSpan Fixity)
Nothing -> MiniFixityEnv -> RnM MiniFixityEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MiniFixityEnv -> RnM MiniFixityEnv)
-> MiniFixityEnv -> RnM MiniFixityEnv
forall a b. (a -> b) -> a -> b
$ NamespaceSpecifier
-> MiniFixityEnv
-> FastString
-> GenLocated SrcSpan Fixity
-> MiniFixityEnv
extend_mini_fixity_env NamespaceSpecifier
ns_spec MiniFixityEnv
env FastString
fs GenLocated SrcSpan Fixity
fix_item
Just (L SrcSpan
loc' Fixity
_) -> do
{ SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
name_loc (SrcSpan -> RdrName -> TcRnMessage
TcRnMultipleFixityDecls SrcSpan
loc' RdrName
name)
; MiniFixityEnv -> RnM MiniFixityEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return MiniFixityEnv
env}
}
search_for_dups :: NamespaceSpecifier
-> MiniFixityEnv -> FastString -> Maybe (GenLocated SrcSpan Fixity)
search_for_dups NamespaceSpecifier
ns_spec MFE{FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names :: MiniFixityEnv -> FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names, FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names :: MiniFixityEnv -> FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names} FastString
fs
= case NamespaceSpecifier
ns_spec of
NamespaceSpecifier
NoNamespaceSpecifier -> case FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString -> Maybe (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names FastString
fs of
Maybe (GenLocated SrcSpan Fixity)
Nothing -> FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString -> Maybe (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names FastString
fs
Maybe (GenLocated SrcSpan Fixity)
just_dup -> Maybe (GenLocated SrcSpan Fixity)
just_dup
TypeNamespaceSpecifier{} -> FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString -> Maybe (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names FastString
fs
DataNamespaceSpecifier{} -> FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString -> Maybe (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names FastString
fs
extend_mini_fixity_env :: NamespaceSpecifier
-> MiniFixityEnv
-> FastString
-> GenLocated SrcSpan Fixity
-> MiniFixityEnv
extend_mini_fixity_env NamespaceSpecifier
ns_spec env :: MiniFixityEnv
env@MFE{FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names :: MiniFixityEnv -> FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names, FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names :: MiniFixityEnv -> FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names} FastString
fs GenLocated SrcSpan Fixity
fix_item
= case NamespaceSpecifier
ns_spec of
NamespaceSpecifier
NoNamespaceSpecifier -> MFE { mfe_data_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names = (FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString
-> GenLocated SrcSpan Fixity
-> FastStringEnv (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> a -> FastStringEnv a
extendFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_data_level_names FastString
fs GenLocated SrcSpan Fixity
fix_item)
, mfe_type_level_names :: FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names = (FastStringEnv (GenLocated SrcSpan Fixity)
-> FastString
-> GenLocated SrcSpan Fixity
-> FastStringEnv (GenLocated SrcSpan Fixity)
forall a. FastStringEnv a -> FastString -> a -> FastStringEnv a
extendFsEnv FastStringEnv (GenLocated SrcSpan Fixity)
mfe_type_level_names FastString
fs GenLocated SrcSpan Fixity
fix_item)}
TypeNamespaceSpecifier{} -> MiniFixityEnv
env { mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)}
DataNamespaceSpecifier{} -> MiniFixityEnv
env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)}
rnHsMultAnn :: HsMultAnn GhcPs -> RnM (HsMultAnn GhcRn, FreeVars)
rnHsMultAnn :: HsMultAnn GhcPs -> RnM (HsMultAnn GhcRn, NameSet)
rnHsMultAnn (HsNoMultAnn XNoMultAnn GhcPs
_) = (HsMultAnn GhcRn, NameSet) -> RnM (HsMultAnn GhcRn, NameSet)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField, NameSet
emptyFVs)
rnHsMultAnn (HsPct1Ann XPct1Ann GhcPs
_) = (HsMultAnn GhcRn, NameSet) -> RnM (HsMultAnn GhcRn, NameSet)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPct1Ann GhcRn -> HsMultAnn GhcRn
forall pass. XPct1Ann pass -> HsMultAnn pass
HsPct1Ann NoExtField
XPct1Ann GhcRn
noExtField, NameSet
emptyFVs)
rnHsMultAnn (HsMultAnn XMultAnn GhcPs
_ LHsType (NoGhcTc GhcPs)
p) = do
(p', freeVars') <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
PatCtx LHsType (NoGhcTc GhcPs)
LHsType GhcPs
p
return $ (HsMultAnn noExtField p', freeVars')
rnPatSynBind :: (Name -> [Name])
-> PatSynBind GhcRn GhcPs
-> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
rnPatSynBind :: (Name -> [Name])
-> PatSynBind GhcRn GhcPs
-> RnM (PatSynBind GhcRn GhcRn, [Name], NameSet)
rnPatSynBind Name -> [Name]
sig_fn bind :: PatSynBind GhcRn GhcPs
bind@(PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
l Name
name
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcPs
details
, psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcPs
pat
, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcPs
dir })
= do { pattern_synonym_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PatternSynonyms
; unless pattern_synonym_ok (addErr TcRnIllegalPatternSynonymDecl)
; let scoped_tvs = Name -> [Name]
sig_fn Name
name
; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
rnPat PatSyn pat $ \LPat GhcRn
pat' ->
case HsPatSynDetails GhcPs
details of
PrefixCon [Void]
_ [LIdP GhcPs]
vars ->
do { [LocatedN RdrName] -> TcM ()
checkDupRdrNames [LIdP GhcPs]
[LocatedN RdrName]
vars
; names <- (LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name))
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
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 LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall {ann}.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupPatSynBndr [LIdP GhcPs]
[LocatedN RdrName]
vars
; return ( (pat', PrefixCon noTypeArgs names)
, mkFVs (map unLoc names)) }
InfixCon LIdP GhcPs
var1 LIdP GhcPs
var2 ->
do { [LocatedN RdrName] -> TcM ()
checkDupRdrNames [LIdP GhcPs
LocatedN RdrName
var1, LIdP GhcPs
LocatedN RdrName
var2]
; name1 <- LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall {ann}.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupPatSynBndr LIdP GhcPs
LocatedN RdrName
var1
; name2 <- lookupPatSynBndr var2
; return ( (pat', InfixCon name1 name2)
, mkFVs (map unLoc [name1, name2])) }
RecCon [RecordPatSynField GhcPs]
vars ->
do { [LocatedN RdrName] -> TcM ()
checkDupRdrNames ((RecordPatSynField GhcPs -> LocatedN RdrName)
-> [RecordPatSynField GhcPs] -> [LocatedN RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (FieldOcc GhcPs -> LIdP GhcPs
FieldOcc GhcPs -> LocatedN RdrName
forall pass. FieldOcc pass -> LIdP pass
foLabel (FieldOcc GhcPs -> LocatedN RdrName)
-> (RecordPatSynField GhcPs -> FieldOcc GhcPs)
-> RecordPatSynField GhcPs
-> LocatedN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcPs -> FieldOcc GhcPs
forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcPs]
vars)
; fls <- HasDebugCallStack => Name -> RnM [FieldLabel]
Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; let fld_env = [(FastString, FieldLabel)] -> FastStringEnv FieldLabel
forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv [ (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, FieldLabel
fl) | FieldLabel
fl <- [FieldLabel]
fls ]
; let rnRecordPatSynField
(RecordPatSynField { recordPatSynField :: forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField = FieldOcc GhcPs
visible
, recordPatSynPatVar :: forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar = LIdP GhcPs
hidden })
= do { let visible' :: FieldOcc GhcRn
visible' = FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField FastStringEnv FieldLabel
fld_env FieldOcc GhcPs
visible
; hidden' <- LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall {ann}.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupPatSynBndr LIdP GhcPs
LocatedN RdrName
hidden
; return $ RecordPatSynField { recordPatSynField = visible'
, recordPatSynPatVar = hidden' } }
; names <- mapM rnRecordPatSynField vars
; return ( (pat', RecCon names)
, mkFVs (map (unLoc . recordPatSynPatVar) names)) }
; (dir', fvs2) <- case dir of
HsPatSynDir GhcPs
Unidirectional -> (HsPatSynDir GhcRn, NameSet)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsPatSynDir GhcRn, NameSet)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPatSynDir GhcRn
forall id. HsPatSynDir id
Unidirectional, NameSet
emptyFVs)
HsPatSynDir GhcPs
ImplicitBidirectional -> (HsPatSynDir GhcRn, NameSet)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsPatSynDir GhcRn, NameSet)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPatSynDir GhcRn
forall id. HsPatSynDir id
ImplicitBidirectional, NameSet
emptyFVs)
ExplicitBidirectional MatchGroup GhcPs (LHsExpr GhcPs)
mg ->
do { (mg', fvs) <- [Name]
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV [Name]
scoped_tvs (RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)),
NameSet))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall a b. (a -> b) -> a -> b
$
HsMatchContextRn
-> (LocatedA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (HsExpr GhcPs))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), NameSet)
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
name) AnnFunRhs
forall a. NoAnn a => a
noAnn)
LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
LocatedA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), NameSet)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (LocatedA (HsExpr GhcPs))
mg
; return (ExplicitBidirectional mg', fvs) }
; mod <- getModule
; let fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2
fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
fvs
bind' = PatSynBind GhcRn GhcPs
bind{ psb_args = details'
, psb_def = pat'
, psb_dir = dir'
, psb_ext = fvs' }
selector_names = case HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
details' of
RecCon [RecordPatSynField GhcRn]
names ->
(RecordPatSynField GhcRn -> Name)
-> [RecordPatSynField GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (RecordPatSynField GhcRn -> GenLocated SrcSpanAnnN Name)
-> RecordPatSynField GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcRn -> XRec GhcRn (IdP GhcRn)
FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name
forall pass. FieldOcc pass -> LIdP pass
foLabel (FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name)
-> (RecordPatSynField GhcRn -> FieldOcc GhcRn)
-> RecordPatSynField GhcRn
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcRn -> FieldOcc GhcRn
forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcRn]
names
HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
_ -> []
; fvs' `seq`
return (bind', name : selector_names , fvs1)
}
where
lookupPatSynBndr :: GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupPatSynBndr = (RdrName -> TcM Name)
-> GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA RdrName -> TcM Name
lookupLocalOccRn
rnMethodBinds :: Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
rnMethodBinds :: Bool
-> Name
-> [Name]
-> LHsBindsLR GhcPs GhcPs
-> [XRec GhcPs (Sig GhcPs)]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
is_cls_decl Name
cls [Name]
ktv_names LHsBindsLR GhcPs GhcPs
binds [XRec GhcPs (Sig GhcPs)]
sigs
= do { [LocatedN RdrName] -> TcM ()
checkDupRdrNames (LHsBindsLR GhcPs GhcPs -> [LIdP GhcPs]
forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
collectMethodBinders LHsBindsLR GhcPs GhcPs
binds)
; binds' <- (GenLocated SrcSpanAnnA (HsBind GhcPs)
-> [LocatedA (HsBindLR GhcRn GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LocatedA (HsBindLR GhcRn GhcPs)])
-> [LocatedA (HsBindLR GhcRn GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBind GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LocatedA (HsBindLR GhcRn GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Bool
-> Name
-> LHsBindLR GhcPs GhcPs
-> LHsBindsLR GhcRn GhcPs
-> RnM (LHsBindsLR GhcRn GhcPs)
rnMethodBindLHS Bool
is_cls_decl Name
cls) [] LHsBindsLR GhcPs GhcPs
[GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds
; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs
bound_nms = [Name] -> NameSet
mkNameSet (CollectFlag GhcRn -> LHsBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LHsBindsLR GhcRn GhcPs
[LocatedA (HsBindLR GhcRn GhcPs)]
binds')
sig_ctxt | Bool
is_cls_decl = Name -> HsSigCtxt
ClsDeclCtxt Name
cls
| Bool
otherwise = NameSet -> HsSigCtxt
InstDeclCtxt NameSet
bound_nms
; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags
; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
renameSigs sig_ctxt other_sigs
; let localCompletePrags = [LSig GhcRn] -> CompleteMatches
localCompletePragmas [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_prags'
; updGblEnv (\TcGblEnv
gblEnv -> TcGblEnv
gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $
do {
; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $
do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn other_sigs')) binds'
; let bind_fvs = ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)
-> NameSet -> NameSet)
-> NameSet
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name],
NameSet)]
-> NameSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
_,[Name]
_,NameSet
fv1) NameSet
fv2 -> NameSet
fv1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv2)
NameSet
emptyFVs [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), [Name], NameSet)]
binds_w_dus
; return (map fstOf3 binds_w_dus, bind_fvs) }
; return ( binds'', spec_prags' ++ other_sigs'
, sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) } }
rnMethodBindLHS :: Bool -> Name
-> LHsBindLR GhcPs GhcPs
-> LHsBindsLR GhcRn GhcPs
-> RnM (LHsBindsLR GhcRn GhcPs)
rnMethodBindLHS :: Bool
-> Name
-> LHsBindLR GhcPs GhcPs
-> LHsBindsLR GhcRn GhcPs
-> RnM (LHsBindsLR GhcRn GhcPs)
rnMethodBindLHS Bool
_ Name
cls (L SrcSpanAnnA
loc bind :: HsBind GhcPs
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcPs
name })) LHsBindsLR GhcRn GhcPs
rest
= SrcSpanAnnA
-> RnM (LHsBindsLR GhcRn GhcPs) -> RnM (LHsBindsLR GhcRn GhcPs)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (RnM (LHsBindsLR GhcRn GhcPs) -> RnM (LHsBindsLR GhcRn GhcPs))
-> RnM (LHsBindsLR GhcRn GhcPs) -> RnM (LHsBindsLR GhcRn GhcPs)
forall a b. (a -> b) -> a -> b
$ do
do { sel_name <- (RdrName -> TcM Name)
-> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA (Name -> SDoc -> RdrName -> TcM Name
lookupInstDeclBndr Name
cls (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"method")) LIdP GhcPs
LocatedN RdrName
name
; let bind' = HsBind GhcPs
bind { fun_id = sel_name, fun_ext = noExtField }
; return (L loc bind' : rest ) }
rnMethodBindLHS Bool
is_cls_decl Name
_ (L SrcSpanAnnA
loc HsBind GhcPs
bind) LHsBindsLR GhcRn GhcPs
rest
= do { SrcSpan -> TcRnMessage -> TcM ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ DeclSort -> HsBind GhcPs -> TcRnMessage
TcRnIllegalClassBinding DeclSort
decl_sort HsBind GhcPs
bind
; [LocatedA (HsBindLR GhcRn GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LocatedA (HsBindLR GhcRn GhcPs)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBindsLR GhcRn GhcPs
[LocatedA (HsBindLR GhcRn GhcPs)]
rest }
where
decl_sort :: DeclSort
decl_sort | Bool
is_cls_decl = DeclSort
ClassDeclSort
| Bool
otherwise = DeclSort
InstanceDeclSort
renameSigs :: HsSigCtxt
-> [LSig GhcPs]
-> RnM ([LSig GhcRn], FreeVars)
renameSigs :: HsSigCtxt
-> [XRec GhcPs (Sig GhcPs)] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
ctxt [XRec GhcPs (Sig GhcPs)]
sigs
= do { (NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcM ())
-> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcM ()
dupSigDeclErr ([XRec GhcPs (Sig GhcPs)]
-> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs [XRec GhcPs (Sig GhcPs)]
sigs)
; [XRec GhcPs (Sig GhcPs)] -> TcM ()
checkDupMinimalSigs [XRec GhcPs (Sig GhcPs)]
sigs
; (sigs', sig_fvs) <- (GenLocated SrcSpanAnnA (Sig GhcPs)
-> RnM (GenLocated SrcSpanAnnA (Sig GhcRn), NameSet))
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (Sig GhcRn)], NameSet)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, NameSet)) -> f a -> RnM (f b, NameSet)
mapFvRn ((Sig GhcPs -> TcM (Sig GhcRn, NameSet))
-> GenLocated SrcSpanAnnA (Sig GhcPs)
-> RnM (GenLocated SrcSpanAnnA (Sig GhcRn), NameSet)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA (HsSigCtxt -> Sig GhcPs -> TcM (Sig GhcRn, NameSet)
renameSig HsSigCtxt
ctxt)) [XRec GhcPs (Sig GhcPs)]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs
; return (good_sigs, sig_fvs) }
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
renameSig :: HsSigCtxt -> Sig GhcPs -> TcM (Sig GhcRn, NameSet)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
vs LHsSigWcType GhcPs
ty)
= do { new_vs <- (LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name))
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
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 (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) [LIdP GhcPs]
[LocatedN RdrName]
vs
; let doc = SDoc -> HsDocContext
TypeSigCtx ([LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LIdP GhcPs]
[LocatedN RdrName]
vs)
; (new_ty, fvs) <- rnHsSigWcType doc ty
; return (TypeSig noAnn new_vs new_ty, fvs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(ClassOpSig XClassOpSig GhcPs
_ Bool
is_deflt [LIdP GhcPs]
vs LHsSigType GhcPs
ty)
= do { defaultSigs_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DefaultSignatures
; when (is_deflt && not defaultSigs_on) $
addErr (TcRnUnexpectedDefaultSig sig)
; new_v <- mapM (lookupSigOccRnN ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }
where
(LIdP GhcPs
v1:[LIdP GhcPs]
_) = [LIdP GhcPs]
vs
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a class method signature for"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
LocatedN RdrName
v1))
renameSig HsSigCtxt
_ (SpecInstSig ((EpaLocation, EpToken "instance", EpToken "#-}")
_, SourceText
src) LHsSigType GhcPs
ty)
= do { HsDocContext -> LHsSigType GhcPs -> TcM ()
checkInferredVars HsDocContext
doc LHsSigType GhcPs
ty
; (new_ty, fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; addNoNestedForallsContextsErr doc NFC_Specialize
(getLHsInstDeclHead new_ty)
; return (SpecInstSig (noAnn, src) new_ty,fvs) }
where
doc :: HsDocContext
doc = HsDocContext
SpecInstSigCtx
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(SpecSig XSpecSig GhcPs
_ LIdP GhcPs
v [LHsSigType GhcPs]
tys InlinePragma
inl)
= do { new_v <- case HsSigCtxt
ctxt of
TopSigCtxt {} -> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall {ann}.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRn LIdP GhcPs
LocatedN RdrName
v
HsSigCtxt
_ -> HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
LocatedN RdrName
v
; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
; return (SpecSig noAnn new_v new_ty inl, fvs) }
where
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a SPECIALISE signature for"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
LocatedN RdrName
v))
do_one :: ([GenLocated SrcSpanAnnA (HsSigType GhcRn)], NameSet)
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsSigType GhcRn)], NameSet)
do_one ([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys,NameSet
fvs) GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
= do { (new_ty, fvs_ty) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
ty_ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(InlineSig XInlineSig GhcPs
_ LIdP GhcPs
v InlinePragma
s)
= do { new_v <- HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
LocatedN RdrName
v
; return (InlineSig noAnn new_v s, emptyFVs) }
renameSig HsSigCtxt
ctxt (FixSig XFixSig GhcPs
_ FixitySig GhcPs
fsig)
= do { new_fsig <- HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl HsSigCtxt
ctxt FixitySig GhcPs
fsig
; return (FixSig noAnn new_fsig, emptyFVs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(MinimalSig ((EpaLocation, EpToken "#-}")
_, SourceText
s) (L SrcSpanAnnL
l BooleanFormula GhcPs
bf))
= do new_bf <- (LIdP GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (XRec GhcRn (IdP GhcRn)))
-> BooleanFormula GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (BooleanFormula GhcRn)
forall (f :: * -> *) (p :: Pass) (p' :: Pass).
Applicative f =>
(LIdP (GhcPass p) -> f (LIdP (GhcPass p')))
-> BooleanFormula (GhcPass p) -> f (BooleanFormula (GhcPass p'))
bfTraverse (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) BooleanFormula GhcPs
bf
return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(PatSynSig XPatSynSig GhcPs
_ [LIdP GhcPs]
vs LHsSigType GhcPs
ty)
= do { new_vs <- (LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name))
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
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 (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) [LIdP GhcPs]
[LocatedN RdrName]
vs
; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (PatSynSig noAnn new_vs ty', fvs) }
where
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern synonym signature for"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LIdP GhcPs]
[LocatedN RdrName]
vs)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(SCCFunSig ((EpaLocation, EpToken "#-}")
_, SourceText
st) LIdP GhcPs
v Maybe (XRec GhcPs StringLiteral)
s)
= do { new_v <- HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
LocatedN RdrName
v
; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) }
renameSig HsSigCtxt
_ctxt sig :: Sig GhcPs
sig@(CompleteMatchSig ((EpaLocation, Maybe TokDcolon, EpToken "#-}")
_, SourceText
s) [LIdP GhcPs]
bf Maybe (LIdP GhcPs)
mty)
= do new_bf <- (LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name))
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
forall {ann}.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRn [LIdP GhcPs]
[LocatedN RdrName]
bf
new_mty <- traverse lookupLocatedOccRn mty
this_mod <- fmap tcg_mod getGblEnv
unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $
addErrCtxt (text "In" <+> ppr sig) $ failWithTc TcRnOrphanCompletePragma
return (CompleteMatchSig (noAnn, s) new_bf new_mty, emptyFVs)
ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc
ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LocatedN RdrName]
bs = SDoc -> SDoc
quotes ((LocatedN RdrName -> SDoc) -> [LocatedN RdrName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocatedN RdrName]
bs)
okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool
okHsSig :: forall (a :: Pass). HsSigCtxt -> LSig (GhcPass a) -> Bool
okHsSig HsSigCtxt
ctxt (L SrcSpanAnnA
_ Sig (GhcPass a)
sig)
= case (Sig (GhcPass a)
sig, HsSigCtxt
ctxt) of
(ClassOpSig {}, ClsDeclCtxt {}) -> Bool
True
(ClassOpSig {}, InstDeclCtxt {}) -> Bool
True
(ClassOpSig {}, HsSigCtxt
_) -> Bool
False
(TypeSig {}, ClsDeclCtxt {}) -> Bool
False
(TypeSig {}, InstDeclCtxt {}) -> Bool
False
(TypeSig {}, HsSigCtxt
_) -> Bool
True
(PatSynSig {}, TopSigCtxt{}) -> Bool
True
(PatSynSig {}, HsSigCtxt
_) -> Bool
False
(FixSig {}, InstDeclCtxt {}) -> Bool
False
(FixSig {}, HsSigCtxt
_) -> Bool
True
(InlineSig {}, HsBootCtxt {}) -> Bool
False
(InlineSig {}, HsSigCtxt
_) -> Bool
True
(SpecSig {}, TopSigCtxt {}) -> Bool
True
(SpecSig {}, LocalBindCtxt {}) -> Bool
True
(SpecSig {}, InstDeclCtxt {}) -> Bool
True
(SpecSig {}, HsSigCtxt
_) -> Bool
False
(SpecInstSig {}, InstDeclCtxt {}) -> Bool
True
(SpecInstSig {}, HsSigCtxt
_) -> Bool
False
(MinimalSig {}, ClsDeclCtxt {}) -> Bool
True
(MinimalSig {}, HsSigCtxt
_) -> Bool
False
(SCCFunSig {}, HsBootCtxt {}) -> Bool
False
(SCCFunSig {}, HsSigCtxt
_) -> Bool
True
(CompleteMatchSig {}, TopSigCtxt {} ) -> Bool
True
(CompleteMatchSig {}, HsSigCtxt
_) -> Bool
False
(XSig {}, TopSigCtxt {}) -> Bool
True
(XSig {}, InstDeclCtxt {}) -> Bool
True
(XSig {}, HsSigCtxt
_) -> Bool
False
findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs :: [XRec GhcPs (Sig GhcPs)]
-> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs [XRec GhcPs (Sig GhcPs)]
sigs
= ((LocatedN RdrName, Sig GhcPs)
-> (LocatedN RdrName, Sig GhcPs) -> Bool)
-> [(LocatedN RdrName, Sig GhcPs)]
-> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (LocatedN RdrName, Sig GhcPs)
-> (LocatedN RdrName, Sig GhcPs) -> Bool
matching_sig ((GenLocated SrcSpanAnnA (Sig GhcPs)
-> [(LocatedN RdrName, Sig GhcPs)])
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
-> [(LocatedN RdrName, Sig GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)]
expand_sig (Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)])
-> (GenLocated SrcSpanAnnA (Sig GhcPs) -> Sig GhcPs)
-> GenLocated SrcSpanAnnA (Sig GhcPs)
-> [(LocatedN RdrName, Sig GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Sig GhcPs) -> Sig GhcPs
forall l e. GenLocated l e -> e
unLoc) [XRec GhcPs (Sig GhcPs)]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs)
where
expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)]
expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)]
expand_sig sig :: Sig GhcPs
sig@(FixSig XFixSig GhcPs
_ (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
ns Fixity
_)) = [LocatedN RdrName]
-> [Sig GhcPs] -> [(LocatedN RdrName, Sig GhcPs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LIdP GhcPs]
[LocatedN RdrName]
ns (Sig GhcPs -> [Sig GhcPs]
forall a. a -> [a]
repeat Sig GhcPs
sig)
expand_sig sig :: Sig GhcPs
sig@(InlineSig XInlineSig GhcPs
_ LIdP GhcPs
n InlinePragma
_) = [(LIdP GhcPs
LocatedN RdrName
n,Sig GhcPs
sig)]
expand_sig sig :: Sig GhcPs
sig@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
ns LHsSigWcType GhcPs
_) = [(LocatedN RdrName
n,Sig GhcPs
sig) | LocatedN RdrName
n <- [LIdP GhcPs]
[LocatedN RdrName]
ns]
expand_sig sig :: Sig GhcPs
sig@(ClassOpSig XClassOpSig GhcPs
_ Bool
_ [LIdP GhcPs]
ns LHsSigType GhcPs
_) = [(LocatedN RdrName
n,Sig GhcPs
sig) | LocatedN RdrName
n <- [LIdP GhcPs]
[LocatedN RdrName]
ns]
expand_sig sig :: Sig GhcPs
sig@(PatSynSig XPatSynSig GhcPs
_ [LIdP GhcPs]
ns LHsSigType GhcPs
_ ) = [(LocatedN RdrName
n,Sig GhcPs
sig) | LocatedN RdrName
n <- [LIdP GhcPs]
[LocatedN RdrName]
ns]
expand_sig sig :: Sig GhcPs
sig@(SCCFunSig ((EpaLocation, EpToken "#-}")
_, SourceText
_) LIdP GhcPs
n Maybe (XRec GhcPs StringLiteral)
_) = [(LIdP GhcPs
LocatedN RdrName
n,Sig GhcPs
sig)]
expand_sig Sig GhcPs
_ = []
matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool
matching_sig :: (LocatedN RdrName, Sig GhcPs)
-> (LocatedN RdrName, Sig GhcPs) -> Bool
matching_sig (L SrcSpanAnnN
_ RdrName
n1,Sig GhcPs
sig1) (L SrcSpanAnnN
_ RdrName
n2,Sig GhcPs
sig2) = RdrName
n1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
n2 Bool -> Bool -> Bool
&& Sig GhcPs -> Sig GhcPs -> Bool
forall {pass} {pass}. Sig pass -> Sig pass -> Bool
mtch Sig GhcPs
sig1 Sig GhcPs
sig2
mtch :: Sig pass -> Sig pass -> Bool
mtch (FixSig {}) (FixSig {}) = Bool
True
mtch (InlineSig {}) (InlineSig {}) = Bool
True
mtch (TypeSig {}) (TypeSig {}) = Bool
True
mtch (ClassOpSig XClassOpSig pass
_ Bool
d1 [LIdP pass]
_ LHsSigType pass
_) (ClassOpSig XClassOpSig pass
_ Bool
d2 [LIdP pass]
_ LHsSigType pass
_) = Bool
d1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
d2
mtch (PatSynSig XPatSynSig pass
_ [LIdP pass]
_ LHsSigType pass
_) (PatSynSig XPatSynSig pass
_ [LIdP pass]
_ LHsSigType pass
_) = Bool
True
mtch (SCCFunSig{}) (SCCFunSig{}) = Bool
True
mtch Sig pass
_ Sig pass
_ = Bool
False
checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
checkDupMinimalSigs :: [XRec GhcPs (Sig GhcPs)] -> TcM ()
checkDupMinimalSigs [XRec GhcPs (Sig GhcPs)]
sigs
= case (XRec GhcPs (Sig GhcPs) -> Bool)
-> [XRec GhcPs (Sig GhcPs)] -> [XRec GhcPs (Sig GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter XRec GhcPs (Sig GhcPs) -> Bool
forall p. UnXRec p => LSig p -> Bool
isMinimalLSig [XRec GhcPs (Sig GhcPs)]
sigs of
XRec GhcPs (Sig GhcPs)
sig1 : XRec GhcPs (Sig GhcPs)
sig2 : [XRec GhcPs (Sig GhcPs)]
otherSigs -> XRec GhcPs (Sig GhcPs)
-> XRec GhcPs (Sig GhcPs) -> [XRec GhcPs (Sig GhcPs)] -> TcM ()
dupMinimalSigErr XRec GhcPs (Sig GhcPs)
sig1 XRec GhcPs (Sig GhcPs)
sig2 [XRec GhcPs (Sig GhcPs)]
otherSigs
[XRec GhcPs (Sig GhcPs)]
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
localCompletePragmas :: [LSig GhcRn] -> CompleteMatches
localCompletePragmas :: [LSig GhcRn] -> CompleteMatches
localCompletePragmas [LSig GhcRn]
sigs = (GenLocated SrcSpanAnnA (Sig GhcRn) -> Maybe CompleteMatch)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> CompleteMatches
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Sig GhcRn -> Maybe (CompleteMatchX (IdP GhcRn))
Sig GhcRn -> Maybe CompleteMatch
getCompleteSig (Sig GhcRn -> Maybe CompleteMatch)
-> (GenLocated SrcSpanAnnA (Sig GhcRn) -> Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> Maybe CompleteMatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Sig GhcRn) -> Sig GhcRn
forall l e. GenLocated l e -> e
unLoc) ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> CompleteMatches)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> CompleteMatches
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. [a] -> [a]
reverse [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs
where
getCompleteSig :: Sig GhcRn -> Maybe (CompleteMatchX (IdP GhcRn))
getCompleteSig = \case
CompleteMatchSig XCompleteMatchSig GhcRn
_ [XRec GhcRn (IdP GhcRn)]
cons Maybe (XRec GhcRn (IdP GhcRn))
mbTyCon ->
CompleteMatchX (IdP GhcRn) -> Maybe (CompleteMatchX (IdP GhcRn))
forall a. a -> Maybe a
Just (CompleteMatchX (IdP GhcRn) -> Maybe (CompleteMatchX (IdP GhcRn)))
-> CompleteMatchX (IdP GhcRn) -> Maybe (CompleteMatchX (IdP GhcRn))
forall a b. (a -> b) -> a -> b
$ UniqDSet (IdP GhcRn) -> Maybe Name -> CompleteMatchX (IdP GhcRn)
forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
CompleteMatch ([IdP GhcRn] -> UniqDSet (IdP GhcRn)
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([IdP GhcRn] -> UniqDSet (IdP GhcRn))
-> [IdP GhcRn] -> UniqDSet (IdP GhcRn)
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnN (IdP GhcRn) -> IdP GhcRn)
-> [GenLocated SrcSpanAnnN (IdP GhcRn)] -> [IdP GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN (IdP GhcRn) -> IdP GhcRn
forall l e. GenLocated l e -> e
unLoc [XRec GhcRn (IdP GhcRn)]
[GenLocated SrcSpanAnnN (IdP GhcRn)]
cons) ((GenLocated SrcSpanAnnN Name -> Name)
-> Maybe (GenLocated SrcSpanAnnN Name) -> Maybe Name
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn (IdP GhcRn))
Maybe (GenLocated SrcSpanAnnN Name)
mbTyCon)
Sig GhcRn
_ -> Maybe (CompleteMatchX (IdP GhcRn))
forall a. Maybe a
Nothing
type AnnoBody body
= ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW
, Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW
, Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO
, Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnnCO
, Outputable (body GhcPs)
)
rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup :: forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
lm [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = XMG GhcPs (LocatedA (body GhcPs))
origin })
= do { TcRnIf TcGblEnv TcLclEnv Bool -> TcM () -> TcM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (([LocatedA (Match GhcPs (LocatedA (body GhcPs)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms Bool -> Bool -> Bool
&&) (Bool -> Bool)
-> TcRnIf TcGblEnv TcLclEnv Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv Bool
mustn't_be_empty) (TcRnMessage -> TcM ()
addErr (HsMatchContextRn -> TcRnMessage
TcRnEmptyCase HsMatchContextRn
ctxt))
; (new_ms, ms_fvs) <- (LocatedA (Match GhcPs (LocatedA (body GhcPs)))
-> RnM (LocatedA (Match GhcRn (LocatedA (body GhcRn))), NameSet))
-> [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
-> RnM ([LocatedA (Match GhcRn (LocatedA (body GhcRn)))], NameSet)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, NameSet)) -> f a -> RnM (f b, NameSet)
mapFvRn (HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), NameSet)
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody) [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms
; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }
where
mustn't_be_empty :: TcRnIf TcGblEnv TcLclEnv Bool
mustn't_be_empty = case HsMatchContextRn
ctxt of
LamAlt HsLamVariant
LamCases -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
ArrowMatchCtxt (ArrowLamAlt HsLamVariant
LamCases) -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
HsMatchContextRn
_ -> Bool -> Bool
not (Bool -> Bool)
-> TcRnIf TcGblEnv TcLclEnv Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyCase
rnMatch :: AnnoBody body
=> HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody = (Match GhcPs (LocatedA (body GhcPs))
-> TcM (Match GhcRn (LocatedA (body GhcRn)), NameSet))
-> LocatedA (Match GhcPs (LocatedA (body GhcPs)))
-> TcM (LocatedA (Match GhcRn (LocatedA (body GhcRn))), NameSet)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA (HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> Match GhcPs (LocatedA (body GhcPs))
-> TcM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch' HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody)
rnMatch' :: (AnnoBody body)
=> HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch' :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch' HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcPs))
mf, m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
l [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcPs (LocatedA (body GhcPs))
grhss })
= HsMatchContextRn
-> [LPat GhcPs]
-> ([LPat GhcRn]
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
forall a.
HsMatchContextRn
-> [LPat GhcPs]
-> ([LPat GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnPats HsMatchContextRn
ctxt [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats (([LPat GhcRn]
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet))
-> ([LPat GhcRn]
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
forall a b. (a -> b) -> a -> b
$ \ [LPat GhcRn]
pats' -> do
{ (grhss', grhss_fvs) <- HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHSs HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody GRHSs GhcPs (LocatedA (body GhcPs))
grhss
; let mf' = case (HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt, HsMatchContext (LIdP (NoGhcTc GhcPs))
HsMatchContext (LocatedN RdrName)
mf) of
(FunRhs { mc_fun :: forall fn. HsMatchContext fn -> fn
mc_fun = L SrcSpanAnnN
_ Name
funid }, FunRhs { mc_fun :: forall fn. HsMatchContext fn -> fn
mc_fun = L SrcSpanAnnN
lf RdrName
_ })
-> HsMatchContext (LIdP (NoGhcTc GhcPs))
mf { mc_fun = L lf funid }
(HsMatchContext (GenLocated SrcSpanAnnN Name),
HsMatchContext (LocatedN RdrName))
_ -> HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt
; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = L l pats'
, m_grhss = grhss'}, grhss_fvs ) }
rnGRHSs :: AnnoBody body
=> HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHSs :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHSs HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (GRHSs XCGRHSs GhcPs (LocatedA (body GhcPs))
_ [LGRHS GhcPs (LocatedA (body GhcPs))]
grhss HsLocalBinds GhcPs
binds)
= HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn
-> NameSet -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn
-> NameSet -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet))
-> (HsLocalBinds GhcRn
-> NameSet -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcRn
binds' NameSet
_ -> do
(grhss', fvGRHSs) <- (GenLocated EpAnnCO (GRHS GhcPs (LocatedA (body GhcPs)))
-> RnM
(GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn))), NameSet))
-> [GenLocated EpAnnCO (GRHS GhcPs (LocatedA (body GhcPs)))]
-> RnM
([GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn)))],
NameSet)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, NameSet)) -> f a -> RnM (f b, NameSet)
mapFvRn (HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), NameSet)
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody) [LGRHS GhcPs (LocatedA (body GhcPs))]
[GenLocated EpAnnCO (GRHS GhcPs (LocatedA (body GhcPs)))]
grhss
return (GRHSs emptyComments grhss' binds', fvGRHSs)
rnGRHS :: AnnoBody body
=> HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS :: forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody = (GRHS GhcPs (LocatedA (body GhcPs))
-> TcM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet))
-> GenLocated EpAnnCO (GRHS GhcPs (LocatedA (body GhcPs)))
-> TcM
(GenLocated EpAnnCO (GRHS GhcRn (LocatedA (body GhcRn))), NameSet)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA (HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> TcM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet)
forall (body :: * -> *).
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS' HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody)
rnGRHS' :: HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS' :: forall (body :: * -> *).
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS' HsMatchContextRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (GRHS XCGRHS GhcPs (LocatedA (body GhcPs))
_ [GuardLStmt GhcPs]
guards LocatedA (body GhcPs)
rhs)
= do { pattern_guards_allowed <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ [Name]
_ ->
LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody LocatedA (body GhcPs)
rhs
; unless (pattern_guards_allowed || is_standard_guard guards') $
addDiagnostic (nonStdGuardErr guards')
; return (GRHS noAnn guards' rhs', fvs) }
where
is_standard_guard :: [GenLocated l (StmtLR idL idR body)] -> Bool
is_standard_guard [] = Bool
True
is_standard_guard [L l
_ (BodyStmt {})] = Bool
True
is_standard_guard [GenLocated l (StmtLR idL idR body)]
_ = Bool
False
rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl HsSigCtxt
sig_ctxt = FixitySig GhcPs -> RnM (FixitySig GhcRn)
rn_decl
where
rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
rn_decl sig :: FixitySig GhcPs
sig@(FixitySig XFixitySig GhcPs
ns_spec [LIdP GhcPs]
fnames Fixity
fixity)
= do Extension -> TcM () -> TcM ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.ExplicitNamespaces (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XFixitySig GhcPs
NamespaceSpecifier
ns_spec NamespaceSpecifier -> NamespaceSpecifier -> Bool
forall a. Eq a => a -> a -> Bool
/= NamespaceSpecifier
NoNamespaceSpecifier) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcM ()
addErr (FixitySig GhcPs -> TcRnMessage
TcRnNamespacedFixitySigWithoutFlag FixitySig GhcPs
sig)
names <- (LocatedN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name])
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (NamespaceSpecifier
-> LocatedN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
lookup_one XFixitySig GhcPs
NamespaceSpecifier
ns_spec) [LIdP GhcPs]
[LocatedN RdrName]
fnames
return (FixitySig ns_spec names fixity)
lookup_one :: NamespaceSpecifier -> LocatedN RdrName -> RnM [LocatedN Name]
lookup_one :: NamespaceSpecifier
-> LocatedN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
lookup_one NamespaceSpecifier
ns_spec (L SrcSpanAnnN
name_loc RdrName
rdr_name)
= SrcSpanAnnN
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnN
name_loc (IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name])
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall a b. (a -> b) -> a -> b
$
do names <- HsSigCtxt
-> SDoc -> NamespaceSpecifier -> RdrName -> RnM [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what NamespaceSpecifier
ns_spec RdrName
rdr_name
return [ L name_loc name | (_, name) <- names ]
what :: SDoc
what = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fixity signature"
dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM ()
dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcM ()
dupSigDeclErr pairs :: NonEmpty (LocatedN RdrName, Sig GhcPs)
pairs@((L SrcSpanAnnN
loc RdrName
_, Sig GhcPs
_) :| [(LocatedN RdrName, Sig GhcPs)]
_)
= SrcSpan -> TcRnMessage -> TcM ()
addErrAt (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRnMessage
TcRnDuplicateSigDecl NonEmpty (LocatedN RdrName, Sig GhcPs)
pairs
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr :: LSig GhcRn -> TcM ()
misplacedSigErr (L SrcSpanAnnA
loc Sig GhcRn
sig)
= SrcSpan -> TcRnMessage -> TcM ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Sig GhcRn -> TcRnMessage
TcRnMisplacedSigDecl Sig GhcRn
sig
nonStdGuardErr :: (Outputable body,
Anno (Stmt GhcRn body) ~ SrcSpanAnnA)
=> [LStmtLR GhcRn GhcRn body] -> TcRnMessage
nonStdGuardErr :: forall body.
(Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) =>
[LStmtLR GhcRn GhcRn body] -> TcRnMessage
nonStdGuardErr [LStmtLR GhcRn GhcRn body]
guards = NonStandardGuards -> TcRnMessage
TcRnNonStdGuards ([LStmtLR GhcRn GhcRn body] -> NonStandardGuards
forall body.
(Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) =>
[LStmtLR GhcRn GhcRn body] -> NonStandardGuards
NonStandardGuards [LStmtLR GhcRn GhcRn body]
guards)
dupMinimalSigErr :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> RnM ()
dupMinimalSigErr :: XRec GhcPs (Sig GhcPs)
-> XRec GhcPs (Sig GhcPs) -> [XRec GhcPs (Sig GhcPs)] -> TcM ()
dupMinimalSigErr XRec GhcPs (Sig GhcPs)
sig1 XRec GhcPs (Sig GhcPs)
sig2 [XRec GhcPs (Sig GhcPs)]
otherSigs
= SrcSpan -> TcRnMessage -> TcM ()
addErrAt (GenLocated SrcSpanAnnA (Sig GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA XRec GhcPs (Sig GhcPs)
GenLocated SrcSpanAnnA (Sig GhcPs)
sig1) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (Sig GhcPs)
-> XRec GhcPs (Sig GhcPs)
-> [XRec GhcPs (Sig GhcPs)]
-> TcRnMessage
TcRnDuplicateMinimalSig XRec GhcPs (Sig GhcPs)
sig1 XRec GhcPs (Sig GhcPs)
sig2 [XRec GhcPs (Sig GhcPs)]
otherSigs