{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Rename.Bind (
rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMethodBinds, renameSigs,
rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..)
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )
import GHC.Hs
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 ( HsDocContext(..), mapFvRn
, checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds
, checkUnusedRecordWildcard
, checkDupAndShadowedNames, bindLocalNamesFV
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Driver.Session
import GHC.Unit.Module
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.SrcLoc as SrcLoc
import GHC.Data.List.SetOps ( findDupsEq )
import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) )
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Unique.Set
import GHC.Data.Maybe ( orElse )
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Foldable ( toList )
import Data.List ( partition, sortBy )
import Data.List.NonEmpty ( NonEmpty(..) )
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
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
mbinds [LSig GhcPs]
sigs)
= do { Bool -> SDoc -> TcRn ()
checkErr (forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR -> Bool
isEmptyLHsBinds LHsBindsLR GhcRn GhcPs
mbinds) (LHsBindsLR GhcRn GhcPs -> SDoc
bindsInHsBootFile LHsBindsLR GhcRn GhcPs
mbinds)
; ([GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs', NameSet
fvs) <- HsSigCtxt -> [LSig GhcPs] -> RnM ([LSig GhcRn], NameSet)
renameSigs (NameSet -> HsSigCtxt
HsBootCtxt NameSet
bound_names) [LSig GhcPs]
sigs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR (forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [] [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs'), NameSet -> DefUses
usesOnly NameSet
fvs) }
rnTopBindsBoot NameSet
_ HsValBindsLR GhcRn GhcPs
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnTopBindsBoot" (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 (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x) NameSet
emptyNameSet
rnLocalBindsAndThen (HsValBinds XHsValBinds GhcPs GhcPs
x HsValBinds GhcPs
val_binds) HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside
= forall result.
HsValBinds GhcPs
-> (HsValBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalValBindsAndThen HsValBinds GhcPs
val_binds forall a b. (a -> b) -> a -> b
$ \ HsValBinds GhcRn
val_binds' ->
HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
x HsValBinds GhcRn
val_binds')
rnLocalBindsAndThen (HsIPBinds XHsIPBinds GhcPs GhcPs
x HsIPBinds GhcPs
binds) HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside = do
(HsIPBinds GhcRn
binds',NameSet
fv_binds) <- HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, NameSet)
rnIPBinds HsIPBinds GhcPs
binds
(result
thing, NameSet
fvs_thing) <- HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside (forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcPs GhcPs
x HsIPBinds GhcRn
binds') NameSet
fv_binds
forall (m :: * -> *) a. Monad m => a -> m a
return (result
thing, NameSet
fvs_thing NameSet -> NameSet -> NameSet
`plusFV` NameSet
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
([LocatedA (IPBind GhcRn)]
ip_binds', [NameSet]
fvs_s) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA IPBind GhcPs -> RnM (IPBind GhcRn, NameSet)
rnIPBind) [LIPBind GhcPs]
ip_binds
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds NoExtField
noExtField [LocatedA (IPBind GhcRn)]
ip_binds', [NameSet] -> NameSet
plusFVs [NameSet]
fvs_s)
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, NameSet)
rnIPBind (IPBind XCIPBind GhcPs
_ ~(Left XRec GhcPs HsIPName
n) LHsExpr GhcPs
expr) = do
(GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr',NameSet
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr LHsExpr GhcPs
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCIPBind id
-> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind forall a. EpAnn a
noAnn (forall a b. a -> Either a b
Left XRec GhcPs HsIPName
n) GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', NameSet
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 { HsValBindsLR GhcRn GhcPs
binds' <- NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS (MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env) HsValBinds GhcPs
binds
; let bound_names :: [IdP GhcRn]
bound_names = forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsValBinders forall p. CollectFlag p
CollNoDictBinders HsValBindsLR GhcRn GhcPs
binds'
; (GlobalRdrEnv, LocalRdrEnv)
envs <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
; (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> TcRn ()
checkDupAndShadowedNames (GlobalRdrEnv, LocalRdrEnv)
envs [IdP GhcRn]
bound_names
; forall (m :: * -> *) a. Monad m => a -> m a
return ([IdP GhcRn]
bound_names, HsValBindsLR GhcRn GhcPs
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 [LSig GhcPs]
sigs)
= do { Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcPs))
mbinds' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (NameMaker
-> SDoc -> HsBindLR GhcPs GhcPs -> RnM (HsBindLR GhcRn GhcPs)
rnBindLHS NameMaker
topP SDoc
doc)) LHsBindsLR GhcPs GhcPs
mbinds
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
x Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcPs))
mbinds' [LSig GhcPs]
sigs }
where
bndrs :: [IdP GhcPs]
bndrs = forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders forall p. CollectFlag p
CollNoDictBinders LHsBindsLR GhcPs GhcPs
mbinds
doc :: SDoc
doc = String -> SDoc
text String
"In the binding group for:" SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [IdP GhcPs]
bndrs
rnValBindsLHS NameMaker
_ HsValBinds GhcPs
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnValBindsLHSFromDoc" (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 [LSig GhcPs]
sigs)
= do { ([GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs', NameSet
sig_fvs) <- HsSigCtxt -> [LSig GhcPs] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
ctxt [LSig GhcPs]
sigs
; Bag (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)
binds_w_dus <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM ((Name -> [Name])
-> LHsBindLR GhcRn GhcPs -> RnM (LHsBind GhcRn, [Name], NameSet)
rnLBind ([LSig GhcRn] -> Name -> [Name]
mkScopedTvFn [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs')) LHsBindsLR GhcRn GhcPs
mbinds
; let !([(RecFlag, LHsBinds GhcRn)]
anal_binds, DefUses
anal_dus) = Bag (LHsBind GhcRn, [Name], NameSet)
-> ([(RecFlag, LHsBinds GhcRn)], DefUses)
depAnalBinds Bag (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)
binds_w_dus
; let patsyn_fvs :: NameSet
patsyn_fvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
unionNameSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall idL idR. PatSynBind idL idR -> XPSB idL idR
psb_ext) NameSet
emptyNameSet forall a b. (a -> b) -> a -> b
$
forall id.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds GhcRn)]
anal_binds
valbind'_dus :: DefUses
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
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR (forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds GhcRn)]
anal_binds [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs'), DefUses
valbind'_dus) }
rnValBindsRHS HsSigCtxt
_ HsValBindsLR GhcRn GhcPs
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnValBindsRHS" (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
_ [LSig GhcPs]
sigs) HsValBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside
= do {
MiniFixityEnv
new_fixities <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv [ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FixitySig GhcPs
sig
| L SrcSpanAnnA
loc (FixSig XFixSig GhcPs
_ FixitySig GhcPs
sig) <- [LSig GhcPs]
sigs]
; ([Name]
bound_names, HsValBindsLR GhcRn GhcPs
new_lhs) <- MiniFixityEnv
-> HsValBinds GhcPs -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
new_fixities HsValBinds GhcPs
binds
; forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindLocalNamesFV [Name]
bound_names forall a b. (a -> b) -> a -> b
$
forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
new_fixities [Name]
bound_names forall a b. (a -> b) -> a -> b
$ do
{
(HsValBinds GhcRn
binds', DefUses
dus) <- NameSet
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> NameSet
mkNameSet [Name]
bound_names) HsValBindsLR GhcRn GhcPs
new_lhs
; (result
result, NameSet
result_fvs) <- HsValBinds GhcRn -> NameSet -> RnM (result, NameSet)
thing_inside HsValBinds GhcRn
binds' (DefUses -> NameSet
allUses DefUses
dus)
; let real_uses :: NameSet
real_uses = DefUses -> NameSet -> NameSet
findUses DefUses
dus NameSet
result_fvs
rec_uses :: [(SrcSpan, [Name])]
rec_uses = forall (idR :: Pass).
HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
hsValBindsImplicits HsValBinds GhcRn
binds'
implicit_uses :: NameSet
implicit_uses = [Name] -> NameSet
mkNameSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, [Name])]
rec_uses
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SrcSpan
loc, [Name]
ns) ->
SrcSpan -> NameSet -> Maybe [Name] -> TcRn ()
checkUnusedRecordWildcard SrcSpan
loc NameSet
real_uses (forall a. a -> Maybe a
Just [Name]
ns))
[(SrcSpan, [Name])]
rec_uses
; [Name] -> NameSet -> TcRn ()
warnUnusedLocalBinds [Name]
bound_names
(NameSet
real_uses NameSet -> NameSet -> NameSet
`unionNameSet` NameSet
implicit_uses)
; let
all_uses :: NameSet
all_uses = DefUses -> NameSet
allUses DefUses
dus NameSet -> NameSet -> NameSet
`plusFV` NameSet
result_fvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (result
result, NameSet
all_uses) }}
rnLocalValBindsAndThen HsValBinds GhcPs
bs HsValBinds GhcRn -> NameSet -> RnM (result, NameSet)
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnLocalValBindsAndThen" (forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcPs
bs)
rnBindLHS :: NameMaker
-> SDoc
-> HsBind GhcPs
-> RnM (HsBindLR GhcRn GhcPs)
rnBindLHS :: NameMaker
-> SDoc -> HsBindLR GhcPs GhcPs -> RnM (HsBindLR GhcRn GhcPs)
rnBindLHS NameMaker
name_maker SDoc
_ bind :: HsBindLR GhcPs GhcPs
bind@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcPs
pat })
= do
(GenLocated SrcSpanAnnA (Pat GhcRn)
pat',NameSet
pat'_fvs) <- NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, NameSet)
rnBindPat NameMaker
name_maker LPat GhcPs
pat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsBindLR GhcPs GhcPs
bind { pat_lhs :: LPat GhcRn
pat_lhs = GenLocated SrcSpanAnnA (Pat GhcRn)
pat', pat_ext :: XPatBind GhcRn GhcPs
pat_ext = NameSet
pat'_fvs })
rnBindLHS NameMaker
name_maker SDoc
_ bind :: HsBindLR GhcPs GhcPs
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcPs
rdr_name })
= do { GenLocated SrcSpanAnnN Name
name <- NameMaker -> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
applyNameMaker NameMaker
name_maker LIdP GhcPs
rdr_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsBindLR GhcPs GhcPs
bind { fun_id :: LIdP GhcRn
fun_id = GenLocated SrcSpanAnnN Name
name
, fun_ext :: XFunBind GhcRn GhcPs
fun_ext = NoExtField
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 { forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName LIdP GhcPs
rdrname
; GenLocated SrcSpanAnnN Name
name <- LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
rdrname
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind XPatSynBind GhcPs GhcPs
x PatSynBind GhcPs GhcPs
psb{ psb_ext :: XPSB GhcRn GhcPs
psb_ext = forall a. EpAnn a
noAnn, psb_id :: LIdP GhcRn
psb_id = GenLocated SrcSpanAnnN Name
name }) }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErr SDoc
localPatternSynonymErr
; GenLocated SrcSpanAnnN Name
name <- NameMaker -> LocatedN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
applyNameMaker NameMaker
name_maker LIdP GhcPs
rdrname
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind XPatSynBind GhcPs GhcPs
x PatSynBind GhcPs GhcPs
psb{ psb_ext :: XPSB GhcRn GhcPs
psb_ext = forall a. EpAnn a
noAnn, psb_id :: LIdP GhcRn
psb_id = GenLocated SrcSpanAnnN Name
name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr :: SDoc
localPatternSynonymErr
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal pattern synonym declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
rdrname))
Int
2 (String -> SDoc
text String
"Pattern synonym declarations are only valid at top level")
rnBindLHS NameMaker
_ SDoc
_ HsBindLR GhcPs GhcPs
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnBindHS" (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcPs 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)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { (HsBind GhcRn
bind', [Name]
bndrs, NameSet
dus) <- (Name -> [Name])
-> HsBindLR GhcRn GhcPs -> RnM (HsBind GhcRn, [Name], NameSet)
rnBind Name -> [Name]
sig_fn HsBindLR GhcRn GhcPs
bind
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBind GhcRn
bind', [Name]
bndrs, NameSet
dus) }
rnBind :: (Name -> [Name])
-> HsBindLR GhcRn GhcPs
-> RnM (HsBind GhcRn, [Name], Uses)
rnBind :: (Name -> [Name])
-> HsBindLR GhcRn GhcPs -> RnM (HsBind 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 { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; (GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss', NameSet
rhs_fvs) <- forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHSs forall p. HsMatchContext p
PatBindRhs LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr GRHSs GhcPs (LHsExpr GhcPs)
grhss
; let all_fvs :: NameSet
all_fvs = XPatBind GhcRn GhcPs
pat_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
rhs_fvs
fvs' :: NameSet
fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
all_fvs
bndrs :: [IdP GhcRn]
bndrs = forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat
bind' :: HsBind GhcRn
bind' = HsBindLR GhcRn GhcPs
bind { pat_rhs :: GRHSs GhcRn (LHsExpr GhcRn)
pat_rhs = GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss'
, pat_ext :: XPatBind GhcRn GhcRn
pat_ext = NameSet
fvs' }
ok_nobind_pat :: Bool
ok_nobind_pat
=
case forall l e. GenLocated l e -> e
unLoc LPat GhcRn
pat of
WildPat {} -> Bool
True
BangPat {} -> Bool
True
SplicePat {} -> Bool
True
Pat GhcRn
_ -> Bool
False
; forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedPatternBinds forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IdP GhcRn]
bndrs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ok_nobind_pat) forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedPatternBinds) forall a b. (a -> b) -> a -> b
$
HsBind GhcRn -> SDoc
unusedPatBindWarn HsBind GhcRn
bind'
; NameSet
fvs' seq :: forall a b. a -> b -> b
`seq`
forall (m :: * -> *) a. Monad m => a -> m a
return (HsBind GhcRn
bind', [IdP GhcRn]
bndrs, NameSet
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 = LIdP 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 = forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
name
; (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches', NameSet
rhs_fvs) <- forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV (Name -> [Name]
sig_fn Name
plain_name) forall a b. (a -> b) -> a -> b
$
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
name)
LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
; let is_infix :: Bool
is_infix = forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
isInfixFunBind HsBindLR GhcRn GhcPs
bind
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_infix forall a b. (a -> b) -> a -> b
$ forall body. Name -> MatchGroup GhcRn body -> TcRn ()
checkPrecMatch Name
plain_name MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches'
; Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; let fvs' :: NameSet
fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
rhs_fvs
; NameSet
fvs' seq :: forall a b. a -> b -> b
`seq`
forall (m :: * -> *) a. Monad m => a -> m a
return (HsBindLR GhcRn GhcPs
bind { fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches'
, fun_ext :: XFunBind GhcRn GhcRn
fun_ext = NameSet
fvs' },
[Name
plain_name], NameSet
rhs_fvs)
}
rnBind Name -> [Name]
sig_fn (PatSynBind XPatSynBind GhcRn GhcPs
x PatSynBind GhcRn GhcPs
bind)
= do { (PatSynBind GhcRn GhcRn
bind', [Name]
name, NameSet
fvs) <- (Name -> [Name])
-> PatSynBind GhcRn GhcPs
-> RnM (PatSynBind GhcRn GhcRn, [Name], NameSet)
rnPatSynBind Name -> [Name]
sig_fn PatSynBind GhcRn GhcPs
bind
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind XPatSynBind GhcRn GhcPs
x PatSynBind GhcRn GhcRn
bind', [Name]
name, NameSet
fvs) }
rnBind Name -> [Name]
_ HsBindLR GhcRn GhcPs
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnBind" (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcRn GhcPs
b)
depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
-> ([(RecFlag, LHsBinds GhcRn)], DefUses)
depAnalBinds :: Bag (LHsBind GhcRn, [Name], NameSet)
-> ([(RecFlag, LHsBinds GhcRn)], DefUses)
depAnalBinds Bag (LHsBind GhcRn, [Name], NameSet)
binds_w_dus
= (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. SCC (a, b, c) -> (RecFlag, Bag a)
get_binds [SCC (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)]
sccs, forall a. [a] -> OrdList a
toOL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. SCC (a, [Name], NameSet) -> (Maybe NameSet, NameSet)
get_du [SCC (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)]
sccs)
where
sccs :: [SCC (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)]
sccs = forall node.
(node -> [Name]) -> (node -> [Name]) -> [node] -> [SCC node]
depAnal (\(GenLocated SrcSpanAnnA (HsBind GhcRn)
_, [Name]
defs, NameSet
_) -> [Name]
defs)
(\(GenLocated SrcSpanAnnA (HsBind GhcRn)
_, [Name]
_, NameSet
uses) -> forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet NameSet
uses)
(forall a. Bag a -> [a]
bagToList Bag (LHsBind GhcRn, [Name], NameSet)
binds_w_dus)
get_binds :: SCC (a, b, c) -> (RecFlag, Bag a)
get_binds (AcyclicSCC (a
bind, b
_, c
_)) = (RecFlag
NonRecursive, forall a. a -> Bag a
unitBag a
bind)
get_binds (CyclicSCC [(a, b, c)]
binds_w_dus) = (RecFlag
Recursive, forall a. [a] -> Bag a
listToBag [a
b | (a
b,b
_,c
_) <- [(a, b, c)]
binds_w_dus])
get_du :: SCC (a, [Name], NameSet) -> (Maybe NameSet, NameSet)
get_du (AcyclicSCC (a
_, [Name]
bndrs, NameSet
uses)) = (forall a. a -> Maybe a
Just ([Name] -> NameSet
mkNameSet [Name]
bndrs), NameSet
uses)
get_du (CyclicSCC [(a, [Name], NameSet)]
binds_w_dus) = (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 -> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [Name]
env Name
n forall a. Maybe a -> a -> a
`orElse` []
where
env :: NameEnv [Name]
env = 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
_ [LIdP GhcRn]
names LHsSigType GhcRn
sig_ty))
= forall a. a -> Maybe a
Just ([LIdP GhcRn]
names, LHsSigType GhcRn -> [Name]
hsScopedTvs LHsSigType GhcRn
sig_ty)
get_scoped_tvs (L SrcSpanAnnA
_ (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
sig_ty))
= forall a. a -> Maybe a
Just ([LIdP GhcRn]
names, LHsSigWcType GhcRn -> [Name]
hsWcScopedTvs LHsSigWcType GhcRn
sig_ty)
get_scoped_tvs (L SrcSpanAnnA
_ (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
sig_ty))
= forall a. a -> Maybe a
Just ([LIdP GhcRn]
names, LHsSigType GhcRn -> [Name]
hsScopedTvs LHsSigType GhcRn
sig_ty)
get_scoped_tvs LSig GhcRn
_ = forall a. Maybe a
Nothing
makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv [LFixitySig GhcPs]
decls = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig forall a. FastStringEnv a
emptyFsEnv [LFixitySig 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
_ [LIdP GhcPs]
names Fixity
fixity)) =
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall {e}.
FastStringEnv (GenLocated SrcSpan e)
-> (SrcSpan, SrcSpan, RdrName, e)
-> IOEnv
(Env TcGblEnv TcLclEnv) (FastStringEnv (GenLocated SrcSpan e))
add_one MiniFixityEnv
env [ (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc,forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
name_loc,RdrName
name,Fixity
fixity)
| L SrcSpanAnnN
name_loc RdrName
name <- [LIdP GhcPs]
names ]
add_one :: FastStringEnv (GenLocated SrcSpan e)
-> (SrcSpan, SrcSpan, RdrName, e)
-> IOEnv
(Env TcGblEnv TcLclEnv) (FastStringEnv (GenLocated SrcSpan e))
add_one FastStringEnv (GenLocated SrcSpan e)
env (SrcSpan
loc, SrcSpan
name_loc, RdrName
name,e
fixity) = do
{
let { fs :: FastString
fs = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
name)
; fix_item :: GenLocated SrcSpan e
fix_item = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc e
fixity };
case forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (GenLocated SrcSpan e)
env FastString
fs of
Maybe (GenLocated SrcSpan e)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FastStringEnv a -> FastString -> a -> FastStringEnv a
extendFsEnv FastStringEnv (GenLocated SrcSpan e)
env FastString
fs GenLocated SrcSpan e
fix_item
Just (L SrcSpan
loc' e
_) -> do
{ forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
name_loc (SrcSpan -> RdrName -> SDoc
dupFixityDecl SrcSpan
loc' RdrName
name)
; forall (m :: * -> *) a. Monad m => a -> m a
return FastStringEnv (GenLocated SrcSpan e)
env}
}
dupFixityDecl :: SrcSpan -> RdrName -> SDoc
dupFixityDecl :: SrcSpan -> RdrName -> SDoc
dupFixityDecl SrcSpan
loc RdrName
rdr_name
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Multiple fixity declarations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name),
String -> SDoc
text String
"also at " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc]
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 { Bool
pattern_synonym_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PatternSynonyms
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pattern_synonym_ok (SDoc -> TcRn ()
addErr SDoc
patternSynonymErr)
; let scoped_tvs :: [Name]
scoped_tvs = Name -> [Name]
sig_fn Name
name
; ((GenLocated SrcSpanAnnA (Pat GhcRn)
pat', HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
details'), NameSet
fvs1) <- forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV [Name]
scoped_tvs forall a b. (a -> b) -> a -> b
$
forall a.
HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnPat forall p. HsMatchContext p
PatSyn LPat GhcPs
pat forall a b. (a -> b) -> a -> b
$ \LPat GhcRn
pat' ->
case HsPatSynDetails GhcPs
details of
PrefixCon [Void]
_ [LIdP GhcPs]
vars ->
do { [LocatedN RdrName] -> TcRn ()
checkDupRdrNamesN [LIdP GhcPs]
vars
; [GenLocated SrcSpanAnnN Name]
names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupPatSynBndr [LIdP GhcPs]
vars
; forall (m :: * -> *) a. Monad m => a -> m a
return ( (LPat GhcRn
pat', forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs [GenLocated SrcSpanAnnN Name]
names)
, [Name] -> NameSet
mkFVs (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnN Name]
names)) }
InfixCon LIdP GhcPs
var1 LIdP GhcPs
var2 ->
do { [LocatedN RdrName] -> TcRn ()
checkDupRdrNames [LIdP GhcPs
var1, LIdP GhcPs
var2]
; GenLocated SrcSpanAnnN Name
name1 <- forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupPatSynBndr LIdP GhcPs
var1
; GenLocated SrcSpanAnnN Name
name2 <- forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupPatSynBndr LIdP GhcPs
var2
; forall (m :: * -> *) a. Monad m => a -> m a
return ( (LPat GhcRn
pat', forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnN Name
name1 GenLocated SrcSpanAnnN Name
name2)
, [Name] -> NameSet
mkFVs (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnN Name
name1, GenLocated SrcSpanAnnN Name
name2])) }
RecCon [RecordPatSynField GhcPs]
vars ->
do { [LocatedN RdrName] -> TcRn ()
checkDupRdrNames (forall a b. (a -> b) -> [a] -> [b]
map (forall pass. FieldOcc pass -> LocatedN RdrName
rdrNameFieldOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcPs]
vars)
; [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; let fld_env :: FastStringEnv FieldLabel
fld_env = forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv [ (FieldLabel -> FastString
flLabel FieldLabel
fl, FieldLabel
fl) | FieldLabel
fl <- [FieldLabel]
fls ]
; let rnRecordPatSynField :: RecordPatSynField GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RecordPatSynField GhcRn)
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
; GenLocated SrcSpanAnnN Name
hidden' <- forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupPatSynBndr LIdP GhcPs
hidden
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RecordPatSynField { recordPatSynField :: FieldOcc GhcRn
recordPatSynField = FieldOcc GhcRn
visible'
, recordPatSynPatVar :: LIdP GhcRn
recordPatSynPatVar = GenLocated SrcSpanAnnN Name
hidden' } }
; [RecordPatSynField GhcRn]
names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RecordPatSynField GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RecordPatSynField GhcRn)
rnRecordPatSynField [RecordPatSynField GhcPs]
vars
; forall (m :: * -> *) a. Monad m => a -> m a
return ( (LPat GhcRn
pat', forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon [RecordPatSynField GhcRn]
names)
, [Name] -> NameSet
mkFVs (forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar) [RecordPatSynField GhcRn]
names)) }
; (HsPatSynDir GhcRn
dir', NameSet
fvs2) <- case HsPatSynDir GhcPs
dir of
HsPatSynDir GhcPs
Unidirectional -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. HsPatSynDir id
Unidirectional, NameSet
emptyFVs)
HsPatSynDir GhcPs
ImplicitBidirectional -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. HsPatSynDir id
ImplicitBidirectional, NameSet
emptyFVs)
ExplicitBidirectional MatchGroup GhcPs (LHsExpr GhcPs)
mg ->
do { (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mg', NameSet
fvs) <- forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV [Name]
scoped_tvs forall a b. (a -> b) -> a -> b
$
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
name))
LHsExpr GhcPs -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
mg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
mg', NameSet
fvs) }
; Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; let fvs :: NameSet
fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2
fvs' :: NameSet
fvs' = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) NameSet
fvs
bind' :: PatSynBind GhcRn GhcRn
bind' = PatSynBind GhcRn GhcPs
bind{ psb_args :: HsPatSynDetails GhcRn
psb_args = HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
details'
, psb_def :: LPat GhcRn
psb_def = GenLocated SrcSpanAnnA (Pat GhcRn)
pat'
, psb_dir :: HsPatSynDir GhcRn
psb_dir = HsPatSynDir GhcRn
dir'
, psb_ext :: XPSB GhcRn GhcRn
psb_ext = NameSet
fvs' }
selector_names :: [Name]
selector_names = case HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
details' of
RecCon [RecordPatSynField GhcRn]
names ->
forall a b. (a -> b) -> [a] -> [b]
map (forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcRn]
names
HsConDetails
Void (GenLocated SrcSpanAnnN Name) [RecordPatSynField GhcRn]
_ -> []
; NameSet
fvs' seq :: forall a b. a -> b -> b
`seq`
forall (m :: * -> *) a. Monad m => a -> m a
return (PatSynBind GhcRn GhcRn
bind', Name
name forall a. a -> [a] -> [a]
: [Name]
selector_names , NameSet
fvs1)
}
where
lookupPatSynBndr :: GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupPatSynBndr = forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA RdrName -> RnM Name
lookupLocalOccRn
patternSynonymErr :: SDoc
patternSynonymErr :: SDoc
patternSynonymErr
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal pattern synonym declaration")
Int
2 (String -> SDoc
text String
"Use -XPatternSynonyms to enable this extension")
rnMethodBinds :: Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
rnMethodBinds :: Bool
-> Name
-> [Name]
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
is_cls_decl Name
cls [Name]
ktv_names LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs
= do { [LocatedN RdrName] -> TcRn ()
checkDupRdrNamesN (forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
collectMethodBinders LHsBindsLR GhcPs GhcPs
binds)
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcPs))
binds' <- 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) forall a. Bag a
emptyBag LHsBindsLR GhcPs GhcPs
binds
; let ([LSig GhcPs]
spec_inst_prags, [LSig GhcPs]
other_sigs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig [LSig GhcPs]
sigs
bound_nms :: NameSet
bound_nms = [Name] -> NameSet
mkNameSet (forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders forall p. CollectFlag p
CollNoDictBinders Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcPs))
binds')
sig_ctxt :: HsSigCtxt
sig_ctxt | Bool
is_cls_decl = Name -> HsSigCtxt
ClsDeclCtxt Name
cls
| Bool
otherwise = NameSet -> HsSigCtxt
InstDeclCtxt NameSet
bound_nms
; ([GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_inst_prags', NameSet
sip_fvs) <- HsSigCtxt -> [LSig GhcPs] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
sig_ctxt [LSig GhcPs]
spec_inst_prags
; ([GenLocated SrcSpanAnnA (Sig GhcRn)]
other_sigs', NameSet
sig_fvs) <- forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindLocalNamesFV [Name]
ktv_names forall a b. (a -> b) -> a -> b
$
HsSigCtxt -> [LSig GhcPs] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
sig_ctxt [LSig GhcPs]
other_sigs
; (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds'', NameSet
bind_fvs) <- forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindSigTyVarsFV [Name]
ktv_names forall a b. (a -> b) -> a -> b
$
do { Bag (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)
binds_w_dus <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM ((Name -> [Name])
-> LHsBindLR GhcRn GhcPs -> RnM (LHsBind GhcRn, [Name], NameSet)
rnLBind ([LSig GhcRn] -> Name -> [Name]
mkScopedTvFn [GenLocated SrcSpanAnnA (Sig GhcRn)]
other_sigs')) Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcPs))
binds'
; let bind_fvs :: NameSet
bind_fvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GenLocated SrcSpanAnnA (HsBind GhcRn)
_,[Name]
_,NameSet
fv1) NameSet
fv2 -> NameSet
fv1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv2)
NameSet
emptyFVs Bag (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)
binds_w_dus
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> Bag a -> Bag b
mapBag forall a b c. (a, b, c) -> a
fstOf3 Bag (GenLocated SrcSpanAnnA (HsBind GhcRn), [Name], NameSet)
binds_w_dus, NameSet
bind_fvs) }
; forall (m :: * -> *) a. Monad m => a -> m a
return ( Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds'', [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_inst_prags' forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (Sig GhcRn)]
other_sigs'
, NameSet
sig_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
sip_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
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 :: HsBindLR GhcPs GhcPs
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcPs
name })) LHsBindsLR GhcRn GhcPs
rest
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ do
do { GenLocated SrcSpanAnnN Name
sel_name <- forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (Name -> SDoc -> RdrName -> RnM Name
lookupInstDeclBndr Name
cls (String -> SDoc
text String
"method")) LIdP GhcPs
name
; let bind' :: HsBindLR GhcRn GhcPs
bind' = HsBindLR GhcPs GhcPs
bind { fun_id :: LIdP GhcRn
fun_id = GenLocated SrcSpanAnnN Name
sel_name, fun_ext :: XFunBind GhcRn GhcPs
fun_ext = NoExtField
noExtField }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBindLR GhcRn GhcPs
bind' forall a. a -> Bag a -> Bag a
`consBag` LHsBindsLR GhcRn GhcPs
rest ) }
rnMethodBindLHS Bool
is_cls_decl Name
_ (L SrcSpanAnnA
loc HsBindLR GhcPs GhcPs
bind) LHsBindsLR GhcRn GhcPs
rest
= do { SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"not allowed in" SDoc -> SDoc -> SDoc
<+> SDoc
decl_sort
, Int -> SDoc -> SDoc
nest Int
2 (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcPs GhcPs
bind) ]
; forall (m :: * -> *) a. Monad m => a -> m a
return LHsBindsLR GhcRn GhcPs
rest }
where
decl_sort :: SDoc
decl_sort | Bool
is_cls_decl = String -> SDoc
text String
"class declaration:"
| Bool
otherwise = String -> SDoc
text String
"instance declaration:"
what :: SDoc
what = case HsBindLR GhcPs GhcPs
bind of
PatBind {} -> String -> SDoc
text String
"Pattern bindings (except simple variables)"
PatSynBind {} -> String -> SDoc
text String
"Pattern synonyms"
HsBindLR GhcPs GhcPs
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnMethodBind" (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcPs GhcPs
bind)
renameSigs :: HsSigCtxt
-> [LSig GhcPs]
-> RnM ([LSig GhcRn], FreeVars)
renameSigs :: HsSigCtxt -> [LSig GhcPs] -> RnM ([LSig GhcRn], NameSet)
renameSigs HsSigCtxt
ctxt [LSig GhcPs]
sigs
= do { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRn ()
dupSigDeclErr ([LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs [LSig GhcPs]
sigs)
; [LSig GhcPs] -> TcRn ()
checkDupMinimalSigs [LSig GhcPs]
sigs
; ([GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs', NameSet
sig_fvs) <- forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA (HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, NameSet)
renameSig HsSigCtxt
ctxt)) [LSig GhcPs]
sigs
; let ([GenLocated SrcSpanAnnA (Sig GhcRn)]
good_sigs, [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (a :: Pass). HsSigCtxt -> LSig (GhcPass a) -> Bool
okHsSig HsSigCtxt
ctxt) [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs'
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LSig GhcRn -> TcRn ()
misplacedSigErr [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs
; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated SrcSpanAnnA (Sig GhcRn)]
good_sigs, NameSet
sig_fvs) }
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, NameSet)
renameSig HsSigCtxt
_ (IdSig XIdSig GhcPs
_ Id
x)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XIdSig pass -> Id -> Sig pass
IdSig NoExtField
noExtField Id
x, NameSet
emptyFVs)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
vs LHsSigWcType GhcPs
ty)
= do { [GenLocated SrcSpanAnnN Name]
new_vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) [LIdP GhcPs]
vs
; let doc :: HsDocContext
doc = SDoc -> HsDocContext
TypeSigCtx ([LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LIdP GhcPs]
vs)
; (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
new_ty, NameSet
fvs) <- HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, NameSet)
rnHsSigWcType HsDocContext
doc LHsSigWcType GhcPs
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnN Name]
new_vs HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
new_ty, NameSet
fvs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(ClassOpSig XClassOpSig GhcPs
_ Bool
is_deflt [LIdP GhcPs]
vs LHsSigType GhcPs
ty)
= do { Bool
defaultSigs_on <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DefaultSignatures
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
is_deflt Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
defaultSigs_on) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErr (Sig GhcPs -> SDoc
defaultSigErr Sig GhcPs
sig)
; [GenLocated SrcSpanAnnN Name]
new_v <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) [LIdP GhcPs]
vs
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty, NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
ty_ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig forall a. EpAnn a
noAnn Bool
is_deflt [GenLocated SrcSpanAnnN Name]
new_v GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty, NameSet
fvs) }
where
(LIdP GhcPs
v1:[LIdP GhcPs]
_) = [LIdP GhcPs]
vs
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
text String
"a class method signature for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
v1))
renameSig HsSigCtxt
_ (SpecInstSig XSpecInstSig GhcPs
_ SourceText
src LHsSigType GhcPs
ty)
= do { HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_msg LHsSigType GhcPs
ty
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty, NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc (String -> SDoc
text String
"SPECIALISE instance type")
(forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XSpecInstSig pass -> SourceText -> LHsSigType pass -> Sig pass
SpecInstSig forall a. EpAnn a
noAnn SourceText
src GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty,NameSet
fvs) }
where
doc :: HsDocContext
doc = HsDocContext
SpecInstSigCtx
inf_msg :: Maybe SDoc
inf_msg = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(SpecSig XSpecSig GhcPs
_ LIdP GhcPs
v [LHsSigType GhcPs]
tys InlinePragma
inl)
= do { GenLocated SrcSpanAnnN Name
new_v <- case HsSigCtxt
ctxt of
TopSigCtxt {} -> forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn LIdP GhcPs
v
HsSigCtxt
_ -> HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
v
; ([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
new_ty, NameSet
fvs) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([GenLocated SrcSpanAnnA (HsSigType GhcRn)], NameSet)
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsSigType GhcRn)], NameSet)
do_one ([],NameSet
emptyFVs) [LHsSigType GhcPs]
tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass
SpecSig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnN Name
new_v [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
new_ty InlinePragma
inl, NameSet
fvs) }
where
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
text String
"a SPECIALISE signature for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
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 { (GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ty, NameSet
fvs_ty) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
ty_ctxt TypeOrKind
TypeLevel GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_tyforall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys, NameSet
fvs_ty NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(InlineSig XInlineSig GhcPs
_ LIdP GhcPs
v InlinePragma
s)
= do { GenLocated SrcSpanAnnN Name
new_v <- HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnN Name
new_v InlinePragma
s, NameSet
emptyFVs) }
renameSig HsSigCtxt
ctxt (FixSig XFixSig GhcPs
_ FixitySig GhcPs
fsig)
= do { FixitySig GhcRn
new_fsig <- HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl HsSigCtxt
ctxt FixitySig GhcPs
fsig
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XFixSig pass -> FixitySig pass -> Sig pass
FixSig forall a. EpAnn a
noAnn FixitySig GhcRn
new_fsig, NameSet
emptyFVs) }
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(MinimalSig XMinimalSig GhcPs
_ SourceText
s (L SrcSpanAnnL
l BooleanFormula (LIdP GhcPs)
bf))
= do BooleanFormula (GenLocated SrcSpanAnnN Name)
new_bf <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) BooleanFormula (LIdP GhcPs)
bf
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XMinimalSig pass
-> SourceText -> LBooleanFormula (LIdP pass) -> Sig pass
MinimalSig forall a. EpAnn a
noAnn SourceText
s (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l BooleanFormula (GenLocated SrcSpanAnnN Name)
new_bf), NameSet
emptyFVs)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(PatSynSig XPatSynSig GhcPs
_ [LIdP GhcPs]
vs LHsSigType GhcPs
ty)
= do { [GenLocated SrcSpanAnnN Name]
new_vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig) [LIdP GhcPs]
vs
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
ty_ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnN Name]
new_vs GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', NameSet
fvs) }
where
ty_ctxt :: HsDocContext
ty_ctxt = SDoc -> HsDocContext
GenericCtx (String -> SDoc
text String
"a pattern synonym signature for"
SDoc -> SDoc -> SDoc
<+> [LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LIdP GhcPs]
vs)
renameSig HsSigCtxt
ctxt sig :: Sig GhcPs
sig@(SCCFunSig XSCCFunSig GhcPs
_ SourceText
st LIdP GhcPs
v Maybe (XRec GhcPs StringLiteral)
s)
= do { GenLocated SrcSpanAnnN Name
new_v <- HsSigCtxt
-> Sig GhcPs
-> LocatedN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigOccRnN HsSigCtxt
ctxt Sig GhcPs
sig LIdP GhcPs
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XSCCFunSig pass
-> SourceText
-> LIdP pass
-> Maybe (XRec pass StringLiteral)
-> Sig pass
SCCFunSig forall a. EpAnn a
noAnn SourceText
st GenLocated SrcSpanAnnN Name
new_v Maybe (XRec GhcPs StringLiteral)
s, NameSet
emptyFVs) }
renameSig HsSigCtxt
_ctxt sig :: Sig GhcPs
sig@(CompleteMatchSig XCompleteMatchSig GhcPs
_ SourceText
s (L SrcSpan
l [LocatedN RdrName]
bf) Maybe (LIdP GhcPs)
mty)
= do [GenLocated SrcSpanAnnN Name]
new_bf <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn [LocatedN RdrName]
bf
Maybe (GenLocated SrcSpanAnnN Name)
new_mty <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {ann}.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn Maybe (LIdP GhcPs)
mty
Module
this_mod <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> Module
tcg_mod forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN Name]
new_bf) forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Sig GhcPs
sig) forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> TcM a
failWithTc SDoc
orphanError
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCompleteMatchSig pass
-> SourceText
-> XRec pass [LIdP pass]
-> Maybe (LIdP pass)
-> Sig pass
CompleteMatchSig forall a. EpAnn a
noAnn SourceText
s (forall l e. l -> e -> GenLocated l e
L SrcSpan
l [GenLocated SrcSpanAnnN Name]
new_bf) Maybe (GenLocated SrcSpanAnnN Name)
new_mty, NameSet
emptyFVs)
where
orphanError :: SDoc
orphanError :: SDoc
orphanError =
String -> SDoc
text String
"Orphan COMPLETE pragmas not supported" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"A COMPLETE pragma must mention at least one data constructor" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"or pattern synonym defined in the same module."
ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc
ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc
ppr_sig_bndrs [LocatedN RdrName]
bs = SDoc -> SDoc
quotes (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas 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
(IdSig {}, TopSigCtxt {}) -> Bool
True
(IdSig {}, InstDeclCtxt {}) -> Bool
True
(IdSig {}, HsSigCtxt
_) -> Bool
False
(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
findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
findDupSigs [LSig GhcPs]
sigs
= forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (LocatedN RdrName, Sig GhcPs)
-> (LocatedN RdrName, Sig GhcPs) -> Bool
matching_sig (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)]
expand_sig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LSig 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
_)) = forall a b. [a] -> [b] -> [(a, b)]
zip [LIdP GhcPs]
ns (forall a. a -> [a]
repeat Sig GhcPs
sig)
expand_sig sig :: Sig GhcPs
sig@(InlineSig XInlineSig GhcPs
_ LIdP GhcPs
n InlinePragma
_) = [(LIdP GhcPs
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]
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]
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]
ns]
expand_sig sig :: Sig GhcPs
sig@(SCCFunSig XSCCFunSig GhcPs
_ SourceText
_ LIdP GhcPs
n Maybe (XRec GhcPs StringLiteral)
_) = [(LIdP GhcPs
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 forall a. Eq a => a -> a -> Bool
== RdrName
n2 Bool -> Bool -> 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 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 :: [LSig GhcPs] -> TcRn ()
checkDupMinimalSigs [LSig GhcPs]
sigs
= case forall a. (a -> Bool) -> [a] -> [a]
filter forall p. UnXRec p => LSig p -> Bool
isMinimalLSig [LSig GhcPs]
sigs of
minSigs :: [LSig GhcPs]
minSigs@(LSig GhcPs
_:LSig GhcPs
_:[LSig GhcPs]
_) -> [LSig GhcPs] -> TcRn ()
dupMinimalSigErr [LSig GhcPs]
minSigs
[LSig GhcPs]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
type AnnoBody body
= ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
, Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL
, Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan
, Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan
, Outputable (body GhcPs)
)
rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
-> (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) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatchGroup HsMatchContext GhcRn
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 SrcSpanAnnL
lm [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms, mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
= do { Bool
empty_case_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyCase
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
empty_case_ok) (SDoc -> TcRn ()
addErr (HsMatchContext GhcRn -> SDoc
emptyCaseErr HsMatchContext GhcRn
ctxt))
; ([LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
new_ms, NameSet
ms_fvs) <- forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody) [LocatedA (Match GhcPs (LocatedA (body GhcPs)))]
ms
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
origin (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
lm [LocatedA (Match GhcRn (LocatedA (body GhcRn)))]
new_ms), NameSet
ms_fvs) }
rnMatch :: AnnoBody body
=> HsMatchContext GhcRn
-> (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 =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody = forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA (forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch' HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody)
rnMatch' :: (AnnoBody body)
=> HsMatchContext GhcRn
-> (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 =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), NameSet)
rnMatch' HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (Match { m_ctxt :: forall p body. Match p body -> HsMatchContext (NoGhcTc p)
m_ctxt = HsMatchContext (NoGhcTc GhcPs)
mf, m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcPs]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcPs (LocatedA (body GhcPs))
grhss })
= forall a.
HsMatchContext GhcRn
-> [LPat GhcPs]
-> ([LPat GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnPats HsMatchContext GhcRn
ctxt [LPat GhcPs]
pats forall a b. (a -> b) -> a -> b
$ \ [LPat GhcRn]
pats' -> do
{ (GRHSs GhcRn (LocatedA (body GhcRn))
grhss', NameSet
grhss_fvs) <- forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHSs HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody GRHSs GhcPs (LocatedA (body GhcPs))
grhss
; let mf' :: HsMatchContext GhcRn
mf' = case (HsMatchContext GhcRn
ctxt, HsMatchContext (NoGhcTc GhcPs)
mf) of
(FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP p
mc_fun = L SrcSpanAnnN
_ Name
funid }, FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP p
mc_fun = L SrcSpanAnnN
lf RdrName
_ })
-> HsMatchContext (NoGhcTc GhcPs)
mf { mc_fun :: LIdP GhcRn
mc_fun = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
lf Name
funid }
(HsMatchContext GhcRn, HsMatchContext GhcPs)
_ -> HsMatchContext GhcRn
ctxt
; forall (m :: * -> *) a. Monad m => a -> m a
return (Match { m_ext :: XCMatch GhcRn (LocatedA (body GhcRn))
m_ext = forall a. EpAnn a
noAnn, m_ctxt :: HsMatchContext (NoGhcTc GhcRn)
m_ctxt = HsMatchContext GhcRn
mf', m_pats :: [LPat GhcRn]
m_pats = [LPat GhcRn]
pats'
, m_grhss :: GRHSs GhcRn (LocatedA (body GhcRn))
m_grhss = GRHSs GhcRn (LocatedA (body GhcRn))
grhss'}, NameSet
grhss_fvs ) }
emptyCaseErr :: HsMatchContext GhcRn -> SDoc
emptyCaseErr :: HsMatchContext GhcRn -> SDoc
emptyCaseErr HsMatchContext GhcRn
ctxt = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Empty list of alternatives in" SDoc -> SDoc -> SDoc
<+> HsMatchContext GhcRn -> SDoc
pp_ctxt HsMatchContext GhcRn
ctxt)
Int
2 (String -> SDoc
text String
"Use EmptyCase to allow this")
where
pp_ctxt :: HsMatchContext GhcRn -> SDoc
pp_ctxt :: HsMatchContext GhcRn -> SDoc
pp_ctxt HsMatchContext GhcRn
c = case HsMatchContext GhcRn
c of
HsMatchContext GhcRn
CaseAlt -> String -> SDoc
text String
"case expression"
HsMatchContext GhcRn
LambdaExpr -> String -> SDoc
text String
"\\case expression"
ArrowMatchCtxt HsArrowMatchContext
ArrowCaseAlt -> String -> SDoc
text String
"case expression"
ArrowMatchCtxt HsArrowMatchContext
KappaExpr -> String -> SDoc
text String
"kappa abstraction"
HsMatchContext GhcRn
_ -> String -> SDoc
text String
"(unexpected)" SDoc -> SDoc -> SDoc
<+> forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContextNoun HsMatchContext GhcRn
c
rnGRHSs :: AnnoBody body
=> HsMatchContext GhcRn
-> (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 =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHSs HsMatchContext GhcRn
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)
= forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> NameSet -> RnM (result, NameSet))
-> RnM (result, NameSet)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcRn
binds' NameSet
_ -> do
([GenLocated SrcSpan (GRHS GhcRn (LocatedA (body GhcRn)))]
grhss', NameSet
fvGRHSs) <- forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody) [LGRHS GhcPs (LocatedA (body GhcPs))]
grhss
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated SrcSpan (GRHS GhcRn (LocatedA (body GhcRn)))]
grhss' HsLocalBinds GhcRn
binds', NameSet
fvGRHSs)
rnGRHS :: AnnoBody body
=> HsMatchContext GhcRn
-> (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 =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody = forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM (forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS' HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody)
rnGRHS' :: HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS' :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), NameSet)
rnGRHS' HsMatchContext GhcRn
ctxt LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody (GRHS XCGRHS GhcPs (LocatedA (body GhcPs))
_ [GuardLStmt GhcPs]
guards LocatedA (body GhcPs)
rhs)
= do { Bool
pattern_guards_allowed <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PatternGuards
; (([GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
guards', LocatedA (body GhcRn)
rhs'), NameSet
fvs) <- forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, NameSet))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, NameSet))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), NameSet)
rnStmts (forall p. HsMatchContext p -> HsStmtContext p
PatGuard HsMatchContext GhcRn
ctxt) HsExpr GhcPs -> RnM (HsExpr GhcRn, NameSet)
rnExpr [GuardLStmt GhcPs]
guards forall a b. (a -> b) -> a -> b
$ \ [Name]
_ ->
LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), NameSet)
rnBody LocatedA (body GhcPs)
rhs
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
pattern_guards_allowed Bool -> Bool -> Bool
|| forall {l} {idL} {idR} {body}.
[GenLocated l (StmtLR idL idR body)] -> Bool
is_standard_guard [GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
guards')
(WarnReason -> SDoc -> TcRn ()
addWarn WarnReason
NoReason (forall body.
(Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) =>
[LStmtLR GhcRn GhcRn body] -> SDoc
nonStdGuardErr [GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
guards'))
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA (Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
guards' LocatedA (body GhcRn)
rhs', NameSet
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 (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
fnames Fixity
fixity)
= do [GenLocated SrcSpanAnnN Name]
names <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LocatedN RdrName -> RnM [GenLocated SrcSpanAnnN Name]
lookup_one [LIdP GhcPs]
fnames
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig NoExtField
noExtField [GenLocated SrcSpanAnnN Name]
names Fixity
fixity)
lookup_one :: LocatedN RdrName -> RnM [LocatedN Name]
lookup_one :: LocatedN RdrName -> RnM [GenLocated SrcSpanAnnN Name]
lookup_one (L SrcSpanAnnN
name_loc RdrName
rdr_name)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnN
name_loc forall a b. (a -> b) -> a -> b
$
do [(RdrName, Name)]
names <- HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what RdrName
rdr_name
forall (m :: * -> *) a. Monad m => a -> m a
return [ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
name_loc Name
name | (RdrName
_, Name
name) <- [(RdrName, Name)]
names ]
what :: SDoc
what = String -> SDoc
text String
"fixity signature"
dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM ()
dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRn ()
dupSigDeclErr pairs :: NonEmpty (LocatedN RdrName, Sig GhcPs)
pairs@((L SrcSpanAnnN
loc RdrName
name, Sig GhcPs
sig) :| [(LocatedN RdrName, Sig GhcPs)]
_)
= SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Duplicate" SDoc -> SDoc -> SDoc
<+> SDoc
what_it_is
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"s for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RdrName
name)
, String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (LocatedN RdrName, Sig GhcPs)
pairs)
]
where
what_it_is :: SDoc
what_it_is = forall name. Sig name -> SDoc
hsSigDoc Sig GhcPs
sig
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr :: LSig GhcRn -> TcRn ()
misplacedSigErr (L SrcSpanAnnA
loc Sig GhcRn
sig)
= SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [String -> SDoc
text String
"Misplaced" SDoc -> SDoc -> SDoc
<+> forall name. Sig name -> SDoc
hsSigDoc Sig GhcRn
sig SDoc -> SDoc -> SDoc
<> SDoc
colon, forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
sig]
defaultSigErr :: Sig GhcPs -> SDoc
defaultSigErr :: Sig GhcPs -> SDoc
defaultSigErr Sig GhcPs
sig = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Unexpected default signature:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr Sig GhcPs
sig)
, String -> SDoc
text String
"Use DefaultSignatures to enable default signatures" ]
bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
bindsInHsBootFile LHsBindsLR GhcRn GhcPs
mbinds
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bindings in hs-boot files are not allowed")
Int
2 (forall a. Outputable a => a -> SDoc
ppr LHsBindsLR GhcRn GhcPs
mbinds)
nonStdGuardErr :: (Outputable body,
Anno (Stmt GhcRn body) ~ SrcSpanAnnA)
=> [LStmtLR GhcRn GhcRn body] -> SDoc
nonStdGuardErr :: forall body.
(Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) =>
[LStmtLR GhcRn GhcRn body] -> SDoc
nonStdGuardErr [LStmtLR GhcRn GhcRn body]
guards
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"accepting non-standard pattern guards (use PatternGuards to suppress this message)")
Int
4 (forall a. Outputable a => [a] -> SDoc
interpp'SP [LStmtLR GhcRn GhcRn body]
guards)
unusedPatBindWarn :: HsBind GhcRn -> SDoc
unusedPatBindWarn :: HsBind GhcRn -> SDoc
unusedPatBindWarn HsBind GhcRn
bind
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"This pattern-binding binds no variables:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
bind)
dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
dupMinimalSigErr :: [LSig GhcPs] -> TcRn ()
dupMinimalSigErr sigs :: [LSig GhcPs]
sigs@(L SrcSpanAnnA
loc Sig GhcPs
_ : [LSig GhcPs]
_)
= SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Multiple minimal complete definitions"
, String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [LSig GhcPs]
sigs)
, String -> SDoc
text String
"Combine alternative minimal complete definitions with `|'" ]
dupMinimalSigErr [] = forall a. String -> a
panic String
"dupMinimalSigErr"