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