{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Parser.PostProcess (
mkRdrGetField, mkRdrProjection, Fbind,
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl,
mkInlinePragma,
mkOpaquePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
annBinds,
fixValbindsAnn,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
checkImportDecl,
checkExpBlockArguments, checkCmdBlockArguments,
checkPrecP,
checkContext,
checkPattern,
checkPattern_details,
incompleteDoBlock,
ParseContext(..),
checkMonadComp,
checkValDef,
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
mkBangTy,
UnpackednessPragma(..),
mkMultTy,
mkTokenLocation,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
starSym,
warnStarIsType,
warnPrepositiveQualifiedModule,
failOpFewArgs,
failOpNotEnabledImportQualifiedPost,
failOpImportQualifiedTwice,
SumOrTuple (..),
PV,
runPV,
ECP(ECP, unECP),
DisambInfixOp(..),
DisambECP(..),
ecpFromExp,
ecpFromCmd,
PatBuilder,
DisambTD(..),
addUnpackednessP,
dataConBuilderCon,
dataConBuilderDetails,
) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon )
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Fixity
import GHC.Types.Hint
import GHC.Types.SourceText
import GHC.Parser.Types
import GHC.Parser.Lexer
import GHC.Parser.Errors.Types
import GHC.Parser.Errors.Ppr ()
import GHC.Utils.Lexeme ( okConOcc )
import GHC.Types.TyThing
import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey )
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Utils.Misc
import Data.Either
import Data.List ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import qualified GHC.Data.Strict as Strict
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
import Data.Kind ( Type )
import Data.List.NonEmpty (NonEmpty)
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: forall (p :: Pass). LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L SrcSpanAnnA
loc TyClDecl (GhcPass p)
d) = SrcSpanAnnA
-> HsDecl (GhcPass p)
-> GenLocated SrcSpanAnnA (HsDecl (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD (GhcPass p)
NoExtField
noExtField TyClDecl (GhcPass p)
d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: forall (p :: Pass). LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L SrcSpanAnnA
loc InstDecl (GhcPass p)
d) = SrcSpanAnnA
-> HsDecl (GhcPass p)
-> GenLocated SrcSpanAnnA (HsDecl (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD (GhcPass p)
NoExtField
noExtField InstDecl (GhcPass p)
d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc' (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls LayoutInfo
layoutInfo [AddEpAnn]
annsIn
= do { let loc :: SrcSpanAnnA
loc = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
ats, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs, [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
_, [GenLocated SrcSpanAnnA (DocDecl GhcPs)]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; (LocatedN RdrName
cls, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (String -> SDoc
text String
"class") SDoc
whereDots LocatedN RdrName
cls [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann EpAnnComments
cs
; GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = (EpAnn [AddEpAnn]
anns', AnnSortKey
NoAnnSortKey, LayoutInfo
layoutInfo)
, tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = Maybe (LHsContext GhcPs)
mcxt
, tcdLName :: LIdP GhcPs
tcdLName = LIdP GhcPs
LocatedN RdrName
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)])
-> [GenLocated SrcSpanAnnA (FunDep GhcPs)]
forall a b. (a, b) -> b
snd (GenLocated SrcSpan (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)])
-> (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)])
forall l e. GenLocated l e -> e
unLoc Located (a, [LHsFunDep GhcPs])
GenLocated SrcSpan (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)])
fds)
, tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
, tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds
, tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
[GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
ats, tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [LTyFamInstDecl GhcPs]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs
, tcdDocs :: [LDocDecl GhcPs]
tcdDocs = [LDocDecl GhcPs]
[GenLocated SrcSpanAnnA (DocDecl GhcPs)]
docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc' NewOrData
new_or_data Maybe (LocatedP CType)
cType (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr))
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
annsIn
= do { let loc :: SrcSpanAnnA
loc = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
; (LocatedN RdrName
tc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (NewOrData -> SDoc
forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots LocatedN RdrName
tc [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann EpAnnComments
cs
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
EpAnn [AddEpAnn]
anns',
tcdLName :: LIdP GhcPs
tcdLName = LIdP GhcPs
LocatedN RdrName
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }
mkDataDefn :: NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (LocatedP CType)
cType
, dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = Maybe (LHsContext GhcPs)
mcxt
, dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
data_cons
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
annsIn
= do { (LocatedN RdrName
tc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; EpAnnComments
cs1 <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (String -> SDoc
text String
"type") SDoc
equalsDots LocatedN RdrName
tc [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
; EpAnnComments
cs2 <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann (EpAnnComments
cs1 EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
; GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (SynDecl
{ tcdSExt :: XSynDecl GhcPs
tcdSExt = XSynDecl GhcPs
EpAnn [AddEpAnn]
anns'
, tcdLName :: LIdP GhcPs
tcdLName = LIdP GhcPs
LocatedN RdrName
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [LocatedN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [LocatedN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [LocatedN RdrName]
lhs LHsSigType GhcPs
rhs [AddEpAnn]
anns =
do { [LocatedN RdrName]
vs <- (LocatedN RdrName -> P (LocatedN RdrName))
-> [LocatedN RdrName] -> P [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedN RdrName -> P (LocatedN RdrName)
forall {m :: * -> *} {a}.
MonadP m =>
GenLocated (SrcSpanAnn' a) RdrName
-> m (GenLocated (SrcSpanAnn' a) RdrName)
check_lhs_name (Located [LocatedN RdrName] -> [LocatedN RdrName]
forall l e. GenLocated l e -> e
unLoc Located [LocatedN RdrName]
lhs)
; LocatedN RdrName
v <- [LocatedN RdrName] -> P (LocatedN RdrName)
check_singular_lhs ([LocatedN RdrName] -> [LocatedN RdrName]
forall a. [a] -> [a]
reverse [LocatedN RdrName]
vs)
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)))
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> StandaloneKindSig GhcPs
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
(StandaloneKindSig GhcPs
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
-> StandaloneKindSig GhcPs
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
forall a b. (a -> b) -> a -> b
$ XStandaloneKindSig GhcPs
-> LIdP GhcPs -> LHsSigType GhcPs -> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) LIdP GhcPs
LocatedN RdrName
v LHsSigType GhcPs
rhs }
where
check_lhs_name :: GenLocated (SrcSpanAnn' a) RdrName
-> m (GenLocated (SrcSpanAnn' a) RdrName)
check_lhs_name v :: GenLocated (SrcSpanAnn' a) RdrName
v@(GenLocated (SrcSpanAnn' a) RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc->RdrName
name) =
if RdrName -> Bool
isUnqual RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc RdrName
name)
then GenLocated (SrcSpanAnn' a) RdrName
-> m (GenLocated (SrcSpanAnn' a) RdrName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated (SrcSpanAnn' a) RdrName
v
else MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName)
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName))
-> MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated (SrcSpanAnn' a) RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) RdrName
v) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> PsMessage
PsErrUnexpectedQualifiedConstructor (GenLocated (SrcSpanAnn' a) RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' a) RdrName
v))
check_singular_lhs :: [LocatedN RdrName] -> P (LocatedN RdrName)
check_singular_lhs [LocatedN RdrName]
vs =
case [LocatedN RdrName]
vs of
[] -> String -> P (LocatedN RdrName)
forall a. String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
[LocatedN RdrName
v] -> LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedN RdrName
v
[LocatedN RdrName]
_ -> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LocatedN RdrName))
-> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (Located [LocatedN RdrName] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [LocatedN RdrName]
lhs) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
([LIdP GhcPs] -> PsMessage
PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]
[LocatedN RdrName]
vs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn SrcSpan
loc HsOuterFamEqnTyVarBndrs GhcPs
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
anns
= do { (LocatedN RdrName
tc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> P (GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
-> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall a b. (a -> b) -> a -> b
$ FamEqn
{ feqn_ext :: XCFamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
feqn_ext = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
anns [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. Monoid a => a -> a -> a
`mappend` [AddEpAnn]
ann) EpAnnComments
cs
, feqn_tycon :: LIdP GhcPs
feqn_tycon = LIdP GhcPs
LocatedN RdrName
tc
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcPs)
feqn_rhs = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs })}
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs,
LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (LocatedP CType)
cType (Maybe (LHsContext GhcPs)
mcxt, HsOuterFamEqnTyVarBndrs GhcPs
bndrs, LHsType GhcPs
tycl_hdr)
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
anns
= do { (LocatedN RdrName
tc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; let fam_eqn_ans :: EpAnn [AddEpAnn]
fam_eqn_ans = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
ann EpAnnComments
cs) [AddEpAnn]
anns EpAnnComments
emptyComments
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; GenLocated SrcSpanAnnA (InstDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (InstDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> InstDecl GhcPs -> GenLocated SrcSpanAnnA (InstDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcPs
NoExtField
noExtField (FamEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass. FamEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl
(FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsDataDefn GhcPs)
EpAnn [AddEpAnn]
fam_eqn_ans
, feqn_tycon :: LIdP GhcPs
feqn_tycon = LIdP GhcPs
LocatedN RdrName
tc
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn })))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> [AddEpAnn] -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn [AddEpAnn]
anns = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
GenLocated SrcSpanAnnA (InstDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (InstDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> InstDecl GhcPs -> GenLocated SrcSpanAnnA (InstDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcPs
NoExtField
noExtField
(XCTyFamInstDecl GhcPs -> TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass.
XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info TopLevelFlag
topLevel LHsType GhcPs
lhs LFamilyResultSig GhcPs
ksig Maybe (LInjectivityAnn GhcPs)
injAnn [AddEpAnn]
annsIn
= do { (LocatedN RdrName
tc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; EpAnnComments
cs1 <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (FamilyInfo GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamilyInfo GhcPs
info) SDoc
equals_or_where LocatedN RdrName
tc [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
; EpAnnComments
cs2 <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann (EpAnnComments
cs1 EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
; GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExtField
noExtField
(FamilyDecl
{ fdExt :: XCFamilyDecl GhcPs
fdExt = XCFamilyDecl GhcPs
EpAnn [AddEpAnn]
anns'
, fdTopLevel :: TopLevelFlag
fdTopLevel = TopLevelFlag
topLevel
, fdInfo :: FamilyInfo GhcPs
fdInfo = FamilyInfo GhcPs
info, fdLName :: LIdP GhcPs
fdLName = LIdP GhcPs
LocatedN RdrName
tc
, fdTyVars :: LHsQTyVars GhcPs
fdTyVars = LHsQTyVars GhcPs
tyvars
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdResultSig :: LFamilyResultSig GhcPs
fdResultSig = LFamilyResultSig GhcPs
ksig
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injAnn }))) }
where
equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
FamilyInfo GhcPs
DataFamily -> SDoc
empty
FamilyInfo GhcPs
OpenTypeFamily -> SDoc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(L SrcSpanAnnA
loc HsExpr GhcPs
expr)
| HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsUntypedSplice {}) <- HsExpr GhcPs
expr = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA
forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> XRec GhcPs (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpanAnnA
-> HsSplice GhcPs -> GenLocated SrcSpanAnnA (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsQuasiQuote {}) <- HsExpr GhcPs
expr = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA
forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> XRec GhcPs (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpanAnnA
-> HsSplice GhcPs -> GenLocated SrcSpanAnnA (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| Bool
otherwise = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA
forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> XRec GhcPs (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField
(SrcSpanAnnA
-> HsSplice GhcPs -> GenLocated SrcSpanAnnA (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (EpAnn [AddEpAnn]
-> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn SpliceDecoration
BareSplice LHsExpr GhcPs
lexpr))
SpliceExplicitFlag
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName
-> [Located (Maybe FastString)]
-> [AddEpAnn]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName
-> [Located (Maybe FastString)]
-> [AddEpAnn]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc LocatedN RdrName
tycon [Located (Maybe FastString)]
roles [AddEpAnn]
anns
= do { [GenLocated (SrcAnn NoEpAnns) (Maybe Role)]
roles' <- (Located (Maybe FastString)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)))
-> [Located (Maybe FastString)]
-> P [GenLocated (SrcAnn NoEpAnns) (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Located (Maybe FastString)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
; GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)))
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> RoleAnnotDecl GhcPs
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
(RoleAnnotDecl GhcPs
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
-> RoleAnnotDecl GhcPs
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> LIdP GhcPs -> [XRec GhcPs (Maybe Role)] -> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) LIdP GhcPs
LocatedN RdrName
tycon [XRec GhcPs (Maybe Role)]
[GenLocated (SrcAnn NoEpAnns) (Maybe Role)]
roles' }
where
role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]
parse_role :: Located (Maybe FastString)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)))
-> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcAnn NoEpAnns
-> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc_role) Maybe Role
forall a. Maybe a
Nothing
parse_role (L SrcSpan
loc_role (Just FastString
role))
= case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
Just Role
found_role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)))
-> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcAnn NoEpAnns
-> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc_role) (Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role))
-> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
Maybe Role
Nothing ->
let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
MsgEnvelope PsMessage
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)))
-> MsgEnvelope PsMessage
-> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc_role (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(FastString -> [Role] -> PsMessage
PsErrIllegalRoleName FastString
role [Role]
nearby)
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs = (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> P [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
fromSpecTyVarBndr
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr LHsTyVarBndr Specificity GhcPs
bndr = case LHsTyVarBndr Specificity GhcPs
bndr of
(L SrcSpanAnnA
loc (UserTyVar XUserTyVar GhcPs
xtv Specificity
flag LIdP GhcPs
idp)) -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
P ()
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs -> () -> LIdP GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
xtv () LIdP GhcPs
idp)
(L SrcSpanAnnA
loc (KindedTyVar XKindedTyVar GhcPs
xtv Specificity
flag LIdP GhcPs
idp LHsType GhcPs
k)) -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
P ()
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> () -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
xtv () LIdP GhcPs
idp LHsType GhcPs
k)
where
check_spec :: Specificity -> SrcSpanAnnA -> P ()
check_spec :: Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
SpecifiedSpec SrcSpanAnnA
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_spec Specificity
InferredSpec SrcSpanAnnA
loc = MsgEnvelope PsMessage -> P ()
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrInferredTypeVarNotAllowed
annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs
-> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds :: AddEpAnn
-> EpAnnComments
-> HsLocalBinds GhcPs
-> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds AddEpAnn
a EpAnnComments
cs (HsValBinds XHsValBinds GhcPs GhcPs
an HsValBindsLR GhcPs GhcPs
bs) = (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds (AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where AddEpAnn
a XHsValBinds GhcPs GhcPs
EpAnn AnnList
an EpAnnComments
cs) HsValBindsLR GhcPs GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds AddEpAnn
a EpAnnComments
cs (HsIPBinds XHsIPBinds GhcPs GhcPs
an HsIPBinds GhcPs
bs) = (XHsIPBinds GhcPs GhcPs -> HsIPBinds GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds (AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where AddEpAnn
a XHsIPBinds GhcPs GhcPs
EpAnn AnnList
an EpAnnComments
cs) HsIPBinds GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds AddEpAnn
_ EpAnnComments
cs (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x) = (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x, EpAnnComments -> Maybe EpAnnComments
forall a. a -> Maybe a
Just EpAnnComments
cs)
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where an :: AddEpAnn
an@(AddEpAnn AnnKeywordId
_ (EpaSpan RealSrcSpan
rs)) (EpAnn Anchor
a (AnnList Maybe Anchor
anc Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs) EpAnnComments
cs2
| RealSrcSpan -> Bool
valid_anchor (Anchor -> RealSrcSpan
anchor Anchor
a)
= Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (Anchor -> [AddEpAnn] -> Anchor
widenAnchor Anchor
a [AddEpAnn
an]) (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList Maybe Anchor
anc Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
| Bool
otherwise
= Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
rs Anchor
a)
(Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList ((Anchor -> Anchor) -> Maybe Anchor -> Maybe Anchor
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
rs) Maybe Anchor
anc) Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
add_where an :: AddEpAnn
an@(AddEpAnn AnnKeywordId
_ (EpaSpan RealSrcSpan
rs)) EpAnn AnnList
EpAnnNotUsed EpAnnComments
cs
= Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
rs AnchorOperation
UnchangedAnchor)
(Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList (Anchor -> Maybe Anchor
forall a. a -> Maybe a
Just (Anchor -> Maybe Anchor) -> Anchor -> Maybe Anchor
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
rs AnchorOperation
UnchangedAnchor) Maybe AddEpAnn
forall a. Maybe a
Nothing Maybe AddEpAnn
forall a. Maybe a
Nothing [AddEpAnn
an] []) EpAnnComments
cs
add_where (AddEpAnn AnnKeywordId
_ (EpaDelta DeltaPos
_ [LEpaComment]
_)) EpAnn AnnList
_ EpAnnComments
_ = String -> EpAnn AnnList
forall a. String -> a
panic String
"add_where"
valid_anchor :: RealSrcSpan -> Bool
valid_anchor :: RealSrcSpan -> Bool
valid_anchor RealSrcSpan
r = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
r1 (Anchor RealSrcSpan
r0 AnchorOperation
op) = RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r AnchorOperation
op
where
r :: RealSrcSpan
r = if RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then RealSrcSpan
r1 else RealSrcSpan
r0
fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn EpAnn AnnList
EpAnnNotUsed = EpAnn AnnList
forall a. EpAnn a
EpAnnNotUsed
fixValbindsAnn (EpAnn Anchor
anchor (AnnList Maybe Anchor
ma Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs)
= (Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (Anchor -> [AddEpAnn] -> Anchor
widenAnchor Anchor
anchor ((TrailingAnn -> AddEpAnn) -> [TrailingAnn] -> [AddEpAnn]
forall a b. (a -> b) -> [a] -> [b]
map TrailingAnn -> AddEpAnn
trailingAnnToAddEpAnn [TrailingAnn]
t)) (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList Maybe Anchor
ma Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs)
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
decls)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBindsLR GhcPs GhcPs)
cvBindGroup OrdList (LHsDecl GhcPs)
binding
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mbs, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fam_ds, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
tfam_insts
, [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
dfam_insts, [GenLocated SrcSpanAnnA (DocDecl GhcPs)]
_) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; Bool -> P ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fam_ds Bool -> Bool -> Bool
&& [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
tfam_insts Bool -> Bool -> Bool
&& [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
dfam_insts)
; HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs))
-> HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs)
forall a b. (a -> b) -> a -> b
$ XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey
NoAnnSortKey LHsBinds GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mbs [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
fb = do
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
fb' <- [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> P [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall {m :: * -> *} {a}.
MonadP m =>
[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
fb)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)],
[GenLocated SrcSpanAnnA (FamilyDecl GhcPs)],
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)],
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)],
[GenLocated SrcSpanAnnA (DocDecl GhcPs)])
-> P (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)],
[GenLocated SrcSpanAnnA (FamilyDecl GhcPs)],
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)],
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)],
[GenLocated SrcSpanAnnA (DocDecl GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsDecl GhcPs]
-> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
partitionBindsAndSigs ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
fb'))
where
drop_bad_decls :: [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [] = [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
drop_bad_decls (L SrcSpanAnn' a
l (SpliceD XSpliceD GhcPs
_ SpliceDecl GhcPs
d) : [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds) = do
MsgEnvelope PsMessage -> m ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SpliceDecl GhcPs -> PsMessage
PsErrDeclSpliceNotAtTopLevel SpliceDecl GhcPs
d
[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds
drop_bad_decls (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)
d:[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds) = (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)
dGenLocated (SrcSpanAnn' a) (HsDecl GhcPs)
-> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
:) ([GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)])
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (L SrcSpanAnnA
loc1 (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = fun_id1 :: LIdP GhcPs
fun_id1@(L SrcSpanAnnN
_ RdrName
f1)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ m1 :: [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1@[L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1]) } }))
[LHsDecl GhcPs]
binds
| [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1
= [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall ann. SrcAnn ann -> SrcAnn ann
removeCommentsA SrcSpanAnnA
loc1) Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1] (SrcSpanAnnA -> SrcSpanAnnA
forall ann. Monoid ann => SrcAnn ann -> SrcAnn ann
commentsOnlyA SrcSpanAnnA
loc1) [LHsDecl GhcPs]
binds []
where
go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
-> (LHsBind GhcPs,[LHsDecl GhcPs])
go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc
((L SrcSpanAnnA
loc2 (ValD XValD GhcPs
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = (L SrcSpanAnnN
_ RdrName
f2)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [L SrcSpanAnnA
lm2 Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2]) } })))
: [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
| RdrName
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
f2 =
let (SrcSpanAnnA
loc2', SrcSpanAnnA
lm2') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsA SrcSpanAnnA
loc2 SrcSpanAnnA
lm2
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go (SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lm2' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2 GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> [a] -> [a]
: [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mtchs)
(SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA SrcSpanAnnA
loc SrcSpanAnnA
loc2') [LHsDecl GhcPs]
binds []
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(L SrcSpanAnnA
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
= let doc_decls' :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls' = LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
doc_decl GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA SrcSpanAnnA
loc SrcSpanAnnA
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls'
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
= ( SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LIdP GhcPs
LocatedN RdrName
fun_id1 ([GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a e2 an.
Semigroup a =>
[GenLocated (SrcAnn a) e2]
-> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList ([GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mtchs))
, ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
binds)
getMonoBind LHsBind GhcPs
bind [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [] = []
getMonoBindAll (L SrcSpanAnnA
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
b) : [LHsDecl GhcPs]
ds) =
let (L SrcSpanAnnA
l' HsBindLR GhcPs GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
b) [LHsDecl GhcPs]
ds
in SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l' (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
NoExtField
noExtField HsBindLR GhcPs GhcPs
b') GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds'
getMonoBindAll (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
d GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = String -> Bool
forall a. String -> a
panic String
"GHC.Parser.PostProcess.has_args"
has_args (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcPs]
args }) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args)
tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon :: LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon (L SrcSpanAnnN
loc RdrName
tc)
| String -> Bool
okConOcc (OccName -> String
occNameString OccName
occ)
= LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a. a -> Either (MsgEnvelope PsMessage) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))
| Bool
otherwise
= MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a b. a -> Either a b
Left (MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName))
-> MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ (RdrName -> PsMessage
PsErrNotADataCon RdrName
tc)
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
mkPatSynMatchGroup :: LocatedN RdrName
-> LocatedL (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: LocatedN RdrName
-> LocatedL (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpanAnnN
loc RdrName
patsyn_name) (L SrcSpanAnnL
ld OrdList (LHsDecl GhcPs)
decls) =
do { [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches <- (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> P [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
fromDecl (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))
decls)
; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches) (SrcSpan -> P ()
wrongNumberErr (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc))
; MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Origin
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
ld [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches) }
where
fromDecl :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
fromDecl (L SrcSpanAnnA
loc decl :: HsDecl GhcPs
decl@(ValD XValD GhcPs
_ (PatBind XPatBind GhcPs GhcPs
_
pat :: LPat GhcPs
pat@(L SrcSpanAnnA
_ (ConPat XConPat GhcPs
noAnn ln :: XRec GhcPs (ConLikeP GhcPs)
ln@(L SrcSpanAnnN
_ RdrName
name) HsConPatDetails GhcPs
details))
GRHSs GhcPs (LHsExpr GhcPs)
rhs ([CoreTickish], [[CoreTickish]])
_))) =
do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl
; Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match <- case HsConPatDetails GhcPs
details of
PrefixCon [HsPatSigType (NoGhcTc GhcPs)]
_ [LPat GhcPs]
pats -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XConPat GhcPs
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noAnn
, m_ctxt :: HsMatchContext GhcPs
m_ctxt = HsMatchContext GhcPs
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
where
ctxt :: HsMatchContext GhcPs
ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs)
mc_fun = LIdP (NoGhcTc GhcPs)
XRec GhcPs (ConLikeP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
InfixCon LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XConPat GhcPs
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noAnn
, m_ctxt :: HsMatchContext GhcPs
m_ctxt = HsMatchContext GhcPs
ctxt
, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs
p1, LPat GhcPs
p2]
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
where
ctxt :: HsMatchContext GhcPs
ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs)
mc_fun = LIdP (NoGhcTc GhcPs)
XRec GhcPs (ConLikeP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
RecCon{} -> SrcSpan
-> LPat GhcPs
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LPat GhcPs
pat
; GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match }
fromDecl (L SrcSpanAnnA
loc HsDecl GhcPs
decl) = SrcSpan
-> HsDecl GhcPs
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
extraDeclErr (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl
extraDeclErr :: SrcSpan
-> HsDecl GhcPs
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
extraDeclErr SrcSpan
loc HsDecl GhcPs
decl =
MsgEnvelope PsMessage
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> MsgEnvelope PsMessage
-> P (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> HsDecl GhcPs -> PsMessage
PsErrNoSingleWhereBindInPatSynDecl RdrName
patsyn_name HsDecl GhcPs
decl)
wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
MsgEnvelope PsMessage -> P ()
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> HsDecl GhcPs -> PsMessage
PsErrInvalidWhereBindInPatSynDecl RdrName
patsyn_name HsDecl GhcPs
decl)
wrongNumberErr :: SrcSpan -> P ()
wrongNumberErr SrcSpan
loc =
MsgEnvelope PsMessage -> P ()
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> PsMessage
PsErrEmptyWhereInPatSynDecl RdrName
patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
MsgEnvelope PsMessage -> P a
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P a) -> MsgEnvelope PsMessage -> P a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LPat GhcPs -> PsMessage
PsErrRecordSyntaxInPatSynDecl LPat GhcPs
pat)
mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 :: EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 EpAnn [AddEpAnn]
ann LocatedN RdrName
name Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDeclH98Details GhcPs
args
= ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = XConDeclH98 GhcPs
EpAnn [AddEpAnn]
ann
, con_name :: LIdP GhcPs
con_name = LIdP GhcPs
LocatedN RdrName
name
, con_forall :: Bool
con_forall = Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
mb_forall
, con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
mb_forall Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall a. Maybe a -> a -> a
`orElse` []
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
, con_args :: HsConDeclH98Details GhcPs
con_args = HsConDeclH98Details GhcPs
args
, con_doc :: Maybe (LHsDoc GhcPs)
con_doc = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing }
mkGadtDecl :: SrcSpan
-> [LocatedN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LConDecl GhcPs)
mkGadtDecl :: SrcSpan
-> [LocatedN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LConDecl GhcPs)
mkGadtDecl SrcSpan
loc [LocatedN RdrName]
names LHsSigType GhcPs
ty [AddEpAnn]
annsIn = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
let l :: SrcSpanAnnA
l = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
(HsConDeclGADTDetails GhcPs
args, GenLocated SrcSpanAnnA (HsType GhcPs)
res_ty, [AddEpAnn]
annsa, EpAnnComments
csa) <-
case LHsType GhcPs
body_ty of
L SrcSpanAnnA
ll (HsFunTy XFunTy GhcPs
af HsArrow GhcPs
hsArr (L SrcSpanAnnA
loc' (HsRecTy XRecTy GhcPs
an [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) -> do
let an' :: EpAnn AnnList
an' = SrcSpan -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
forall a.
Monoid a =>
SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a
addCommentsToEpAnn (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc') XRecTy GhcPs
EpAnn AnnList
an (EpAnn NoEpAnns -> EpAnnComments
forall ann. EpAnn ann -> EpAnnComments
comments XFunTy GhcPs
EpAnn NoEpAnns
af)
GenLocated TokenLocation (HsUniToken "->" "\8594")
arr <- case HsArrow GhcPs
hsArr of
HsUnrestrictedArrow LHsUniToken "->" "\8594" GhcPs
arr -> GenLocated TokenLocation (HsUniToken "->" "\8594")
-> P (GenLocated TokenLocation (HsUniToken "->" "\8594"))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsUniToken "->" "\8594" GhcPs
GenLocated TokenLocation (HsUniToken "->" "\8594")
arr
HsArrow GhcPs
_ -> do MsgEnvelope PsMessage -> P ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body_ty) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsArrow GhcPs -> PsMessage
PsErrIllegalGadtRecordMultiplicity HsArrow GhcPs
hsArr)
GenLocated TokenLocation (HsUniToken "->" "\8594")
-> P (GenLocated TokenLocation (HsUniToken "->" "\8594"))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated TokenLocation (HsUniToken "->" "\8594")
forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
(HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs),
[AddEpAnn], EpAnnComments)
-> P (HsConDeclGADTDetails GhcPs,
GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XRec GhcPs [LConDeclField GhcPs]
-> LHsUniToken "->" "\8594" GhcPs -> HsConDeclGADTDetails GhcPs
forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT (SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpAnn AnnList -> SrcSpan -> SrcSpanAnnL
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn AnnList
an' (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc')) [LConDeclField GhcPs]
[GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rf) LHsUniToken "->" "\8594" GhcPs
GenLocated TokenLocation (HsUniToken "->" "\8594")
arr, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_ty
, [], EpAnn AnnListItem -> EpAnnComments
forall ann. EpAnn ann -> EpAnnComments
epAnnComments (SrcSpanAnnA -> EpAnn AnnListItem
forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnA
ll))
LHsType GhcPs
_ -> do
let ([AddEpAnn]
anns, EpAnnComments
cs, [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type) = LHsType GhcPs
-> ([AddEpAnn], EpAnnComments, [HsScaled GhcPs (LHsType GhcPs)],
LHsType GhcPs)
forall (p :: Pass).
LHsType (GhcPass p)
-> ([AddEpAnn], EpAnnComments,
[HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
splitHsFunType LHsType GhcPs
body_ty
(HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs),
[AddEpAnn], EpAnnComments)
-> P (HsConDeclGADTDetails GhcPs,
GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_type, [AddEpAnn]
anns, EpAnnComments
cs)
let an :: EpAnn [AddEpAnn]
an = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
annsIn [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
annsa) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csa)
GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> P (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l ConDeclGADT
{ con_g_ext :: XConDeclGADT GhcPs
con_g_ext = XConDeclGADT GhcPs
EpAnn [AddEpAnn]
an
, con_names :: [LIdP GhcPs]
con_names = [LIdP GhcPs]
[LocatedN RdrName]
names
, con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs = SrcSpanAnnA
-> HsOuterSigTyVarBndrs GhcPs
-> GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty) HsOuterSigTyVarBndrs GhcPs
outer_bndrs
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
, con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args = HsConDeclGADTDetails GhcPs
args
, con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_ty
, con_doc :: Maybe (LHsDoc GhcPs)
con_doc = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing }
where
(HsOuterSigTyVarBndrs GhcPs
outer_bndrs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsSigType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs),
LHsType GhcPs)
splitLHsGadtTy LHsSigType GhcPs
ty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual OccName
occ) NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual ModuleName
m OccName
occ) NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig Module
m OccName
occ) NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact Name
n) NameSpace
ns
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
n
= TyThing -> NameSpace -> RdrName
setWiredInNameSpace TyThing
thing NameSpace
ns
| Name -> Bool
isExternalName Name
n
= Module -> OccName -> RdrName
Orig ((() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
n) OccName
occ
| Bool
otherwise
= Name -> RdrName
Exact (Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt (Name -> Unique
nameUnique Name
n) OccName
occ (Name -> SrcSpan
nameSrcSpan Name
n))
where
occ :: OccName
occ = NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns (Name -> OccName
nameOccName Name
n)
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon TyCon
tc) NameSpace
ns
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= TyCon -> RdrName
ty_con_data_con TyCon
tc
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
setWiredInNameSpace (AConLike (RealDataCon DataCon
dc)) NameSpace
ns
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= DataCon -> RdrName
data_con_ty_con DataCon
dc
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
setWiredInNameSpace TyThing
thing NameSpace
ns
= String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con TyCon
tc
| TyCon -> Bool
isTupleTyCon TyCon
tc
, Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
listTyConKey
= Name -> RdrName
Exact Name
nilDataConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
srcDataName (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc))
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con DataCon
dc
| let tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
, TyCon -> Bool
isTupleTyCon TyCon
tc
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey
= Name -> RdrName
Exact Name
listTyConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tcClsName (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))
eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a
eitherToP :: forall (m :: * -> *) a.
MonadP m =>
Either (MsgEnvelope PsMessage) a -> m a
eitherToP (Left MsgEnvelope PsMessage
err) = MsgEnvelope PsMessage -> m a
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError MsgEnvelope PsMessage
err
eitherToP (Right a
thing) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
thing
checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars :: SDoc
-> SDoc
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars SDoc
pp_what SDoc
equals_or_where LocatedN RdrName
tc [LHsTypeArg GhcPs]
tparms
= do { [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs <- (HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> P [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
check [LHsTypeArg GhcPs]
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparms
; LHsQTyVars GhcPs -> P (LHsQTyVars GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs) }
where
check :: HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
check (HsTypeArg SrcSpan
_ ki :: GenLocated SrcSpanAnnA (HsType GhcPs)
ki@(L SrcSpanAnnA
loc HsType GhcPs
_)) = MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LHsType GhcPs -> SDoc -> RdrName -> PsMessage
PsErrUnexpectedTypeAppInDecl LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ki SDoc
pp_what (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc))
check (HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
ty) = [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens [] [] EpAnnComments
emptyComments LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
check (HsArgPar SrcSpan
sp) = MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
sp (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(SDoc -> RdrName -> PsMessage
PsErrMalformedDecl SDoc
pp_what (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc))
chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens :: [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsParTy XParTy GhcPs
an LHsType GhcPs
ty))
= let
(AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
in
[AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
cps) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnn AnnParen -> EpAnnComments
forall ann. EpAnn ann -> EpAnnComments
epAnnComments XParTy GhcPs
EpAnn AnnParen
an) LHsType GhcPs
ty
chkParens [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs LHsType GhcPs
ty = [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs LHsType GhcPs
ty
chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk :: [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsKindSig XKindSig GhcPs
annk (L SrcSpanAnnA
annt (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
lv RdrName
tv))) LHsType GhcPs
k))
| RdrName -> Bool
isRdrTyVar RdrName
tv
= let
an :: [AddEpAnn]
an = ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
in
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> [AddEpAnn] -> SrcSpanAnnA
forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
widenLocatedAn (SrcSpanAnnA
l SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA
annt) [AddEpAnn]
an)
(XKindedTyVar GhcPs
-> () -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (XKindSig GhcPs
EpAnn [AddEpAnn]
annk EpAnn [AddEpAnn] -> EpAnn [AddEpAnn] -> EpAnn [AddEpAnn]
forall a. Semigroup a => a -> a -> a
Semi.<> XTyVar GhcPs
EpAnn [AddEpAnn]
ann) [AddEpAnn]
an EpAnnComments
cs) () (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
lv RdrName
tv) LHsType GhcPs
k))
chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
ltv RdrName
tv)))
| RdrName -> Bool
isRdrTyVar RdrName
tv
= let
an :: [AddEpAnn]
an = ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
in
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> [AddEpAnn] -> SrcSpanAnnA
forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
widenLocatedAn SrcSpanAnnA
l [AddEpAnn]
an)
(XUserTyVar GhcPs -> () -> LIdP GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns XTyVar GhcPs
EpAnn [AddEpAnn]
ann [AddEpAnn]
an EpAnnComments
cs) () (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ltv RdrName
tv)))
chk [AddEpAnn]
_ [AddEpAnn]
_ EpAnnComments
_ t :: LHsType GhcPs
t@(L SrcSpanAnnA
loc HsType GhcPs
_)
= MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs))
-> MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LHsType GhcPs
-> SDoc -> RdrName -> [LHsTypeArg GhcPs] -> SDoc -> PsMessage
PsErrUnexpectedTypeInDecl LHsType GhcPs
t SDoc
pp_what (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc) [LHsTypeArg GhcPs]
tparms SDoc
equals_or_where)
whereDots, equalsDots :: SDoc
whereDots :: SDoc
whereDots = String -> SDoc
text String
"where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text String
"= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
Nothing = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just LHsContext GhcPs
c)
= do Bool
allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DatatypeContextsBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope PsMessage -> P ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsContext GhcPs
GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
c) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LHsContext GhcPs -> PsMessage
PsErrIllegalDataTypeContext LHsContext GhcPs
c)
type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs))
-> [LRuleTyTmVar]
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs)
-> LRuleTyTmVar -> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)
forall a b.
(a -> b)
-> GenLocated (SrcAnn NoEpAnns) a -> GenLocated (SrcAnn NoEpAnns) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar EpAnn [AddEpAnn]
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> LIdP GhcPs -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr XCRuleBndr GhcPs
EpAnn [AddEpAnn]
ann LIdP GhcPs
LocatedN RdrName
v
cvt_one (RuleTyTmVar EpAnn [AddEpAnn]
ann LocatedN RdrName
v (Just LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> LIdP GhcPs -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcPs
EpAnn [AddEpAnn]
ann LIdP GhcPs
LocatedN RdrName
v (EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnn EpaLocation
forall a. EpAnn a
noAnn LHsType GhcPs
sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> [LRuleTyTmVar]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall {a} {ann}.
GenLocated (SrcSpanAnn' a) RuleTyTmVar
-> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
cvt_one
where cvt_one :: GenLocated (SrcSpanAnn' a) RuleTyTmVar
-> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
cvt_one (L SrcSpanAnn' a
l (RuleTyTmVar EpAnn [AddEpAnn]
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
Nothing))
= SrcAnn ann
-> HsTyVarBndr () GhcPs
-> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' a -> SrcAnn ann
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnn' a
l) (XUserTyVar GhcPs -> () -> LIdP GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
EpAnn [AddEpAnn]
ann () ((RdrName -> RdrName) -> LocatedN RdrName -> LocatedN RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty LocatedN RdrName
v))
cvt_one (L SrcSpanAnn' a
l (RuleTyTmVar EpAnn [AddEpAnn]
ann LocatedN RdrName
v (Just LHsType GhcPs
sig)))
= SrcAnn ann
-> HsTyVarBndr () GhcPs
-> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' a -> SrcAnn ann
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnn' a
l) (XKindedTyVar GhcPs
-> () -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
EpAnn [AddEpAnn]
ann () ((RdrName -> RdrName) -> LocatedN RdrName -> LocatedN RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty LocatedN RdrName
v) LHsType GhcPs
sig)
tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
tm_to_ty RdrName
_ = String -> RdrName
forall a. String -> a
panic String
"mkRuleTyVarBndrs"
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> P ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GenLocated SrcSpanAnnA RdrName -> P ()
forall {f :: * -> *} {a}.
MonadP f =>
GenLocated (SrcSpanAnn' a) RdrName -> f ()
check (GenLocated SrcSpanAnnA RdrName -> P ())
-> (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> GenLocated SrcSpanAnnA RdrName)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr flag GhcPs -> RdrName)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> GenLocated SrcSpanAnnA RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr flag GhcPs -> IdP GhcPs
HsTyVarBndr flag GhcPs -> RdrName
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
where check :: GenLocated (SrcSpanAnn' a) RdrName -> f ()
check (L SrcSpanAnn' a
loc (Unqual OccName
occ)) =
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String
"forall",String
"family",String
"role"])
(MsgEnvelope PsMessage -> f ()
forall a. MsgEnvelope PsMessage -> f a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> f ()) -> MsgEnvelope PsMessage -> f ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(OccName -> PsMessage
PsErrParseErrorOnInput OccName
occ))
check GenLocated (SrcSpanAnn' a) RdrName
_ = String -> f ()
forall a. String -> a
panic String
"checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax :: forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
LocatedA a -> m (LocatedA a)
checkRecordSyntax lr :: LocatedA a
lr@(L SrcSpanAnnA
loc a
r)
= do Bool
allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope PsMessage -> m ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(SDoc -> PsMessage
PsErrIllegalTraditionalRecordSyntax (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r))
LocatedA a -> m (LocatedA a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA a
lr
checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
-> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
-> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddEpAnn], [LConDecl GhcPs])
gadts@(L SrcSpan
span ([AddEpAnn]
_, []))
= do Bool
gadtSyntax <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gadtSyntax (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope PsMessage -> P ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
span (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrIllegalWhereInDataDecl
Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
-> P (Located
([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddEpAnn], [LConDecl GhcPs])
Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
gadts
checkEmptyGADTs Located ([AddEpAnn], [LConDecl GhcPs])
gadts = Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
-> P (Located
([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddEpAnn], [LConDecl GhcPs])
Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (LocatedN RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[AddEpAnn])
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[AddEpAnn])
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
= GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty [] [] [] LexicalFixity
Prefix
where
goL :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
goL (L SrcSpanAnnA
l HsType GhcPs
ty) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = SrcSpan
-> HsType GhcPs
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
go (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsType GhcPs
ty [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
go :: SrcSpan
-> HsType GhcPs
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
go SrcSpan
_ (HsParTy XParTy GhcPs
an (L SrcSpanAnnA
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops' [AddEpAnn]
cps' LexicalFixity
fix
= do { SrcSpan -> PsMessage -> P ()
addPsMessage (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) PsMessage
PsWarnStarBinder
; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
; let a' :: SrcSpanAnnN
a' = SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns SrcSpanAnnA
l XParTy GhcPs
EpAnn AnnParen
an
; (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
a' (OccName -> RdrName
Unqual OccName
name), [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix
, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops') [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps') }
go SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: LIdP GhcPs
ltc@(L SrcSpanAnnN
_ RdrName
tc)) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
| RdrName -> Bool
isRdrTc RdrName
tc = (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LIdP GhcPs
LocatedN RdrName
ltc, [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)
go SrcSpan
_ (HsOpTy XOpTy GhcPs
_ PromotionFlag
_ LHsType GhcPs
t1 ltc :: LIdP GhcPs
ltc@(L SrcSpanAnnN
_ RdrName
tc) LHsType GhcPs
t2) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
_fix
| RdrName -> Bool
isRdrTc RdrName
tc = (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LIdP GhcPs
LocatedN RdrName
ltc, GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t2HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
Infix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)
go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
cps) LexicalFixity
fix
where
(AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l)
go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1 (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t2HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc) [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty (SrcSpan
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg XAppKindTy GhcPs
SrcSpan
l LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
kiHsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc) [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
= (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) (Name -> RdrName
nameRdrName Name
tup_name)
, (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts, LexicalFixity
fix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops)[AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++[AddEpAnn]
cps)
where
arity :: Int
arity = [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts
tup_name :: Name
tup_name | Bool
is_cls = Int -> Name
cTupleTyConName Int
arity
| Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
go SrcSpan
l HsType GhcPs
_ [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
_ [AddEpAnn]
_ [AddEpAnn]
_ LexicalFixity
_
= MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn]))
-> MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [AddEpAnn])
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LHsType GhcPs -> PsMessage
PsErrMalformedTyOrClDecl LHsType GhcPs
ty)
newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns (SrcSpanAnn EpAnn AnnListItem
EpAnnNotUsed SrcSpan
l) (EpAnn Anchor
as (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs) =
let
lr :: RealSrcSpan
lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (Anchor -> RealSrcSpan
anchor Anchor
as)
an :: EpAnn NameAnn
an = (Anchor -> NameAnn -> EpAnnComments -> EpAnn NameAnn
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
lr AnchorOperation
UnchangedAnchor) (NameAdornment
-> EpaLocation
-> EpaLocation
-> EpaLocation
-> [TrailingAnn]
-> NameAnn
NameAnn NameAdornment
NameParens EpaLocation
o (RealSrcSpan -> EpaLocation
EpaSpan (RealSrcSpan -> EpaLocation) -> RealSrcSpan -> EpaLocation
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) EpaLocation
c []) EpAnnComments
cs)
in EpAnn NameAnn -> SrcSpan -> SrcSpanAnnN
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn NameAnn
an (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
lr Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
newAnns SrcSpanAnnA
_ EpAnn AnnParen
EpAnnNotUsed = String -> SrcSpanAnnN
forall a. String -> a
panic String
"missing AnnParen"
newAnns (SrcSpanAnn (EpAnn Anchor
ap (AnnListItem [TrailingAnn]
ta) EpAnnComments
csp) SrcSpan
l) (EpAnn Anchor
as (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs) =
let
lr :: RealSrcSpan
lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans (Anchor -> RealSrcSpan
anchor Anchor
ap) (Anchor -> RealSrcSpan
anchor Anchor
as)
an :: EpAnn NameAnn
an = (Anchor -> NameAnn -> EpAnnComments -> EpAnn NameAnn
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
lr AnchorOperation
UnchangedAnchor) (NameAdornment
-> EpaLocation
-> EpaLocation
-> EpaLocation
-> [TrailingAnn]
-> NameAnn
NameAnn NameAdornment
NameParens EpaLocation
o (RealSrcSpan -> EpaLocation
EpaSpan (RealSrcSpan -> EpaLocation) -> RealSrcSpan -> EpaLocation
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) EpaLocation
c [TrailingAnn]
ta) (EpAnnComments
csp EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs))
in EpAnn NameAnn -> SrcSpan -> SrcSpanAnnN
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn NameAnn
an (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
lr Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(LHsExpr GhcPs -> PV ()
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
checkExpBlockArguments, LHsCmd GhcPs -> PV ()
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
checkCmdBlockArguments) = (LHsExpr GhcPs -> PV ()
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
checkExpr, LHsCmd GhcPs -> PV ()
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
checkCmd)
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr LHsExpr GhcPs
expr = case GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr of
HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
m) XRec GhcPs [ExprLStmt GhcPs]
_ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (Maybe ModuleName -> LHsExpr GhcPs -> PsMessage
PsErrDoInFunAppExpr Maybe ModuleName
m) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsDo XDo GhcPs
_ (MDoExpr Maybe ModuleName
m) XRec GhcPs [ExprLStmt GhcPs]
_ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (Maybe ModuleName -> LHsExpr GhcPs -> PsMessage
PsErrMDoInFunAppExpr Maybe ModuleName
m) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsLam {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrLambdaInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsCase {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrCaseInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsLamCase XLamCase GhcPs
_ LamCaseVariant
lc_variant MatchGroup GhcPs (LHsExpr GhcPs)
_ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (LamCaseVariant -> LHsExpr GhcPs -> PsMessage
PsErrLambdaCaseInFunAppExpr LamCaseVariant
lc_variant) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsLet {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrLetInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsIf {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrIfInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsProc {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrProcInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsExpr GhcPs
_ -> () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case GenLocated SrcSpanAnnA (HsCmd GhcPs) -> HsCmd GhcPs
forall l e. GenLocated l e -> e
unLoc LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd of
HsCmdLam {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrLambdaCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdCase {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrCaseCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdLamCase XCmdLamCase GhcPs
_ LamCaseVariant
lc_variant MatchGroup GhcPs (LHsCmd GhcPs)
_ -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (LamCaseVariant -> LHsCmd GhcPs -> PsMessage
PsErrLambdaCaseCmdInFunAppCmd LamCaseVariant
lc_variant) LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdIf {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrIfCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdLet {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrLetCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdDo {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrDoCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmd GhcPs
_ -> () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check :: (GenLocated (SrcSpanAnn' a) e -> PsMessage)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check GenLocated (SrcSpanAnn' a) e -> PsMessage
err GenLocated (SrcSpanAnn' a) e
a = do
Bool
blockArguments <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
MsgEnvelope PsMessage -> m ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated (SrcSpanAnn' a) e -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) e
a) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ (GenLocated (SrcSpanAnn' a) e -> PsMessage
err GenLocated (SrcSpanAnn' a) e
a)
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext orig_t :: LHsType GhcPs
orig_t@(L (SrcSpanAnn EpAnn AnnListItem
_ SrcSpan
l) HsType GhcPs
_orig_t) =
([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([],[],EpAnnComments
emptyComments) LHsType GhcPs
orig_t
where
check :: ([EpaLocation],[EpaLocation],EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsTupleTy XTupleTy GhcPs
ann' HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
= do
let ([EpaLocation]
op,[EpaLocation]
cp,EpAnnComments
cs') = case XTupleTy GhcPs
ann' of
XTupleTy GhcPs
EpAnn AnnParen
EpAnnNotUsed -> ([],[],EpAnnComments
emptyComments)
EpAnn Anchor
_ (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs -> ([EpaLocation
o],[EpaLocation
c],EpAnnComments
cs)
GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnContext)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpAnn AnnContext -> SrcSpan -> SrcSpanAnn' (EpAnn AnnContext)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> AnnContext -> EpAnnComments -> EpAnn AnnContext
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l)
(Maybe (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing ([EpaLocation]
oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation]
op) ([EpaLocation]
cp [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation]
cparens)) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs')) SrcSpan
l) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts)
check ([EpaLocation]
opi,[EpaLocation]
cpi,EpAnnComments
csi) (L SrcSpanAnnA
_lp1 (HsParTy XParTy GhcPs
ann' LHsType GhcPs
ty))
= do
let ([EpaLocation]
op,[EpaLocation]
cp,EpAnnComments
cs') = case XParTy GhcPs
ann' of
XParTy GhcPs
EpAnn AnnParen
EpAnnNotUsed -> ([],[],EpAnnComments
emptyComments)
EpAnn Anchor
_ (AnnParen ParenType
_ EpaLocation
open EpaLocation
close ) EpAnnComments
cs -> ([EpaLocation
open],[EpaLocation
close],EpAnnComments
cs)
([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpaLocation]
op[EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++[EpaLocation]
opi,[EpaLocation]
cp[EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++[EpaLocation]
cpi,EpAnnComments
cs' EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csi) LHsType GhcPs
ty
check ([EpaLocation]
_opi,[EpaLocation]
_cpi,EpAnnComments
_csi) LHsType GhcPs
_t =
GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnContext)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpAnn AnnContext -> SrcSpan -> SrcSpanAnn' (EpAnn AnnContext)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> AnnContext -> EpAnnComments -> EpAnn AnnContext
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l) (Maybe (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) SrcSpan
l) [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
orig_t])
checkImportDecl :: Maybe EpaLocation
-> Maybe EpaLocation
-> P ()
checkImportDecl :: Maybe EpaLocation -> Maybe EpaLocation -> P ()
checkImportDecl Maybe EpaLocation
mPre Maybe EpaLocation
mPost = do
let whenJust :: Maybe a -> (a -> f ()) -> f ()
whenJust Maybe a
mg a -> f ()
f = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> f ()
f Maybe a
mg
Bool
importQualifiedPostEnabled <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ImportQualifiedPostBit
Maybe EpaLocation -> (EpaLocation -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe EpaLocation
mPost ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \EpaLocation
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
post) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
Maybe EpaLocation -> (EpaLocation -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe EpaLocation
mPost ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \EpaLocation
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe EpaLocation -> Bool
forall a. Maybe a -> Bool
isJust Maybe EpaLocation
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpImportQualifiedTwice (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
post) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
Maybe EpaLocation -> (EpaLocation -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe EpaLocation
mPre ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \EpaLocation
pre ->
SrcSpan -> P ()
warnPrepositiveQualifiedModule (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
pre) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> LocatedA (PatBuilder GhcPs)
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat
checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_details ParseContext
extraDetails PV (LocatedA (PatBuilder GhcPs))
pp = ParseContext
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
extraDetails (PV (LocatedA (PatBuilder GhcPs))
pp PV (LocatedA (PatBuilder GhcPs))
-> (LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. PV a -> (a -> PV b) -> PV b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: LocatedA (PatBuilder GhcPs)
e@(L SrcSpanAnnA
l PatBuilder GhcPs
_) = SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
l LocatedA (PatBuilder GhcPs)
e [] []
checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat :: SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpanAnnN
ln RdrName
c))) [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
args
| RdrName -> Bool
isRdrDataCon RdrName
c = GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (LPat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (LPat GhcPs))
-> (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs
-> PV (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Pat GhcPs -> PV (LPat GhcPs)) -> Pat GhcPs -> PV (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ln RdrName
c
, pat_args :: HsConPatDetails GhcPs
pat_args = [HsPatSigType GhcPs]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
(HsPatSigType GhcPs)
(GenLocated SrcSpanAnnA (Pat GhcPs))
(HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args
}
| Bool -> Bool
not ([HsPatSigType GhcPs] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsPatSigType GhcPs]
tyargs) =
SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> PV (LPat GhcPs))
-> (PsErrInPatDetails -> PsMessage)
-> PsErrInPatDetails
-> PV (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage
PsErrInPat PatBuilder GhcPs
e (PsErrInPatDetails -> PV (LPat GhcPs))
-> PsErrInPatDetails -> PV (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsPatSigType GhcPs] -> PsErrInPatDetails
PEIP_TypeArgs [HsPatSigType GhcPs]
tyargs
| (Bool -> Bool
not ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec RdrName
c) = do
ParseContext
ctx <- PV ParseContext
askParseContext
SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (PsErrInPatDetails -> PsMessage)
-> PsErrInPatDetails
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage
PsErrInPat PatBuilder GhcPs
e (PsErrInPatDetails -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PsErrInPatDetails -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> PatIsRecursive -> ParseContext -> PsErrInPatDetails
PEIP_RecPattern [LPat GhcPs]
args PatIsRecursive
YesPatIsRecursive ParseContext
ctx
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
_ (PatBuilderAppType LocatedA (PatBuilder GhcPs)
f HsPatSigType GhcPs
t)) [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
args =
SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
f (HsPatSigType GhcPs
t HsPatSigType GhcPs -> [HsPatSigType GhcPs] -> [HsPatSigType GhcPs]
forall a. a -> [a] -> [a]
: [HsPatSigType GhcPs]
tyargs) [LPat GhcPs]
args
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
_ (PatBuilderApp LocatedA (PatBuilder GhcPs)
f LocatedA (PatBuilder GhcPs)
e)) [] [LPat GhcPs]
args = do
GenLocated SrcSpanAnnA (Pat GhcPs)
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
f [] (GenLocated SrcSpanAnnA (Pat GhcPs)
p GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args)
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
l PatBuilder GhcPs
e) [] [] = do
Pat GhcPs
p <- SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e
GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcPs
p)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
e [HsPatSigType GhcPs]
_ [LPat GhcPs]
_ = do
PsErrInPatDetails
details <- ParseContext -> PsErrInPatDetails
fromParseContext (ParseContext -> PsErrInPatDetails)
-> PV ParseContext -> PV PsErrInPatDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PV ParseContext
askParseContext
SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage
PsErrInPat (LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall l e. GenLocated l e -> e
unLoc LocatedA (PatBuilder GhcPs)
e) PsErrInPatDetails
details)
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e0 = do
Bool
nPlusKPatterns <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
NPlusKPatternsBit
case PatBuilder GhcPs
e0 of
PatBuilderPat Pat GhcPs
p -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat GhcPs
p
PatBuilderVar LocatedN RdrName
x -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField LIdP GhcPs
LocatedN RdrName
x)
PatBuilderOverLit HsOverLit GhcPs
pos_lit -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn NoEpAnns (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs
mkNPat (SrcAnn NoEpAnns
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcAnn NoEpAnns
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
loc) HsOverLit GhcPs
pos_lit) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn)
PatBuilderOpApp
(L SrcSpanAnnA
_ (PatBuilderVar (L SrcSpanAnnN
nloc RdrName
n)))
(L SrcSpanAnnN
l RdrName
plus)
(L SrcSpanAnnA
lloc (PatBuilderOverLit lit :: HsOverLit GhcPs
lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral {}})))
(EpAnn Anchor
anc [AddEpAnn]
_ EpAnnComments
cs)
| Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
-> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedAn NoEpAnns (HsOverLit GhcPs)
-> EpAnn EpaLocation
-> Pat GhcPs
mkNPlusKPat (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc RdrName
n) (SrcAnn NoEpAnns
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcAnn NoEpAnns
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
lloc) HsOverLit GhcPs
lit)
(Anchor -> EpaLocation -> EpAnnComments -> EpAnn EpaLocation
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc (SrcSpanAnnN -> EpaLocation
forall ann. SrcAnn ann -> EpaLocation
epaLocationFromSrcAnn SrcSpanAnnN
l) EpAnnComments
cs))
PatBuilderOpApp LocatedA (PatBuilder GhcPs)
_ LocatedN RdrName
op LocatedA (PatBuilder GhcPs)
_ EpAnn [AddEpAnn]
_ | RdrName -> Bool
opIsAt (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
op) -> do
MsgEnvelope PsMessage -> PV ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> PV ()) -> MsgEnvelope PsMessage -> PV ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (LocatedN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN RdrName
op) PsMessage
PsErrAtInPatPos
Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExtField
noExtField)
PatBuilderOpApp LocatedA (PatBuilder GhcPs)
l (L SrcSpanAnnN
cl RdrName
c) LocatedA (PatBuilder GhcPs)
r EpAnn [AddEpAnn]
anns
| RdrName -> Bool
isRdrDataCon RdrName
c -> do
GenLocated SrcSpanAnnA (Pat GhcPs)
l <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
l
GenLocated SrcSpanAnnA (Pat GhcPs)
r <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
r
Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs)) -> Pat GhcPs -> PV (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = XConPat GhcPs
EpAnn [AddEpAnn]
anns
, pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
cl RdrName
c
, pat_args :: HsConPatDetails GhcPs
pat_args = GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
(HsPatSigType GhcPs)
(GenLocated SrcSpanAnnA (Pat GhcPs))
(HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnA (Pat GhcPs)
l GenLocated SrcSpanAnnA (Pat GhcPs)
r
}
PatBuilderPar LHsToken "(" GhcPs
lpar LocatedA (PatBuilder GhcPs)
e LHsToken ")" GhcPs
rpar -> do
GenLocated SrcSpanAnnA (Pat GhcPs)
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XParPat GhcPs
-> LHsToken "(" GhcPs
-> LPat GhcPs
-> LHsToken ")" GhcPs
-> Pat GhcPs
forall p.
XParPat p -> LHsToken "(" p -> LPat p -> LHsToken ")" p -> Pat p
ParPat (Anchor -> NoEpAnns -> EpAnnComments -> EpAnn NoEpAnns
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)) NoEpAnns
NoEpAnns EpAnnComments
emptyComments) LHsToken "(" GhcPs
lpar LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p LHsToken ")" GhcPs
rpar)
PatBuilder GhcPs
_ -> do
PsErrInPatDetails
details <- ParseContext -> PsErrInPatDetails
fromParseContext (ParseContext -> PsErrInPatDetails)
-> PV ParseContext -> PV PsErrInPatDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PV ParseContext
askParseContext
SrcSpan -> PsMessage -> PV (Pat GhcPs)
forall a. SrcSpan -> PsMessage -> PV a
patFail (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage
PsErrInPat PatBuilder GhcPs
e0 PsErrInPatDetails
details)
placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
placeHolderPunRhs :: forall b. DisambECP b => PV (LocatedA b)
placeHolderPunRhs = LocatedN RdrName -> PV (LocatedA b)
forall b. DisambECP b => LocatedN RdrName -> PV (LocatedA b)
mkHsVarPV (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
pun_RDR)
plus_RDR, pun_RDR :: RdrName
plus_RDR :: RdrName
plus_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"+")
pun_RDR :: RdrName
pun_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pun-right-hand-side")
checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (L SrcSpanAnnA
l HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
fld) = do GenLocated SrcSpanAnnA (Pat GhcPs)
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
-> LocatedA (PatBuilder GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
fld)
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs))))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
fld { hfbRHS :: GenLocated SrcSpanAnnA (Pat GhcPs)
hfbRHS = GenLocated SrcSpanAnnA (Pat GhcPs)
p }))
patFail :: SrcSpan -> PsMessage -> PV a
patFail :: forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
loc PsMessage
msg = MsgEnvelope PsMessage -> PV a
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV a) -> MsgEnvelope PsMessage -> PV a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
msg
patIsRec :: RdrName -> Bool
patIsRec :: RdrName -> Bool
patIsRec RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"rec")
checkValDef :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> Maybe (AddEpAnn, LHsType GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkValDef :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> Maybe (AddEpAnn, LHsType GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (Just (AddEpAnn
sigAnn, LHsType GhcPs
sig)) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
= do GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' <- PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> LHsType GhcPs
-> [AddEpAnn]
-> PV (LocatedA (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpanAnnA
-> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)
mkHsTySigPV (LocatedA (PatBuilder GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
combineLocsA LocatedA (PatBuilder GhcPs)
lhs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
sig) LocatedA (PatBuilder GhcPs)
lhs LHsType GhcPs
sig [AddEpAnn
sigAnn]
PV (LocatedA (PatBuilder GhcPs))
-> (LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. PV a -> (a -> PV b) -> PV b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat
SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc [] LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs Maybe (AddEpAnn, LHsType GhcPs)
Nothing Located (GRHSs GhcPs (LHsExpr GhcPs))
g
= do { Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn])
mb_fun <- LocatedA (PatBuilder GhcPs)
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
lhs
; case Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn])
mb_fun of
Just (LocatedN RdrName
fun, LexicalFixity
is_infix, [LocatedA (PatBuilder GhcPs)]
pats, [AddEpAnn]
ann) ->
SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> LocatedN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
NoSrcStrict SrcSpan
loc [AddEpAnn]
ann
LocatedN RdrName
fun LexicalFixity
is_infix [LocatedA (PatBuilder GhcPs)]
pats Located (GRHSs GhcPs (LHsExpr GhcPs))
g
Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn])
Nothing -> do
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc [] LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' Located (GRHSs GhcPs (LHsExpr GhcPs))
g }
checkFunBind :: SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> LocatedN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkFunBind :: SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> LocatedN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
strictness SrcSpan
locF [AddEpAnn]
ann LocatedN RdrName
fun LexicalFixity
is_infix [LocatedA (PatBuilder GhcPs)]
pats (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss)
= do [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps <- ParseContext
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> P [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
extraDetails ((LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [LocatedA (PatBuilder GhcPs)]
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat [LocatedA (PatBuilder GhcPs)]
pats)
let match_span :: SrcSpanAnnA
match_span = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ SrcSpan
locF
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
locF
HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LocatedN RdrName
fun (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnL
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcSpanAnnL) -> SrcSpan -> SrcSpanAnnL
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
match_span)
[SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
match_span (Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
locF) [AddEpAnn]
ann EpAnnComments
cs
, m_ctxt :: HsMatchContext GhcPs
m_ctxt = FunRhs
{ mc_fun :: LIdP (NoGhcTc GhcPs)
mc_fun = LIdP (NoGhcTc GhcPs)
LocatedN RdrName
fun
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
ps
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss })]))
where
extraDetails :: ParseContext
extraDetails
| LexicalFixity
Infix <- LexicalFixity
is_infix = Maybe RdrName -> PatIncompleteDoBlock -> ParseContext
ParseContext (RdrName -> Maybe RdrName
forall a. a -> Maybe a
Just (RdrName -> Maybe RdrName) -> RdrName -> Maybe RdrName
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
fun) PatIncompleteDoBlock
NoIncompleteDoBlock
| Bool
otherwise = ParseContext
noParseContext
makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind :: LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LocatedN RdrName
fn LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
NoExtField
noExtField,
fun_id :: LIdP GhcPs
fun_id = LIdP GhcPs
LocatedN RdrName
fn,
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms,
fun_tick :: [CoreTickish]
fun_tick = [] }
checkPatBind :: SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkPatBind :: SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc [AddEpAnn]
annsIn (L SrcSpanAnnA
_ (BangPat (EpAnn Anchor
_ [AddEpAnn]
ans EpAnnComments
cs) (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
v))))
(L SrcSpan
_match_span GRHSs GhcPs (LHsExpr GhcPs)
grhss)
= HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LIdP GhcPs
LocatedN RdrName
v (SrcSpanAnnL
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnL
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
[SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
ans[AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++[AddEpAnn]
annsIn) EpAnnComments
cs) LIdP GhcPs
LocatedN RdrName
v)]))
where
m :: EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m EpAnn [AddEpAnn]
a LocatedN RdrName
v = Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
a
, m_ctxt :: HsMatchContext GhcPs
m_ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs)
mc_fun = LIdP (NoGhcTc GhcPs)
LocatedN RdrName
v
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict }
, m_pats :: [LPat GhcPs]
m_pats = []
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss }
checkPatBind SrcSpan
loc [AddEpAnn]
annsIn LPat GhcPs
lhs (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
EpAnnComments
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([CoreTickish], [[CoreTickish]])
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([CoreTickish], [[CoreTickish]])
-> HsBindLR idL idR
PatBind (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
cs) LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ lrdr :: LIdP GhcPs
lrdr@(L SrcSpanAnnN
_ RdrName
v)))
| RdrName -> Bool
isUnqual RdrName
v
, Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc RdrName
v))
= LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return LIdP GhcPs
LocatedN RdrName
lrdr
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpanAnnA
l HsExpr GhcPs
_)
= MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LocatedN RdrName))
-> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> PsMessage
PsErrInvalidTypeSignature LHsExpr GhcPs
lhs
checkDoAndIfThenElse
:: (Outputable a, Outputable b, Outputable c)
=> (a -> Bool -> b -> Bool -> c -> PsMessage)
-> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
checkDoAndIfThenElse :: forall a b c.
(Outputable a, Outputable b, Outputable c) =>
(a -> Bool -> b -> Bool -> c -> PsMessage)
-> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
checkDoAndIfThenElse a -> Bool -> b -> Bool -> c -> PsMessage
err LocatedA a
guardExpr Bool
semiThen LocatedA b
thenExpr Bool
semiElse LocatedA c
elseExpr
| Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse = do
Bool
doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
let e :: PsMessage
e = a -> Bool -> b -> Bool -> c -> PsMessage
err (LocatedA a -> a
forall l e. GenLocated l e -> e
unLoc LocatedA a
guardExpr)
Bool
semiThen (LocatedA b -> b
forall l e. GenLocated l e -> e
unLoc LocatedA b
thenExpr)
Bool
semiElse (LocatedA c -> c
forall l e. GenLocated l e -> e
unLoc LocatedA c
elseExpr)
loc :: SrcSpan
loc = Located a -> Located c -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs (LocatedA a -> Located a
forall a e. LocatedAn a e -> Located e
reLoc LocatedA a
guardExpr) (LocatedA c -> Located c
forall a e. LocatedAn a e -> Located e
reLoc LocatedA c
elseExpr)
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope PsMessage -> PV ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc PsMessage
e)
| Bool
otherwise = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe (LocatedN RdrName, LexicalFixity,
[LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
e = LocatedA (PatBuilder GhcPs)
-> [LocatedA (PatBuilder GhcPs)]
-> [AddEpAnn]
-> [AddEpAnn]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],
[AddEpAnn]))
forall {m :: * -> *} {p}.
Monad m =>
LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
go LocatedA (PatBuilder GhcPs)
e [] [] []
where
go :: LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
go (L SrcSpanAnnA
_ (PatBuilderVar (L SrcSpanAnnN
loc RdrName
f))) [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f) = Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc RdrName
f, LexicalFixity
Prefix, [LocatedA (PatBuilder p)]
es, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps))
go (L SrcSpanAnnA
_ (PatBuilderApp LocatedA (PatBuilder p)
f LocatedA (PatBuilder p)
e)) [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps = LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
go LocatedA (PatBuilder p)
f (LocatedA (PatBuilder p)
eLocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)] -> [LocatedA (PatBuilder p)]
forall a. a -> [a] -> [a]
:[LocatedA (PatBuilder p)]
es) [AddEpAnn]
ops [AddEpAnn]
cps
go (L SrcSpanAnnA
l (PatBuilderPar LHsToken "(" p
_ LocatedA (PatBuilder p)
e LHsToken ")" p
_)) es :: [LocatedA (PatBuilder p)]
es@(LocatedA (PatBuilder p)
_:[LocatedA (PatBuilder p)]
_) [AddEpAnn]
ops [AddEpAnn]
cps
= let
(AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
in
LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
go LocatedA (PatBuilder p)
e [LocatedA (PatBuilder p)]
es (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
cps)
go (L SrcSpanAnnA
loc (PatBuilderOpApp LocatedA (PatBuilder p)
l (L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder p)
r (EpAnn Anchor
loca [AddEpAnn]
anns EpAnnComments
cs))) [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)
= Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
-> m (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder p)],
[AddEpAnn])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op, LexicalFixity
Infix, (LocatedA (PatBuilder p)
lLocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)] -> [LocatedA (PatBuilder p)]
forall a. a -> [a] -> [a]
:LocatedA (PatBuilder p)
rLocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)] -> [LocatedA (PatBuilder p)]
forall a. a -> [a] -> [a]
:[LocatedA (PatBuilder p)]
es), ([AddEpAnn]
anns [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)))
| Bool