{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Parser.PostProcess (
mkRdrGetField, mkRdrProjection, Fbind,
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkMDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl,
mkInlinePragma,
mkOpaquePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
annBinds,
stmtsAnchor, stmtsLoc,
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,
mkMultAnn,
mkTokenLocation,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
starSym,
warnStarIsType,
warnPrepositiveQualifiedModule,
failOpFewArgs,
failNotEnabledImportQualifiedPost,
failImportQualifiedTwice,
SumOrTuple (..),
PV,
runPV,
ECP(ECP, unECP),
DisambInfixOp(..),
DisambECP(..),
ecpFromExp,
ecpFromCmd,
ecpFromPat,
ArrowParsingMode(..),
withArrowParsingMode, withArrowParsingMode',
setTelescopeBndrsNameSpace,
PatBuilder,
hsHoleExpr,
DisambTD(..),
addUnpackednessP,
dataConBuilderCon,
dataConBuilderDetails,
mkUnboxedSumCon,
mkTupleSyntaxTy,
mkTupleSyntaxTycon,
mkListSyntaxTy0,
mkListSyntaxTy1,
withCombinedComments,
requireLTPuns,
) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName )
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
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.Utils.Lexeme ( okConOcc )
import GHC.Types.TyThing
import GHC.Core.Type ( Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey, sumDataCon,
unrestrictedFunTyCon , listTyCon_RDR, unitDataCon )
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 GHC.Utils.Monad (unlessM)
import Data.Either
import Data.List ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
import GHC.Unit.Module.Warnings
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
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)
-> EpLayout
-> AnnClassDecl
-> P (LTyClDecl GhcPs)
mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> EpLayout
-> AnnClassDecl
-> 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 EpLayout
layout AnnClassDecl
annsIn
= do { (binds, sigs, ats, at_defs, _, docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; (cls, tparams, fixity, ops, cps, cs) <- checkTyClHdr True tycl_hdr
; tyvars <- checkTyVars (text "class") whereDots cls tparams
; let anns' = AnnClassDecl
annsIn { acd_openp = ops, acd_closep = cps}
; let loc = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc') AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdFDs = snd (unLoc fds)
, tcdSigs = mkClassOpSigs sigs
, tcdMeths = binds
, tcdATs = ats, tcdATDefs = at_defs
, tcdDocs = docs })) }
mkTyData :: SrcSpan
-> Bool
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> AnnDataDefn
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> Bool
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> AnnDataDefn
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc' Bool
is_type_data 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) AnnDataDefn
annsIn
= do { (tc, tparams, fixity, ops, cps, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; let anns = AnnDataDefn
annsIn {andd_openp = ops, andd_closep = cps}
; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns
; !cs' <- getCommentsFor loc'
; let loc = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc') AnnListItem
forall a. NoAnn a => a
noAnn (EpAnnComments
cs' EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs)
; return (L loc (DataDecl { tcdDExt = noExtField,
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdDataDefn = defn })) }
mkDataDefn :: Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> DataDefnCons (LConDecl GhcPs)
-> HsDeriving GhcPs
-> AnnDataDefn
-> P (HsDataDefn GhcPs)
mkDataDefn :: Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> DataDefnCons (LConDecl GhcPs)
-> HsDeriving GhcPs
-> AnnDataDefn
-> P (HsDataDefn GhcPs)
mkDataDefn Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig DataDefnCons (LConDecl GhcPs)
data_cons HsDeriving GhcPs
maybe_deriv AnnDataDefn
anns
= 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
AnnDataDefn
anns
, 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 :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (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
-> EpToken "type"
-> EpToken "="
-> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> EpToken "type"
-> EpToken "="
-> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs EpToken "type"
antype EpToken "="
aneq
= do { (tc, tparams, fixity, ops, cps, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
lhs
; tyvars <- checkTyVars (text "type") equalsDots tc tparams
; let anns = [EpToken "("]
-> [EpToken ")"] -> EpToken "type" -> EpToken "=" -> AnnSynDecl
AnnSynDecl [EpToken "("]
ops [EpToken ")"]
cps EpToken "type"
antype EpToken "="
aneq
; let loc' = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
; return (L loc' (SynDecl { tcdSExt = anns
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [LocatedN RdrName]
-> LHsSigType GhcPs
-> (EpToken "type", TokDcolon)
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [LocatedN RdrName]
-> LHsSigType GhcPs
-> (EpToken "type", TokDcolon)
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [LocatedN RdrName]
lhs LHsSigType GhcPs
rhs (EpToken "type", TokDcolon)
anns =
do { 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 :: * -> *} {l}.
(MonadP m, HasLoc l) =>
GenLocated l RdrName -> m (GenLocated l RdrName)
check_lhs_name (Located [LocatedN RdrName] -> [LocatedN RdrName]
forall l e. GenLocated l e -> e
unLoc Located [LocatedN RdrName]
lhs)
; v <- check_singular_lhs (reverse vs)
; return $ L (noAnnSrcSpan loc)
$ StandaloneKindSig anns v rhs }
where
check_lhs_name :: GenLocated l RdrName -> m (GenLocated l RdrName)
check_lhs_name v :: GenLocated l RdrName
v@(GenLocated l 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 l RdrName -> m (GenLocated l RdrName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated l RdrName
v
else MsgEnvelope PsMessage -> m (GenLocated l RdrName)
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> m (GenLocated l RdrName))
-> MsgEnvelope PsMessage -> m (GenLocated l RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated l RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated l RdrName
v) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> PsMessage
PsErrUnexpectedQualifiedConstructor (GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated l 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. HasCallStack => 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
$
([XRec GhcPs (IdP GhcPs)] -> PsMessage
PsErrMultipleNamesInStandaloneKindSignature [XRec GhcPs (IdP GhcPs)]
[LocatedN RdrName]
vs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> EpToken "="
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> EpToken "="
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn SrcSpan
loc HsOuterFamEqnTyVarBndrs GhcPs
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs EpToken "="
annEq
= do { (tc, tparams, fixity, ops, cps, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
lhs
; let loc' = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
; return (L loc' $ FamEqn
{ feqn_ext = (ops, cps, annEq)
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = rhs })}
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> AnnDataDefn
-> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs,
LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> AnnDataDefn
-> 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) AnnDataDefn
anns
= do { (tc, tparams, fixity, ops, cps, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
; let anns' = AnnDataDefn
anns {andd_openp = ops, andd_closep = cps}
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns'
; let loc' = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
(FamEqn { feqn_ext = ([], [], NoEpTok)
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn })))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> EpToken "type"
-> EpToken "instance"
-> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> EpToken "type"
-> EpToken "instance"
-> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn EpToken "type"
t EpToken "instance"
i = do
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 e. HasAnnotation e => SrcSpan -> e
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 (EpToken "type"
t,EpToken "instance"
i) TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> AnnFamilyDecl
-> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> AnnFamilyDecl
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info TopLevelFlag
topLevel LHsType GhcPs
lhs LFamilyResultSig GhcPs
ksig Maybe (LInjectivityAnn GhcPs)
injAnn AnnFamilyDecl
annsIn
= do { (tc, tparams, fixity, ops, cps, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
; let loc' = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
; let anns' = AnnFamilyDecl
annsIn { afd_openp = ops, afd_closep = cps }
; return (L loc' (FamDecl noExtField (FamilyDecl
{ fdExt = anns'
, fdTopLevel = topLevel
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
, fdFixity = fixity
, fdResultSig = ksig
, fdInjectivityAnn = injAnn }))) }
where
equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
FamilyInfo GhcPs
DataFamily -> SDoc
forall doc. IsOutput doc => doc
empty
FamilyInfo GhcPs
OpenTypeFamily -> SDoc
forall doc. IsOutput doc => doc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> (LHsDecl GhcPs)
mkSpliceDecl :: LHsExpr GhcPs -> LHsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(L SrcSpanAnnA
loc HsExpr GhcPs
expr)
| HsUntypedSplice XUntypedSplice GhcPs
_ splice :: HsUntypedSplice GhcPs
splice@(HsUntypedSpliceExpr {}) <- HsExpr GhcPs
expr
= SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (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 (HsUntypedSplice GhcPs)
-> SpliceDecoration
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsUntypedSplice p) -> SpliceDecoration -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpanAnnA
-> HsUntypedSplice GhcPs
-> GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) HsUntypedSplice GhcPs
splice) SpliceDecoration
DollarSplice)
| HsUntypedSplice XUntypedSplice GhcPs
_ splice :: HsUntypedSplice GhcPs
splice@(HsQuasiQuote {}) <- HsExpr GhcPs
expr
= SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (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 (HsUntypedSplice GhcPs)
-> SpliceDecoration
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsUntypedSplice p) -> SpliceDecoration -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpanAnnA
-> HsUntypedSplice GhcPs
-> GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) HsUntypedSplice GhcPs
splice) SpliceDecoration
DollarSplice)
| Bool
otherwise
= SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (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 (HsUntypedSplice GhcPs)
-> SpliceDecoration
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> XRec p (HsUntypedSplice p) -> SpliceDecoration -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField
(SrcSpanAnnA
-> HsUntypedSplice GhcPs
-> GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) (XUntypedSpliceExpr GhcPs -> LHsExpr GhcPs -> HsUntypedSplice GhcPs
forall id.
XUntypedSpliceExpr id -> LHsExpr id -> HsUntypedSplice id
HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs
forall a. NoAnn a => a
noAnn (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l l2 a.
(HasLoc l, HasAnnotation l2) =>
GenLocated l a -> GenLocated l2 a
la2la LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr)))
SpliceDecoration
BareSplice)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName
-> [Located (Maybe FastString)]
-> (EpToken "type", EpToken "role")
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName
-> [Located (Maybe FastString)]
-> (EpToken "type", EpToken "role")
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc LocatedN RdrName
tycon [Located (Maybe FastString)]
roles (EpToken "type", EpToken "role")
anns
= do { roles' <- (Located (Maybe FastString) -> P (GenLocated EpAnnCO (Maybe Role)))
-> [Located (Maybe FastString)]
-> P [GenLocated EpAnnCO (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 EpAnnCO (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; !cs <- getCommentsFor loc
; return $ L (EpAnn (spanAsAnchor loc) noAnn cs)
$ RoleAnnotDecl anns tycon 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 EpAnnCO (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role)))
-> GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a b. (a -> b) -> a -> b
$ EpAnnCO -> Maybe Role -> GenLocated EpAnnCO (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
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 EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role)))
-> GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a b. (a -> b) -> a -> b
$ EpAnnCO -> Maybe Role -> GenLocated EpAnnCO (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc_role) (Maybe Role -> GenLocated EpAnnCO (Maybe Role))
-> Maybe Role -> GenLocated EpAnnCO (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 (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (Maybe Role))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (Maybe Role)))
-> MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (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)
mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
mkMDo :: HsDoFlavour
-> LocatedLW [ExprLStmt GhcPs]
-> EpaLocation
-> EpaLocation
-> HsExpr GhcPs
mkMDo HsDoFlavour
ctxt LocatedLW [ExprLStmt GhcPs]
stmts EpaLocation
tok EpaLocation
loc
= HsDoFlavour
-> LocatedLW [ExprLStmt GhcPs]
-> AnnList EpaLocation
-> HsExpr GhcPs
mkHsDoAnns HsDoFlavour
ctxt LocatedLW [ExprLStmt GhcPs]
stmts (Maybe EpaLocation
-> AnnListBrackets
-> [EpToken ";"]
-> EpaLocation
-> [TrailingAnn]
-> AnnList EpaLocation
forall a.
Maybe EpaLocation
-> AnnListBrackets
-> [EpToken ";"]
-> a
-> [TrailingAnn]
-> AnnList a
AnnList (EpaLocation -> Maybe EpaLocation
forall a. a -> Maybe a
Just EpaLocation
loc) AnnListBrackets
ListNone [] EpaLocation
tok [])
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 (L SrcSpanAnnA
loc (HsTvb XTyVarBndr GhcPs
xtv Specificity
flag HsBndrVar GhcPs
idp HsBndrKind GhcPs
k)) = do
case Specificity
flag of
Specificity
SpecifiedSpec -> () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Specificity
InferredSpec -> 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrInferredTypeVarNotAllowed
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XTyVarBndr GhcPs
-> ()
-> HsBndrVar GhcPs
-> HsBndrKind GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb XTyVarBndr GhcPs
xtv () HsBndrVar GhcPs
idp HsBndrKind GhcPs
k)
annBinds :: EpToken "where" -> EpAnnComments -> HsLocalBinds GhcPs
-> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds :: EpToken "where"
-> EpAnnComments
-> HsLocalBinds GhcPs
-> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds EpToken "where"
w 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 (EpToken "where" -> SrcSpanAnnLW -> EpAnnComments -> SrcSpanAnnLW
add_where EpToken "where"
w XHsValBinds GhcPs GhcPs
SrcSpanAnnLW
an EpAnnComments
cs) HsValBindsLR GhcPs GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds EpToken "where"
w 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 (EpToken "where" -> SrcSpanAnnLW -> EpAnnComments -> SrcSpanAnnLW
add_where EpToken "where"
w XHsIPBinds GhcPs GhcPs
SrcSpanAnnLW
an EpAnnComments
cs) HsIPBinds GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds EpToken "where"
_ 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 :: EpToken "where" -> EpAnn (AnnList (EpToken "where")) -> EpAnnComments -> EpAnn (AnnList (EpToken "where"))
add_where :: EpToken "where" -> SrcSpanAnnLW -> EpAnnComments -> SrcSpanAnnLW
add_where w :: EpToken "where"
w@(EpTok (EpaSpan (RealSrcSpan RealSrcSpan
rs Maybe BufSpan
_))) (EpAnn EpaLocation
a AnnList (EpToken "where")
al EpAnnComments
cs) EpAnnComments
cs2
| EpaLocation -> Bool
valid_anchor EpaLocation
a
= EpaLocation
-> AnnList (EpToken "where") -> EpAnnComments -> SrcSpanAnnLW
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpaLocation -> EpToken "where" -> EpaLocation
forall (tok :: Symbol). EpaLocation -> EpToken tok -> EpaLocation
widenAnchorT EpaLocation
a EpToken "where"
w) (AnnList (EpToken "where")
al { al_rest = w}) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
| Bool
otherwise
= EpaLocation
-> AnnList (EpToken "where") -> EpAnnComments -> SrcSpanAnnLW
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor RealSrcSpan
rs EpaLocation
a)
(AnnList (EpToken "where")
al { al_anchor = (fmap (patch_anchor rs) (al_anchor al))
, al_rest = w})
(EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
add_where EpToken "where"
_ SrcSpanAnnLW
_ EpAnnComments
_ = String -> SrcSpanAnnLW
forall a. HasCallStack => String -> a
panic String
"add_where"
valid_anchor :: EpaLocation -> Bool
valid_anchor :: EpaLocation -> Bool
valid_anchor (EpaSpan (RealSrcSpan RealSrcSpan
r Maybe BufSpan
_)) = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
valid_anchor EpaLocation
_ = Bool
False
patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor RealSrcSpan
r EpaDelta{} = SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
patch_anchor RealSrcSpan
r1 (EpaSpan (RealSrcSpan RealSrcSpan
r0 Maybe BufSpan
mb)) = SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
mb)
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
patch_anchor RealSrcSpan
_ (EpaSpan SrcSpan
ss) = SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan SrcSpan
ss
stmtsAnchor :: Located (OrdList (EpToken tok),a) -> Maybe EpaLocation
stmtsAnchor :: forall (tok :: Symbol) a.
Located (OrdList (EpToken tok), a) -> Maybe EpaLocation
stmtsAnchor (L (RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb) ((ConsOL (EpTok (EpaSpan (RealSrcSpan RealSrcSpan
r Maybe BufSpan
rb))) OrdList (EpToken tok)
_), a
_))
= EpaLocation -> Maybe EpaLocation
forall a. a -> Maybe a
Just (EpaLocation -> Maybe EpaLocation)
-> EpaLocation -> Maybe EpaLocation
forall a b. (a -> b) -> a -> b
$ EpaLocation -> SrcSpan -> EpaLocation
widenAnchorS (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb)) (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
rb)
stmtsAnchor (L (RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb) (OrdList (EpToken tok), a)
_) = EpaLocation -> Maybe EpaLocation
forall a. a -> Maybe a
Just (EpaLocation -> Maybe EpaLocation)
-> EpaLocation -> Maybe EpaLocation
forall a b. (a -> b) -> a -> b
$ SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb)
stmtsAnchor GenLocated SrcSpan (OrdList (EpToken tok), a)
_ = Maybe EpaLocation
forall a. Maybe a
Nothing
stmtsLoc :: Located (OrdList (EpToken tok),a) -> SrcSpan
stmtsLoc :: forall (tok :: Symbol) a.
Located (OrdList (EpToken tok), a) -> SrcSpan
stmtsLoc (L SrcSpan
l ((ConsOL EpToken tok
aa OrdList (EpToken tok)
_), a
_))
= SrcSpan -> EpToken tok -> SrcSpan
forall (tok :: Symbol). SrcSpan -> EpToken tok -> SrcSpan
widenSpanT SrcSpan
l EpToken tok
aa
stmtsLoc (L SrcSpan
l (OrdList (EpToken tok), a)
_) = SrcSpan
l
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 { (mbs, sigs, fam_ds, tfam_insts
, dfam_insts, _) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; massert (null fam_ds && null tfam_insts && null dfam_insts)
; return $ ValBinds NoAnnSortKey mbs 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
fb' <- [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> P [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall {m :: * -> *} {a}.
(MonadP m, HasLoc a) =>
[GenLocated a (HsDecl GhcPs)] -> m [GenLocated 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)
return (partitionBindsAndSigs (getMonoBindAll fb'))
where
drop_bad_decls :: [GenLocated a (HsDecl GhcPs)] -> m [GenLocated a (HsDecl GhcPs)]
drop_bad_decls [] = [GenLocated a (HsDecl GhcPs)] -> m [GenLocated a (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
drop_bad_decls (L a
l (SpliceD XSpliceD GhcPs
_ SpliceDecl GhcPs
d) : [GenLocated 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 (a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA a
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SpliceDecl GhcPs -> PsMessage
PsErrDeclSpliceNotAtTopLevel SpliceDecl GhcPs
d
[GenLocated a (HsDecl GhcPs)] -> m [GenLocated a (HsDecl GhcPs)]
drop_bad_decls [GenLocated a (HsDecl GhcPs)]
ds
drop_bad_decls (GenLocated a (HsDecl GhcPs)
d:[GenLocated a (HsDecl GhcPs)]
ds) = (GenLocated a (HsDecl GhcPs)
dGenLocated a (HsDecl GhcPs)
-> [GenLocated a (HsDecl GhcPs)] -> [GenLocated a (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
:) ([GenLocated a (HsDecl GhcPs)] -> [GenLocated a (HsDecl GhcPs)])
-> m [GenLocated a (HsDecl GhcPs)]
-> m [GenLocated a (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated a (HsDecl GhcPs)] -> m [GenLocated a (HsDecl GhcPs)]
drop_bad_decls [GenLocated 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 :: XRec GhcPs (IdP 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 SrcSpanAnnLW
_ 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
loc1 Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1] (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA 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 SrcSpanAnnLW
_ [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 => EpAnn a -> EpAnn a -> EpAnn 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 => EpAnn a -> EpAnn a -> EpAnn 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
= let
L SrcSpanAnnA
llm Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
last_m = [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. HasCallStack => [a] -> a
head [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mtchs
(SrcSpanAnnA
llm',SrcSpanAnnA
loc') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsOnlyA SrcSpanAnnA
llm SrcSpanAnnA
loc
matches' :: [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches' = [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a]
reverse (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
llm' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
last_mGenLocated
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]
:[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. HasCallStack => [a] -> [a]
tail [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mtchs)
L SrcSpanAnnA
lfm Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
first_m = [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. HasCallStack => [a] -> a
head [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches'
(SrcSpanAnnA
lfm', SrcSpanAnnA
loc'') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
lfm SrcSpanAnnA
loc'
in
( SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc'' (LocatedN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
LocatedN RdrName
fun_id1 ([GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an e2.
(Semigroup a, NoAnn an) =>
[GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2]
mkLocatedList ([GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[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
lfm' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
first_mGenLocated
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]
:[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. HasCallStack => [a] -> [a]
tail [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches')))
, ([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. HasCallStack => String -> a
panic String
"GHC.Parser.PostProcess.has_args"
has_args (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ [GenLocated SrcSpanAnnA (Pat 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 [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. HasLoc a => 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
-> LocatedLW (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: LocatedN RdrName
-> LocatedLW (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpanAnnN
loc RdrName
patsyn_name) (L SrcSpanAnnLW
ld OrdList (LHsDecl GhcPs)
decls) =
do { 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)
; when (null matches) (wrongNumberErr (locA loc))
; return $ mkMatchGroup FromSource (L ld 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
_conAnn ln :: XRec GhcPs (ConLikeP GhcPs)
ln@(L SrcSpanAnnN
_ RdrName
name) HsConPatDetails GhcPs
details))
HsMultAnn GhcPs
_ GRHSs GhcPs (LHsExpr GhcPs)
rhs))) =
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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl
; let ann_fun :: AnnFunRhs
ann_fun = [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
mk_ann_funrhs [] []
; match <- case HsConPatDetails GhcPs
details of
PrefixCon [HsConPatTyArg (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 = XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
NoExtField
noExtField
, m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcPs))
HsMatchContext (LocatedN RdrName)
ctxt, m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = EpaLocation
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
where
l :: EpaLocation
l = [GenLocated SrcSpanAnnA (Pat GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
ctxt :: HsMatchContext (LocatedN RdrName)
ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict
, mc_an :: XFunRhs
mc_an = XFunRhs
AnnFunRhs
ann_fun }
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 = XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
NoExtField
noExtField
, m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcPs))
HsMatchContext (LocatedN RdrName)
ctxt
, m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = EpaLocation
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2]
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
where
l :: EpaLocation
l = [GenLocated SrcSpanAnnA (Pat GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2]
ctxt :: HsMatchContext (LocatedN RdrName)
ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict
, mc_an :: XFunRhs
mc_an = XFunRhs
AnnFunRhs
ann_fun }
RecCon{} -> SrcSpan
-> LPat GhcPs
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) LPat GhcPs
pat
; return $ L loc 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. HasLoc a => 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 :: (TokDarrow, (TokForall, EpToken ".")) -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 :: (TokDarrow, (TokForall, EpToken "."))
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 (TokDarrow
tdarrow, (TokForall
tforall,EpToken "."
tdot)) LocatedN RdrName
name Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDeclH98Details GhcPs
args
= ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = TokForall -> EpToken "." -> TokDarrow -> AnnConDeclH98
AnnConDeclH98 TokForall
tforall EpToken "."
tdot TokDarrow
tdarrow
, con_name :: XRec GhcPs (IdP GhcPs)
con_name = XRec GhcPs (IdP 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
-> NonEmpty (LocatedN RdrName)
-> TokDcolon
-> LHsSigType GhcPs
-> P (LConDecl GhcPs)
mkGadtDecl :: SrcSpan
-> NonEmpty (LocatedN RdrName)
-> TokDcolon
-> LHsSigType GhcPs
-> P (LConDecl GhcPs)
mkGadtDecl SrcSpan
loc NonEmpty (LocatedN RdrName)
names TokDcolon
dcol LHsSigType GhcPs
ty = do
(args, res_ty, (ops, cps), csa) <-
case LHsType GhcPs
body_ty of
L SrcSpanAnnA
ll (HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
hsArr (L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
cs) (HsRecTy XRecTy GhcPs
an [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) -> do
arr <- case HsArrow GhcPs
hsArr of
HsUnrestrictedArrow XUnrestrictedArrow (LHsType GhcPs) GhcPs
arr -> TokRarrow -> P TokRarrow
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return TokRarrow
XUnrestrictedArrow (LHsType GhcPs) GhcPs
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. HasLoc a => GenLocated 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)
TokRarrow -> P TokRarrow
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return TokRarrow
forall a. NoAnn a => a
noAnn
return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty
, ([], []), epAnnComments ll)
LHsType GhcPs
_ -> do
let (([EpToken "("]
ops, [EpToken ")"]
cps), EpAnnComments
cs, [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type) = LHsType GhcPs
-> (([EpToken "("], [EpToken ")"]), EpAnnComments,
[HsScaled GhcPs (LHsType GhcPs)], LHsType GhcPs)
forall (p :: Pass).
LHsType (GhcPass p)
-> (([EpToken "("], [EpToken ")"]), EpAnnComments,
[HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
splitHsFunType LHsType GhcPs
body_ty
(HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs),
([EpToken "("], [EpToken ")"]), EpAnnComments)
-> P (HsConDeclGADTDetails GhcPs,
GenLocated SrcSpanAnnA (HsType GhcPs),
([EpToken "("], [EpToken ")"]), EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPrefixConGADT GhcPs
-> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall pass.
XPrefixConGADT pass
-> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT NoExtField
XPrefixConGADT GhcPs
noExtField [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_type, ([EpToken "("]
ops,[EpToken ")"]
cps), EpAnnComments
cs)
let bndrs_loc = case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
HsOuterImplicit{} -> GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
HsOuterExplicit XHsOuterExplicit GhcPs Specificity
an [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
_ -> EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpAnn (TokForall, EpToken ".") -> EpaLocation
forall ann. EpAnn ann -> EpaLocation
entry XHsOuterExplicit GhcPs Specificity
EpAnn (TokForall, EpToken ".")
an) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
emptyComments
let l = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
csa
pure $ L l ConDeclGADT
{ con_g_ext = AnnConDeclGADT ops cps dcol
, con_names = names
, con_bndrs = L bndrs_loc outer_bndrs
, con_mb_cxt = mcxt
, con_g_args = args
, con_res_ty = res_ty
, con_doc = 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 (HasDebugCallStack => 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
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 { tvs <- (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated
SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> P [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) 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
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
check [LHsTypeArg GhcPs]
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tparms
; return (mkHsQTvs tvs) }
where
check :: HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
check (HsTypeArg XTypeArg GhcPs
at GenLocated SrcSpanAnnA (HsType GhcPs)
ki) = [EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens [] [] (XBndrInvisible GhcPs -> HsBndrVis GhcPs
forall pass. XBndrInvisible pass -> HsBndrVis pass
HsBndrInvisible XTypeArg GhcPs
XBndrInvisible GhcPs
at) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ki
check (HsValArg XValArg GhcPs
_ GenLocated SrcSpanAnnA (HsType GhcPs)
ty) = [EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens [] [] (XBndrRequired GhcPs -> HsBndrVis GhcPs
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired GhcPs
noExtField) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
check (HsArgPar XArgPar GhcPs
sp) = MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (GenLocated
SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)))
-> MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
XArgPar GhcPs
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 :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens :: [EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens [EpaLocation]
ops [EpaLocation]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l (HsParTy XParTy GhcPs
_ (L SrcSpanAnnA
lt HsType GhcPs
ty)))
= let
(EpaLocation
o,EpaLocation
c) = RealSrcSpan -> (EpaLocation, EpaLocation)
mkParensLocs (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
(SrcSpanAnnA
_,SrcSpanAnnA
lt') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnA
lt
in
[EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens (EpaLocation
oEpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
ops) (EpaLocation
cEpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
cps) HsBndrVis GhcPs
bvis (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lt' HsType GhcPs
ty)
chkParens [EpaLocation]
ops [EpaLocation]
cps HsBndrVis GhcPs
bvis LHsType GhcPs
ty = [EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chk [EpaLocation]
ops [EpaLocation]
cps HsBndrVis GhcPs
bvis LHsType GhcPs
ty
chk :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chk :: [EpaLocation]
-> [EpaLocation]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chk [EpaLocation]
ops [EpaLocation]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l (HsKindSig XKindSig GhcPs
tok_dc (L SrcSpanAnnA
annt HsType GhcPs
t) LHsType GhcPs
k))
| Just (EpToken "'"
ann, HsBndrVar GhcPs
bvar) <- HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)
match_bndr_var HsType GhcPs
t
= let
bkind :: HsBndrKind GhcPs
bkind = XBndrKind GhcPs -> LHsType GhcPs -> HsBndrKind GhcPs
forall pass. XBndrKind pass -> LHsKind pass -> HsBndrKind pass
HsBndrKind NoExtField
XBndrKind GhcPs
noExtField LHsType GhcPs
k
an :: [EpaLocation]
an = ([EpaLocation] -> [EpaLocation]
forall a. [a] -> [a]
reverse [EpaLocation]
ops) [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation]
cps
in
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> [EpaLocation] -> SrcSpanAnnA
forall an. EpAnn an -> [EpaLocation] -> EpAnn an
widenLocatedAnL (SrcSpanAnnA
l SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA
annt) (HsBndrVis GhcPs -> EpaLocation
for_widening HsBndrVis GhcPs
bvisEpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
an))
(XTyVarBndr GhcPs
-> HsBndrVis GhcPs
-> HsBndrVar GhcPs
-> HsBndrKind GhcPs
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb ([EpaLocation]
-> [EpaLocation] -> EpToken "'" -> TokDcolon -> AnnTyVarBndr
AnnTyVarBndr ([EpaLocation] -> [EpaLocation]
forall a. [a] -> [a]
reverse [EpaLocation]
ops) [EpaLocation]
cps EpToken "'"
ann XKindSig GhcPs
TokDcolon
tok_dc) HsBndrVis GhcPs
bvis HsBndrVar GhcPs
bvar HsBndrKind GhcPs
bkind))
chk [EpaLocation]
ops [EpaLocation]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l HsType GhcPs
t)
| Just (EpToken "'"
ann, HsBndrVar GhcPs
bvar) <- HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)
match_bndr_var HsType GhcPs
t
= let
bkind :: HsBndrKind GhcPs
bkind = XBndrNoKind GhcPs -> HsBndrKind GhcPs
forall pass. XBndrNoKind pass -> HsBndrKind pass
HsBndrNoKind NoExtField
XBndrNoKind GhcPs
noExtField
an :: [EpaLocation]
an = ([EpaLocation] -> [EpaLocation]
forall a. [a] -> [a]
reverse [EpaLocation]
ops) [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation]
cps
in
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> [EpaLocation] -> SrcSpanAnnA
forall an. EpAnn an -> [EpaLocation] -> EpAnn an
widenLocatedAnL SrcSpanAnnA
l (HsBndrVis GhcPs -> EpaLocation
for_widening HsBndrVis GhcPs
bvisEpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
an))
(XTyVarBndr GhcPs
-> HsBndrVis GhcPs
-> HsBndrVar GhcPs
-> HsBndrKind GhcPs
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb ([EpaLocation]
-> [EpaLocation] -> EpToken "'" -> TokDcolon -> AnnTyVarBndr
AnnTyVarBndr ([EpaLocation] -> [EpaLocation]
forall a. [a] -> [a]
reverse [EpaLocation]
ops) [EpaLocation]
cps EpToken "'"
ann TokDcolon
forall a. NoAnn a => a
noAnn) HsBndrVis GhcPs
bvis HsBndrVar GhcPs
bvar HsBndrKind GhcPs
bkind))
chk [EpaLocation]
_ [EpaLocation]
_ HsBndrVis GhcPs
_ t :: LHsType GhcPs
t@(L SrcSpanAnnA
loc HsType GhcPs
_)
= MsgEnvelope PsMessage -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs))
-> MsgEnvelope PsMessage
-> P (LHsTyVarBndr (HsBndrVis GhcPs) 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. HasLoc a => 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)
match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)
match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)
match_bndr_var (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ XRec GhcPs (IdP GhcPs)
tv) | RdrName -> Bool
isRdrTyVar (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (IdP GhcPs)
LocatedN RdrName
tv)
= (EpToken "'", HsBndrVar GhcPs)
-> Maybe (EpToken "'", HsBndrVar GhcPs)
forall a. a -> Maybe a
Just (XTyVar GhcPs
EpToken "'"
ann, XBndrVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsBndrVar GhcPs
forall pass. XBndrVar pass -> LIdP pass -> HsBndrVar pass
HsBndrVar NoExtField
XBndrVar GhcPs
noExtField XRec GhcPs (IdP GhcPs)
tv)
match_bndr_var (HsWildCardTy XWildCardTy GhcPs
_)
= (EpToken "'", HsBndrVar GhcPs)
-> Maybe (EpToken "'", HsBndrVar GhcPs)
forall a. a -> Maybe a
Just (EpToken "'"
forall a. NoAnn a => a
noAnn, XBndrWildCard GhcPs -> HsBndrVar GhcPs
forall pass. XBndrWildCard pass -> HsBndrVar pass
HsBndrWildCard NoExtField
XBndrWildCard GhcPs
noExtField)
match_bndr_var HsType GhcPs
_ = Maybe (EpToken "'", HsBndrVar GhcPs)
forall a. Maybe a
Nothing
for_widening :: HsBndrVis GhcPs -> EpaLocation
for_widening :: HsBndrVis GhcPs -> EpaLocation
for_widening (HsBndrInvisible (EpTok EpaLocation
loc)) = EpaLocation
loc
for_widening HsBndrVis GhcPs
_ = EpaLocation
forall a. NoAnn a => a
noAnn
whereDots, equalsDots :: SDoc
whereDots :: SDoc
whereDots = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
forall doc. IsLine doc => String -> doc
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 allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DatatypeContextsBit
unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $
(PsErrIllegalDataTypeContext c)
type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> GenLocated EpAnnCO (RuleBndr GhcPs))
-> [LRuleTyTmVar] -> [GenLocated EpAnnCO (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 EpAnnCO (RuleBndr GhcPs)
forall a b.
(a -> b) -> GenLocated EpAnnCO a -> GenLocated EpAnnCO 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 AnnTyVarBndr
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> XRec GhcPs (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr XCRuleBndr GhcPs
AnnTyVarBndr
ann XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v
cvt_one (RuleTyTmVar AnnTyVarBndr
ann LocatedN RdrName
v (Just LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> XRec GhcPs (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcPs
AnnTyVarBndr
ann XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v (EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnnCO
forall a. NoAnn a => 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 (NameSpace -> LHsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall flag.
NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs
setLHsTyVarBndrNameSpace NameSpace
tvName (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> (LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> LRuleTyTmVar
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall {a} {l}.
(HasLoc a, HasAnnotation l) =>
GenLocated a RuleTyTmVar -> GenLocated l (HsTyVarBndr () GhcPs)
cvt_one)
where cvt_one :: GenLocated a RuleTyTmVar -> GenLocated l (HsTyVarBndr () GhcPs)
cvt_one (L a
l (RuleTyTmVar AnnTyVarBndr
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
msig))
= l -> HsTyVarBndr () GhcPs -> GenLocated l (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L (a -> l
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l a
l) (XTyVarBndr GhcPs
-> ()
-> HsBndrVar GhcPs
-> HsBndrKind GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XTyVarBndr pass
-> flag
-> HsBndrVar pass
-> HsBndrKind pass
-> HsTyVarBndr flag pass
HsTvb XTyVarBndr GhcPs
AnnTyVarBndr
ann () (XBndrVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsBndrVar GhcPs
forall pass. XBndrVar pass -> LIdP pass -> HsBndrVar pass
HsBndrVar NoExtField
XBndrVar GhcPs
noExtField XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v) (Maybe (LHsType GhcPs) -> HsBndrKind GhcPs
forall {pass}.
(XBndrKind pass ~ NoExtField, XBndrNoKind pass ~ NoExtField) =>
Maybe (XRec pass (HsKind pass)) -> HsBndrKind pass
cvt_sig Maybe (LHsType GhcPs)
msig))
cvt_sig :: Maybe (XRec pass (HsKind pass)) -> HsBndrKind pass
cvt_sig Maybe (XRec pass (HsKind pass))
Nothing = XBndrNoKind pass -> HsBndrKind pass
forall pass. XBndrNoKind pass -> HsBndrKind pass
HsBndrNoKind NoExtField
XBndrNoKind pass
noExtField
cvt_sig (Just XRec pass (HsKind pass)
sig) = XBndrKind pass -> XRec pass (HsKind pass) -> HsBndrKind pass
forall pass. XBndrKind pass -> LHsKind pass -> HsBndrKind pass
HsBndrKind NoExtField
XBndrKind pass
noExtField XRec pass (HsKind pass)
sig
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = (LocatedN RdrName -> P ()) -> [LocatedN RdrName] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LocatedN RdrName -> P ()
forall {f :: * -> *} {a}.
(MonadP f, HasLoc a) =>
GenLocated a RdrName -> f ()
check ([LocatedN RdrName] -> P ())
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> [LocatedN RdrName])
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (LocatedN RdrName))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> [LocatedN RdrName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HsTyVarBndr flag GhcPs -> Maybe (XRec GhcPs (IdP GhcPs))
HsTyVarBndr flag GhcPs -> Maybe (LocatedN RdrName)
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p))
hsTyVarLName (HsTyVarBndr flag GhcPs -> Maybe (LocatedN RdrName))
-> (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> HsTyVarBndr flag GhcPs)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> Maybe (LocatedN RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> HsTyVarBndr flag GhcPs
forall l e. GenLocated l e -> e
unLoc)
where check :: GenLocated a RdrName -> f ()
check (L a
loc (Unqual OccName
occ)) =
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OccName -> FastString
occNameFS OccName
occ FastString -> [FastString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String -> FastString
fsLit String
"family",String -> FastString
fsLit 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 (a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA a
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(OccName -> PsMessage
PsErrParseErrorOnInput OccName
occ))
check GenLocated a RdrName
_ = String -> f ()
forall a. HasCallStack => 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 allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrIllegalTraditionalRecordSyntax (ppr r))
return lr
checkEmptyGADTs :: Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])
-> P (Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs]))
checkEmptyGADTs :: Located
((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])
-> P (Located
((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located
((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])
gadts@(L SrcSpan
span ((EpToken "where", EpToken "{", EpToken "}")
_, []))
= do gadtSyntax <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit
unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $
PsErrIllegalWhereInDataDecl
return gadts
checkEmptyGADTs Located
((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])
gadts = Located
((EpToken "where", EpToken "{", EpToken "}"),
[GenLocated SrcSpanAnnA (ConDecl GhcPs)])
-> P (Located
((EpToken "where", EpToken "{", EpToken "}"),
[GenLocated SrcSpanAnnA (ConDecl GhcPs)]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Located
((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])
Located
((EpToken "where", EpToken "{", EpToken "}"),
[GenLocated SrcSpanAnnA (ConDecl GhcPs)])
gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (LocatedN RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[EpToken "("],
[EpToken ")"],
EpAnnComments)
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
[EpToken "("], [EpToken ")"], EpAnnComments)
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
= EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
goL EpAnnComments
emptyComments LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty [] [] [] LexicalFixity
Prefix
where
goL :: EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
goL EpAnnComments
cs (L SrcSpanAnnA
l HsType GhcPs
ty) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix = EpAnnComments
-> SrcSpanAnnA
-> HsType GhcPs
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
go EpAnnComments
cs SrcSpanAnnA
l HsType GhcPs
ty [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix
go :: EpAnnComments
-> SrcSpanAnnA
-> HsType GhcPs
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
go EpAnnComments
cs SrcSpanAnnA
ll (HsParTy XParTy GhcPs
an (L SrcSpanAnnA
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops' [EpToken ")"]
cps' LexicalFixity
fix
= do { SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) PsMessage
PsWarnStarBinder
; let name :: OccName
name = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
tcClsName (Bool -> FastString
starSym Bool
isUni)
; let a' :: SrcSpanAnnN
a' = SrcSpanAnnA
-> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN
newAnns SrcSpanAnnA
ll SrcSpanAnnA
l (EpToken "(", EpToken ")")
XParTy GhcPs
an
; (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
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
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix
, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops'), [EpToken ")"]
cps', EpAnnComments
cs) }
go EpAnnComments
cs SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: XRec GhcPs (IdP GhcPs)
ltc@(L SrcSpanAnnN
_ RdrName
tc)) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix
| RdrName -> Bool
isRdrTc RdrName
tc = (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs)
LocatedN RdrName
ltc, [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), [EpToken ")"]
cps, EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l)
go EpAnnComments
cs SrcSpanAnnA
l (HsOpTy XOpTy GhcPs
_ PromotionFlag
_ LHsType GhcPs
t1 ltc :: XRec GhcPs (IdP GhcPs)
ltc@(L SrcSpanAnnN
_ RdrName
tc) LHsType GhcPs
t2) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
_fix
| RdrName -> Bool
isRdrTc RdrName
tc = (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs)
LocatedN RdrName
ltc, HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
lhsHsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
rhsHsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
Infix, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), [EpToken ")"]
cps, EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l)
where lhs :: HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
lhs = XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1
rhs :: HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
rhs = XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t2
go EpAnnComments
cs SrcSpanAnnA
l (HsParTy (EpToken "("
o,EpToken ")"
c) LHsType GhcPs
ty) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
goL (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc (EpToken "("
oEpToken "(" -> [EpToken "("] -> [EpToken "("]
forall a. a -> [a] -> [a]
:[EpToken "("]
ops) (EpToken ")"
cEpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
:[EpToken ")"]
cps) LexicalFixity
fix
go EpAnnComments
cs SrcSpanAnnA
l (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
goL (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1 (XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t2HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc) [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix
go EpAnnComments
cs SrcSpanAnnA
l (HsAppKindTy XAppKindTy GhcPs
at LHsType GhcPs
ty LHsType GhcPs
ki) [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
goL (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty (XTypeArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XTypeArg p -> ty -> HsArg p tm ty
HsTypeArg XAppKindTy GhcPs
XTypeArg GhcPs
at LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
kiHsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
acc) [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix
go EpAnnComments
cs SrcSpanAnnA
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
fix
= (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
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 (SrcSpanAnnA -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
l) (Name -> RdrName
nameRdrName Name
tup_name)
, (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts, LexicalFixity
fix, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), [EpToken ")"]
cps, EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l)
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 EpAnnComments
_ SrcSpanAnnA
l HsType GhcPs
_ [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
_ [EpToken "("]
_ [EpToken ")"]
_ LexicalFixity
_
= MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments))
-> MsgEnvelope PsMessage
-> P (LocatedN RdrName,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))],
LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(LHsType GhcPs -> PsMessage
PsErrMalformedTyOrClDecl LHsType GhcPs
ty)
newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN
newAnns :: SrcSpanAnnA
-> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN
newAnns l :: SrcSpanAnnA
l@(EpAnn EpaLocation
_ (AnnListItem [TrailingAnn]
_) EpAnnComments
csp0) l1 :: SrcSpanAnnA
l1@(EpAnn EpaLocation
ap (AnnListItem [TrailingAnn]
ta) EpAnnComments
csp) (EpToken "("
o,EpToken ")"
c) =
let
lr :: SrcSpan
lr = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l1) (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
in
EpaLocation -> NameAnn -> EpAnnComments -> SrcSpanAnnN
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan SrcSpan
lr) (NameAdornment -> EpaLocation -> [TrailingAnn] -> NameAnn
NameAnn (EpToken "(" -> EpToken ")" -> NameAdornment
NameParens EpToken "("
o EpToken ")"
c) EpaLocation
ap [TrailingAnn]
ta) (EpAnnComments
csp0 EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csp)
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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated a e -> m ()
check (Maybe ModuleName -> LHsExpr GhcPs -> PsMessage
PsErrMDoInFunAppExpr Maybe ModuleName
m) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsCase {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
(MonadP m, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated a e -> m ()
check LHsExpr GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage
PsErrCaseInFunAppExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
HsLam XLam GhcPs
_ HsLamVariant
lam_variant MatchGroup GhcPs (LHsExpr GhcPs)
_ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
(MonadP m, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated a e -> m ()
check (HsLamVariant -> LHsExpr GhcPs -> PsMessage
PsErrLambdaInFunAppExpr HsLamVariant
lam_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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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 XCmdLamCase GhcPs
_ HsLamVariant
lam_variant MatchGroup GhcPs (LHsCmd GhcPs)
_ -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
(MonadP m, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated a e -> m ()
check (HsLamVariant -> LHsCmd GhcPs -> PsMessage
PsErrLambdaCmdInFunAppCmd HsLamVariant
lam_variant) LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdCase {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
(MonadP m, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated a e -> m ()
check LHsCmd GhcPs -> PsMessage
GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage
PsErrCaseCmdInFunAppCmd LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
HsCmdIf {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage)
-> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
forall {m :: * -> *} {a} {e}.
(MonadP m, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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, HasLoc a) =>
(GenLocated a e -> PsMessage) -> GenLocated 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 a e -> PsMessage) -> GenLocated a e -> m ()
check GenLocated a e -> PsMessage
err GenLocated a e
a = do
blockArguments <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
unless blockArguments $
addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext orig_t :: LHsType GhcPs
orig_t@(L (EpAnn EpaLocation
l AnnListItem
_ EpAnnComments
cs) HsType GhcPs
_orig_t) =
([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([],[],EpAnnComments
cs) LHsType GhcPs
orig_t
where
check :: ([EpToken "("],[EpToken ")"],EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check :: ([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpToken "("]
oparens,[EpToken ")"]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsTupleTy (AnnParens EpToken "("
o EpToken ")"
c) HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
= ([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpToken "("]
oparens [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpToken "("
o], EpToken ")"
c EpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
: [EpToken ")"]
cparens, EpAnnComments
cs) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts
check ([EpToken "("]
oparens,[EpToken ")"]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsExplicitTupleTy (EpToken "'"
q,EpToken "("
o,EpToken ")"
c) [LHsType GhcPs]
ts))
= P Bool
punsAllowed P Bool
-> (Bool
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]))
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> P (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
unprocessed
Bool
False -> do
let
([EpToken "("]
op, [EpToken ")"]
cp) = case EpToken "'"
q of
EpTok EpaLocation
ql -> ([EpaLocation -> EpToken "("
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok EpaLocation
ql], [EpToken ")"
c])
EpToken "'"
_ -> ([EpToken "("
o], [EpToken ")"
c])
([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpToken "("]
oparens [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpToken "("]
op, [EpToken ")"]
cp [EpToken ")"] -> [EpToken ")"] -> [EpToken ")"]
forall a. [a] -> [a] -> [a]
++ [EpToken ")"]
cparens, EpAnnComments
cs) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts
check ([EpToken "("]
opi,[EpToken ")"]
cpi,EpAnnComments
csi) (L SrcSpanAnnA
_lp1 (HsParTy (EpToken "("
o,EpToken ")"
c) LHsType GhcPs
ty))
= ([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check (EpToken "("
oEpToken "(" -> [EpToken "("] -> [EpToken "("]
forall a. a -> [a] -> [a]
:[EpToken "("]
opi, EpToken ")"
cEpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
:[EpToken ")"]
cpi, EpAnnComments
csi) LHsType GhcPs
ty
check ([EpToken "("]
_opi,[EpToken ")"]
_cpi,EpAnnComments
_csi) LHsType GhcPs
_t = P (LHsContext GhcPs)
P (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
unprocessed
unprocessed :: P (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
unprocessed =
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnContext -> EpAnnComments -> SrcSpanAnnC
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
l (Maybe TokDarrow -> [EpToken "("] -> [EpToken ")"] -> AnnContext
AnnContext Maybe TokDarrow
forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
orig_t])
mkCTuple :: ([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpToken "("]
oparens, [EpToken ")"]
cparens, EpAnnComments
cs) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ts =
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnContext -> EpAnnComments -> SrcSpanAnnC
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
l (Maybe TokDarrow -> [EpToken "("] -> [EpToken ")"] -> AnnContext
AnnContext Maybe TokDarrow
forall a. Maybe a
Nothing [EpToken "("]
oparens [EpToken ")"]
cparens) EpAnnComments
cs) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ts)
checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
checkContextExpr orig_expr :: LHsExpr GhcPs
orig_expr@(L (EpAnn EpaLocation
l AnnListItem
_ EpAnnComments
cs) HsExpr GhcPs
_) =
([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([],[], EpAnnComments
cs) LHsExpr GhcPs
orig_expr
where
check :: ([EpToken "("],[EpToken ")"],EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check :: ([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([EpToken "("]
oparens,[EpToken ")"]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_ (ExplicitTuple (EpaLocation
ap_open, EpaLocation
ap_close) [HsTupArg GhcPs]
tup_args Boxity
boxity))
| Boxity -> Bool
isBoxed Boxity
boxity
, Just [LHsExpr GhcPs]
es <- [HsTupArg GhcPs] -> Maybe [LHsExpr GhcPs]
forall (p :: Pass).
[HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]
tupArgsPresent_maybe [HsTupArg GhcPs]
tup_args
= ([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpToken "("]
oparens [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpaLocation -> EpToken "("
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok EpaLocation
ap_open], EpaLocation -> EpToken ")"
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok EpaLocation
ap_close EpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
: [EpToken ")"]
cparens, EpAnnComments
cs) [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es
check ([EpToken "("]
opi, [EpToken ")"]
cpi, EpAnnComments
csi) (L SrcSpanAnnA
_ (HsPar (EpToken "("
open_tok, EpToken ")"
close_tok) LHsExpr GhcPs
expr))
= ([EpToken "("], [EpToken ")"], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([EpToken "("]
opi [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpToken "("
open_tok], EpToken ")"
close_tok EpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
: [EpToken ")"]
cpi, EpAnnComments
csi) LHsExpr GhcPs
expr
check ([EpToken "("]
oparens,[EpToken ")"]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L (EpAnn EpaLocation
_ (NameAnnOnly (NameParens EpToken "("
open EpToken ")"
closed) []) EpAnnComments
_) RdrName
name)))
| RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName (DataCon -> Name
dataConName DataCon
unitDataCon)
= ([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpToken "("]
oparens [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpToken "("
open], EpToken ")"
closed EpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
: [EpToken ")"]
cparens, EpAnnComments
cs) []
check ([EpToken "("], [EpToken ")"], EpAnnComments)
_ LHsExpr GhcPs
_ = PV (LocatedC [LHsExpr GhcPs])
PV (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
unprocessed
unprocessed :: PV (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
unprocessed =
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnContext -> EpAnnComments -> SrcSpanAnnC
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
l (Maybe TokDarrow -> [EpToken "("] -> [EpToken ")"] -> AnnContext
AnnContext Maybe TokDarrow
forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) [LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
orig_expr])
mkCTuple :: ([EpToken "("], [EpToken ")"], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpToken "("]
oparens, [EpToken ")"]
cparens, EpAnnComments
cs) [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ts =
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnContext -> EpAnnComments -> SrcSpanAnnC
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
l (Maybe TokDarrow -> [EpToken "("] -> [EpToken ")"] -> AnnContext
AnnContext Maybe TokDarrow
forall a. Maybe a
Nothing [EpToken "("]
oparens [EpToken ")"]
cparens) EpAnnComments
cs) [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ts)
checkImportDecl :: Maybe (EpToken "qualified")
-> Maybe (EpToken "qualified")
-> P ()
checkImportDecl :: Maybe (EpToken "qualified") -> Maybe (EpToken "qualified") -> P ()
checkImportDecl Maybe (EpToken "qualified")
mPre Maybe (EpToken "qualified")
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
tokenSpan :: EpToken tok -> SrcSpan
tokenSpan EpToken tok
tok = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
epaLocationRealSrcSpan (EpaLocation -> RealSrcSpan) -> EpaLocation -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ EpToken tok -> EpaLocation
forall (tok :: Symbol). EpToken tok -> EpaLocation
getEpTokenLoc EpToken tok
tok) Maybe BufSpan
forall a. Maybe a
Strict.Nothing
importQualifiedPostEnabled <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ImportQualifiedPostBit
whenJust mPost $ \EpToken "qualified"
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 ()
failNotEnabledImportQualifiedPost (EpToken "qualified" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
tokenSpan EpToken "qualified"
post)
whenJust mPost $ \EpToken "qualified"
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (EpToken "qualified") -> Bool
forall a. Maybe a -> Bool
isJust Maybe (EpToken "qualified")
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failImportQualifiedTwice (EpToken "qualified" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
tokenSpan EpToken "qualified"
post)
whenJust mPre $ \EpToken "qualified"
pre ->
SrcSpan -> P ()
warnPrepositiveQualifiedModule (EpToken "qualified" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
tokenSpan EpToken "qualified"
pre)
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)
checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
checkLArgPat (L SrcSpanAnnA
l (ArgPatBuilderVisPat PatBuilder GhcPs
p)) = LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l PatBuilder GhcPs
p)
checkLArgPat (L SrcSpanAnnA
l (ArgPatBuilderArgPat Pat GhcPs
p)) = 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)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (L l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
_) PatBuilder GhcPs
p) = do
(L l' p', cs) <- SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat (EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
emptyComments) EpAnnComments
emptyComments (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l PatBuilder GhcPs
p) [] []
return (L (addCommentsToEpAnn l' cs) p')
checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat :: SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpanAnnN
ln RdrName
c))) [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
args
| RdrName -> Bool
isRdrDataCon RdrName
c Bool -> Bool -> Bool
|| RdrName -> Bool
isRdrTc RdrName
c
= (GenLocated SrcSpanAnnA (Pat GhcPs), EpAnnComments)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs), EpAnnComments)
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
loc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = (Maybe (EpToken "{"), Maybe (EpToken "}"))
XConPat GhcPs
forall a. NoAnn a => 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 = [HsConPatTyArg GhcPs]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
(HsConPatTyArg GhcPs)
(GenLocated SrcSpanAnnA (Pat GhcPs))
(HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args
}, SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs)
| (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
ctx <- PV ParseContext
askParseContext
patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
la (PatBuilderAppType LocatedA (PatBuilder GhcPs)
f EpToken "@"
at HsTyPat GhcPs
t)) [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
args =
SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat SrcSpanAnnA
loc (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
la) LocatedA (PatBuilder GhcPs)
f (XConPatTyArg GhcPs -> HsTyPat GhcPs -> HsConPatTyArg GhcPs
forall p. XConPatTyArg p -> HsTyPat p -> HsConPatTyArg p
HsConPatTyArg EpToken "@"
XConPatTyArg GhcPs
at HsTyPat GhcPs
t HsConPatTyArg GhcPs
-> [HsConPatTyArg GhcPs] -> [HsConPatTyArg GhcPs]
forall a. a -> [a] -> [a]
: [HsConPatTyArg GhcPs]
tyargs) [LPat GhcPs]
args
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
la (PatBuilderApp LocatedA (PatBuilder GhcPs)
f LocatedA (PatBuilder GhcPs)
e)) [] [LPat GhcPs]
args = do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
checkPat loc (cs Semi.<> comments la) f [] (p : args)
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
l PatBuilder GhcPs
e) [] [] = do
p <- SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e
return (L l p, cs)
checkPat SrcSpanAnnA
loc EpAnnComments
_ LocatedA (PatBuilder GhcPs)
e [HsConPatTyArg GhcPs]
_ [LPat GhcPs]
_ = do
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
patFail (locA loc) (PsErrInPat (unLoc e) details)
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e0 = do
nPlusKPatterns <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
NPlusKPatternsBit
case 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 -> XRec GhcPs (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField XRec GhcPs (IdP 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) -> EpToken "-" -> Pat GhcPs
mkNPat (EpAnnCO -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnCO
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) HsOverLit GhcPs
pos_lit) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing EpToken "-"
forall a. NoAnn a => 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 {}})))
([EpToken "("], [EpToken ")"])
_
| 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) -> EpToken "+" -> Pat GhcPs
mkNPlusKPat (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc RdrName
n) (EpAnnCO -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnCO
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
lloc) HsOverLit GhcPs
lit)
(EpaLocation -> EpToken "+"
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok (EpaLocation -> EpToken "+") -> EpaLocation -> EpToken "+"
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> EpaLocation
forall ann. EpAnn ann -> EpaLocation
entry SrcSpanAnnN
l))
PatBuilderOpApp LocatedA (PatBuilder GhcPs)
_ LocatedN RdrName
op LocatedA (PatBuilder GhcPs)
_ ([EpToken "("], [EpToken ")"])
_ | 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. HasLoc a => GenLocated 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 ([EpToken "("]
_os,[EpToken ")"]
_cs)
| RdrName -> Bool
isRdrDataCon RdrName
c Bool -> Bool -> Bool
|| RdrName -> Bool
isRdrTc RdrName
c -> do
l <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
l
r <- checkLPat r
return $ ConPat
{ pat_con_ext = noAnn
, pat_con = L cl c
, pat_args = InfixCon l r
}
PatBuilderPar EpToken "("
lpar LocatedA (PatBuilder GhcPs)
e EpToken ")"
rpar -> do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
return (ParPat (lpar, rpar) p)
PatBuilder GhcPs
_ -> do
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
patFail (locA loc) (PsErrInPat e0 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 e a. HasAnnotation e => a -> GenLocated e 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 SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
fld) = do p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
-> LocatedA (PatBuilder GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))
fld)
return (L l (fld { hfbRHS = 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)
-> (HsMultAnn GhcPs, Maybe (TokDcolon, LHsType GhcPs))
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkValDef :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> (HsMultAnn GhcPs, Maybe (TokDcolon, LHsType GhcPs))
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult, Just (TokDcolon
sigAnn, LHsType GhcPs
sig)) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
= do 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
-> TokDcolon
-> PV (LocatedA (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpanAnnA
-> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b)
mkHsTySigPV (LocatedA (PatBuilder GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
combineLocsA LocatedA (PatBuilder GhcPs)
lhs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
sig) LocatedA (PatBuilder GhcPs)
lhs LHsType GhcPs
sig TokDcolon
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
checkPatBind loc lhs' grhss mult
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult_ann, Maybe (TokDcolon, LHsType GhcPs)
Nothing) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
| HsNoMultAnn{} <- HsMultAnn GhcPs
mult_ann
= do { mb_fun <- LocatedA (PatBuilder GhcPs)
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
isFunLhs LocatedA (PatBuilder GhcPs)
lhs
; case mb_fun of
Just (LocatedN RdrName
fun, LexicalFixity
is_infix, [LocatedA (ArgPatBuilder GhcPs)]
pats, [EpToken "("]
ops, [EpToken ")"]
cps) -> do
let ann_fun :: AnnFunRhs
ann_fun = [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
mk_ann_funrhs [EpToken "("]
ops [EpToken ")"]
cps
let l :: EpaLocation
l = [LocatedA (ArgPatBuilder GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LocatedA (ArgPatBuilder GhcPs)]
pats
SrcSpan
-> AnnFunRhs
-> LocatedN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcSpan
loc AnnFunRhs
ann_fun
LocatedN RdrName
fun LexicalFixity
is_infix (EpaLocation
-> [LocatedA (ArgPatBuilder GhcPs)]
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LocatedA (ArgPatBuilder GhcPs)]
pats) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
Nothing -> do
lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
checkPatBind loc lhs' grhss mult_ann }
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult_ann, Maybe (TokDcolon, LHsType GhcPs)
Nothing) Located (GRHSs GhcPs (LHsExpr GhcPs))
ghrss
= do lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
checkPatBind loc lhs' ghrss mult_ann
mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
mk_ann_funrhs [EpToken "("]
ops [EpToken ")"]
cps = EpToken "!" -> [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
AnnFunRhs EpToken "!"
forall (tok :: Symbol). EpToken tok
NoEpTok [EpToken "("]
ops [EpToken ")"]
cps
checkFunBind :: SrcSpan
-> AnnFunRhs
-> LocatedN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkFunBind :: SrcSpan
-> AnnFunRhs
-> LocatedN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcSpan
locF AnnFunRhs
ann_fun (L SrcSpanAnnN
lf RdrName
fun) LexicalFixity
is_infix (L EpaLocation
lp [LocatedA (ArgPatBuilder GhcPs)]
pats) (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss)
= do ps <- ParseContext
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> P [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
extraDetails ((LocatedA (ArgPatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [LocatedA (ArgPatBuilder 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 (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (ArgPatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLArgPat [LocatedA (ArgPatBuilder GhcPs)]
pats)
let match_span = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ SrcSpan
locF
return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)
[L match_span (Match { m_ext = noExtField
, m_ctxt = FunRhs
{ mc_fun = L lf fun
, mc_fixity = is_infix
, mc_strictness = NoSrcStrict
, mc_an = ann_fun }
, m_pats = L lp ps
, m_grhss = 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
fun) PatIncompleteDoBlock
NoIncompleteDoBlock
| Bool
otherwise = ParseContext
noParseContext
makeFunBind :: LocatedN RdrName -> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind :: LocatedN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LocatedN RdrName
fn LocatedLW [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
NoExtField
noExtField,
fun_id :: XRec GhcPs (IdP GhcPs)
fun_id = XRec GhcPs (IdP GhcPs)
LocatedN RdrName
fn,
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource LocatedLW [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms }
checkPatBind :: SrcSpan
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> HsMultAnn GhcPs
-> P (HsBind GhcPs)
checkPatBind :: SrcSpan
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> HsMultAnn GhcPs
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc (L SrcSpanAnnA
_ (BangPat XBangPat GhcPs
an (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ XRec GhcPs (IdP GhcPs)
v))))
(L SrcSpan
_match_span GRHSs GhcPs (LHsExpr GhcPs)
grhss) (HsNoMultAnn XNoMultAnn GhcPs
_)
= HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v (SrcSpanAnnLW
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnLW
forall e. HasAnnotation e => SrcSpan -> e
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 e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (EpToken "!"
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m XBangPat GhcPs
EpToken "!"
an XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v)]))
where
m :: EpToken "!"
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m EpToken "!"
a LocatedN RdrName
v = Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
NoExtField
noExtField
, m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun = LocatedN RdrName
v
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict
, mc_an :: XFunRhs
mc_an = EpToken "!" -> [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
AnnFunRhs EpToken "!"
a [] [] }
, m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA []
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss }
checkPatBind SrcSpan
_loc LPat GhcPs
lhs (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss) HsMultAnn GhcPs
mult = do
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
-> HsMultAnn GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> HsMultAnn idL
-> GRHSs idR (LHsExpr idR)
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExtField
noExtField LPat GhcPs
lhs HsMultAnn GhcPs
mult GRHSs GhcPs (LHsExpr GhcPs)
grhss)
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpanAnnA
l HsExpr GhcPs
lhs_expr) =
case HsExpr GhcPs
lhs_expr of
HsVar XVar GhcPs
_ lrdr :: XRec GhcPs (IdP GhcPs)
lrdr@(L SrcSpanAnnN
_ RdrName
v) -> RdrName -> LocatedN RdrName -> P (LocatedN RdrName)
check_var RdrName
v XRec GhcPs (IdP GhcPs)
LocatedN RdrName
lrdr
HsExpr GhcPs
_ -> PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Other
where
check_var :: RdrName -> LocatedN RdrName -> P (LocatedN RdrName)
check_var RdrName
v LocatedN RdrName
lrdr
| Bool -> Bool
not (RdrName -> Bool
isUnqual RdrName
v) = PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Qualified
| OccName -> Bool
isDataOcc OccName
occ_n = PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_DataCon
| Bool
otherwise = LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedN RdrName
lrdr
where occ_n :: OccName
occ_n = RdrName -> OccName
rdrNameOcc RdrName
v
make_err :: PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
reason = 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsInvalidTypeSignature -> LHsExpr GhcPs -> PsMessage
PsErrInvalidTypeSignature PsInvalidTypeSignature
reason 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 GenLocated SrcSpanAnnA a
guardExpr Bool
semiThen LocatedA b
thenExpr Bool
semiElse GenLocated SrcSpanAnnA c
elseExpr
| Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse = do
doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
let e = a -> Bool -> b -> Bool -> c -> PsMessage
err (GenLocated SrcSpanAnnA a -> a
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA a
guardExpr)
Bool
semiThen (LocatedA b -> b
forall l e. GenLocated l e -> e
unLoc LocatedA b
thenExpr)
Bool
semiElse (GenLocated SrcSpanAnnA c -> c
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA c
elseExpr)
loc = Located a -> Located c -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs (GenLocated SrcSpanAnnA a -> Located a
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpanAnnA a
guardExpr) (GenLocated SrcSpanAnnA c -> Located c
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpanAnnA c
elseExpr)
unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc 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 (ArgPatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
isFunLhs LocatedA (PatBuilder GhcPs)
e = LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go LocatedA (PatBuilder GhcPs)
e [] [] []
where
mk :: GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk = (PatBuilder p -> ArgPatBuilder p)
-> GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatBuilder p -> ArgPatBuilder p
forall p. PatBuilder p -> ArgPatBuilder p
ArgPatBuilderVisPat
go :: LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go (L SrcSpanAnnA
l (PatBuilderVar (L SrcSpanAnnN
loc RdrName
f))) [LocatedA (ArgPatBuilder GhcPs)]
es [EpToken "("]
ops [EpToken ")"]
cps
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f) = do
let (SrcSpanAnnA
_l, SrcSpanAnnN
loc') = SrcSpanAnnA -> SrcSpanAnnN -> (SrcSpanAnnA, SrcSpanAnnN)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnN
loc
Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
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 (ArgPatBuilder GhcPs)]
es, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), [EpToken ")"]
cps))
go (L SrcSpanAnnA
l (PatBuilderApp (L SrcSpanAnnA
lf PatBuilder GhcPs
f) LocatedA (PatBuilder GhcPs)
e)) [LocatedA (ArgPatBuilder GhcPs)]
es [EpToken "("]
ops [EpToken ")"]
cps = do
let (SrcSpanAnnA
_l, SrcSpanAnnA
lf') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnA
lf
LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lf' PatBuilder GhcPs
f) (LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk LocatedA (PatBuilder GhcPs)
eLocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[LocatedA (ArgPatBuilder GhcPs)]
es) [EpToken "("]
ops [EpToken ")"]
cps
go (L SrcSpanAnnA
l (PatBuilderPar EpToken "("
_ (L SrcSpanAnnA
le PatBuilder GhcPs
e) EpToken ")"
_)) es :: [LocatedA (ArgPatBuilder GhcPs)]
es@(LocatedA (ArgPatBuilder GhcPs)
_:[LocatedA (ArgPatBuilder GhcPs)]
_) [EpToken "("]
ops [EpToken ")"]
cps = LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
le' PatBuilder GhcPs
e) [LocatedA (ArgPatBuilder GhcPs)]
es (EpToken "("
oEpToken "(" -> [EpToken "("] -> [EpToken "("]
forall a. a -> [a] -> [a]
:[EpToken "("]
ops) (EpToken ")"
cEpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
:[EpToken ")"]
cps)
where
(SrcSpanAnnA
_l, SrcSpanAnnA
le') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnA
le
(EpToken "("
o,EpToken ")"
c) = RealSrcSpan -> (EpToken "(", EpToken ")")
mkParensEpToks (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
go (L SrcSpanAnnA
loc (PatBuilderOpApp (L SrcSpanAnnA
ll PatBuilder GhcPs
l) (L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder GhcPs)
r ([EpToken "("]
os,[EpToken ")"]
cs))) [LocatedA (ArgPatBuilder GhcPs)]
es [EpToken "("]
ops [EpToken ")"]
cps
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)
= do { let (SrcSpanAnnA
_l, SrcSpanAnnA
ll') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
loc SrcSpanAnnA
ll
; Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
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 GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ll' PatBuilder GhcPs
l)LocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk LocatedA (PatBuilder GhcPs)
rLocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[LocatedA (ArgPatBuilder GhcPs)]
es), ([EpToken "("]
os [EpToken "("] -> [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a] -> [a]
++ [EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), ([EpToken ")"]
cs [EpToken ")"] -> [EpToken ")"] -> [EpToken ")"]
forall a. [a] -> [a] -> [a]
++ [EpToken ")"]
cps))) }
| Bool
otherwise
= do { let (SrcSpanAnnA
_l, SrcSpanAnnA
ll') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
loc SrcSpanAnnA
ll
; mb_l <- LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ll' PatBuilder GhcPs
l) [LocatedA (ArgPatBuilder GhcPs)]
es [EpToken "("]
ops [EpToken ")"]
cps
; return (reassociate =<< mb_l) }
where
reassociate :: (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
reassociate (LocatedN RdrName
op', LexicalFixity
Infix, LocatedA (ArgPatBuilder GhcPs)
j : L SrcSpanAnnA
k_loc (ArgPatBuilderVisPat PatBuilder GhcPs
k) : [LocatedA (ArgPatBuilder GhcPs)]
es', [EpToken "("]
ops', [EpToken ")"]
cps')
= (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
forall a. a -> Maybe a
Just (LocatedN RdrName
op', LexicalFixity
Infix, LocatedA (ArgPatBuilder GhcPs)
j LocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: LocatedA (ArgPatBuilder GhcPs)
op_app LocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [LocatedA (ArgPatBuilder GhcPs)]
es', [EpToken "("]
ops', [EpToken ")"]
cps')
where
op_app :: LocatedA (ArgPatBuilder GhcPs)
op_app = LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk (LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs))
-> LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (LocatedA (PatBuilder GhcPs)
-> LocatedN RdrName
-> LocatedA (PatBuilder GhcPs)
-> ([EpToken "("], [EpToken ")"])
-> PatBuilder GhcPs
forall p.
LocatedA (PatBuilder p)
-> LocatedN RdrName
-> LocatedA (PatBuilder p)
-> ([EpToken "("], [EpToken ")"])
-> PatBuilder p
PatBuilderOpApp (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
k_loc PatBuilder GhcPs
k)
(SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder GhcPs)
r ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops, [EpToken ")"]
cps))
reassociate (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
_other = Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
forall a. Maybe a
Nothing
go (L SrcSpanAnnA
l (PatBuilderAppType (L SrcSpanAnnA
lp PatBuilder GhcPs
pat) EpToken "@"
tok ty_pat :: HsTyPat GhcPs
ty_pat@(HsTP XHsTP GhcPs
_ (L (EpAnn EpaLocation
anc AnnListItem
ann EpAnnComments
cs) HsType GhcPs
_)))) [LocatedA (ArgPatBuilder GhcPs)]
es [EpToken "("]
ops [EpToken ")"]
cps
= LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lp' PatBuilder GhcPs
pat) (SrcSpanAnnA
-> ArgPatBuilder GhcPs -> LocatedA (ArgPatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
anc' AnnListItem
ann EpAnnComments
cs) (Pat GhcPs -> ArgPatBuilder GhcPs
forall p. Pat p -> ArgPatBuilder p
ArgPatBuilderArgPat Pat GhcPs
invis_pat) LocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [LocatedA (ArgPatBuilder GhcPs)]
es) [EpToken "("]
ops [EpToken ")"]
cps
where invis_pat :: Pat GhcPs
invis_pat = XInvisPat GhcPs -> HsTyPat (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
InvisPat (EpToken "@"
tok, Specificity
SpecifiedSpec) HsTyPat (NoGhcTc GhcPs)
HsTyPat GhcPs
ty_pat
anc' :: EpaLocation
anc' = EpaLocation -> EpToken "@" -> EpaLocation
forall (tok :: Symbol). EpaLocation -> EpToken tok -> EpaLocation
widenAnchorT EpaLocation
anc EpToken "@"
tok
(SrcSpanAnnA
_l, SrcSpanAnnA
lp') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnA
lp
go LocatedA (PatBuilder GhcPs)
_ [LocatedA (ArgPatBuilder GhcPs)]
_ [EpToken "("]
_ [EpToken ")"]
_ = Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
-> P (Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
[EpToken "("], [EpToken ")"])
forall a. Maybe a
Nothing
data ArgPatBuilder p
= ArgPatBuilderVisPat (PatBuilder p)
| ArgPatBuilderArgPat (Pat p)
instance Outputable (ArgPatBuilder GhcPs) where
ppr :: ArgPatBuilder GhcPs -> SDoc
ppr (ArgPatBuilderVisPat PatBuilder GhcPs
p) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p
ppr (ArgPatBuilderArgPat Pat GhcPs
p) = Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
p
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy EpaLocation
tok_loc SrcStrictness
strictness =
XBangTy GhcPs -> HsBang -> LHsType GhcPs -> HsType GhcPs
forall pass. XBangTy pass -> HsBang -> LHsType pass -> HsType pass
HsBangTy ((EpaLocation
forall a. NoAnn a => a
noAnn, EpToken "#-}"
forall a. NoAnn a => a
noAnn, EpaLocation
tok_loc), SourceText
NoSourceText) (SrcUnpackedness -> SrcStrictness -> HsBang
HsBang SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness)
data UnpackednessPragma =
UnpackednessPragma (EpaLocation, EpToken "#-}") SourceText SrcUnpackedness
addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP :: forall (m :: * -> *).
MonadP m =>
Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP (L SrcSpan
lprag (UnpackednessPragma (EpaLocation, EpToken "#-}")
anns SourceText
prag SrcUnpackedness
unpk)) LHsType GhcPs
ty = do
let l' :: SrcSpan
l' = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lprag (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty)
let t' :: HsType GhcPs
t' = (EpaLocation, EpToken "#-}")
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
addUnpackedness (EpaLocation, EpToken "#-}")
anns LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l') HsType GhcPs
t')
where
addUnpackedness :: (EpaLocation, EpToken "#-}")
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
addUnpackedness (EpaLocation
o,EpToken "#-}"
c) (L SrcSpanAnnA
_ (HsBangTy ((EpaLocation
_,EpToken "#-}"
_,EpaLocation
tl), SourceText
NoSourceText) HsBang
bang LHsType GhcPs
t))
| HsBang SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness <- HsBang
bang
= XBangTy GhcPs -> HsBang -> LHsType GhcPs -> HsType GhcPs
forall pass. XBangTy pass -> HsBang -> LHsType pass -> HsType pass
HsBangTy ((EpaLocation
o,EpToken "#-}"
c,EpaLocation
tl), SourceText
prag) (SrcUnpackedness -> SrcStrictness -> HsBang
HsBang SrcUnpackedness
unpk SrcStrictness
strictness) LHsType GhcPs
t
addUnpackedness (EpaLocation
o,EpToken "#-}"
c) GenLocated SrcSpanAnnA (HsType GhcPs)
t
= XBangTy GhcPs -> HsBang -> LHsType GhcPs -> HsType GhcPs
forall pass. XBangTy pass -> HsBang -> LHsType pass -> HsType pass
HsBangTy ((EpaLocation
o,EpToken "#-}"
c,EpaLocation
forall a. NoAnn a => a
noAnn), SourceText
prag) (SrcUnpackedness -> SrcStrictness -> HsBang
HsBang SrcUnpackedness
unpk SrcStrictness
NoSrcStrict) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t
checkMonadComp :: PV HsDoFlavour
checkMonadComp :: PV HsDoFlavour
checkMonadComp = do
monadComprehensions <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
MonadComprehensionsBit
return $ if monadComprehensions
then MonadComp
else ListComp
newtype ECP =
ECP { ECP -> forall b. DisambECP b => PV (LocatedA b)
unECP :: forall b. DisambECP b => PV (LocatedA b) }
ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp LHsExpr GhcPs
a = (forall b. DisambECP b => PV (LocatedA b)) -> ECP
ECP (LHsExpr GhcPs -> PV (LocatedA b)
forall b. DisambECP b => LHsExpr GhcPs -> PV (LocatedA b)
ecpFromExp' LHsExpr GhcPs
a)
ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd LHsCmd GhcPs
a = (forall b. DisambECP b => PV (LocatedA b)) -> ECP
ECP (LHsCmd GhcPs -> PV (LocatedA b)
forall b. DisambECP b => LHsCmd GhcPs -> PV (LocatedA b)
ecpFromCmd' LHsCmd GhcPs
a)
ecpFromPat :: LPat GhcPs -> ECP
ecpFromPat :: LPat GhcPs -> ECP
ecpFromPat LPat GhcPs
a = (forall b. DisambECP b => PV (LocatedA b)) -> ECP
ECP (LPat GhcPs -> PV (LocatedA b)
forall b. DisambECP b => LPat GhcPs -> PV (LocatedA b)
ecpFromPat' LPat GhcPs
a)
type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))
class DisambInfixOp b where
mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)
mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)
mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN b)
instance DisambInfixOp (HsExpr GhcPs) where
mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsVarOpPV LocatedN RdrName
v = LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs)))
-> LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> HsExpr GhcPs -> LocatedN (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (LocatedN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc LocatedN RdrName
v) (XVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v)
mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsConOpPV LocatedN RdrName
v = LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs)))
-> LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> HsExpr GhcPs -> LocatedN (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (LocatedN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc LocatedN RdrName
v) (XVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v)
mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
mkHsInfixHolePV LocatedN (HsExpr GhcPs)
h = LocatedN (HsExpr GhcPs) -> PV (LocatedN (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedN (HsExpr GhcPs)
h
instance DisambInfixOp RdrName where
mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN RdrName)
mkHsConOpPV (L SrcSpanAnnN
l RdrName
v) = LocatedN RdrName -> PV (LocatedN RdrName)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName -> PV (LocatedN RdrName))
-> LocatedN RdrName -> PV (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN RdrName)
mkHsVarOpPV (L SrcSpanAnnN
l RdrName
v) = LocatedN RdrName -> PV (LocatedN RdrName)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName -> PV (LocatedN RdrName))
-> LocatedN RdrName -> PV (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN RdrName)
mkHsInfixHolePV (L SrcSpanAnnN
l HsExpr GhcPs
_) = MsgEnvelope PsMessage -> PV (LocatedN RdrName)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedN RdrName))
-> MsgEnvelope PsMessage -> PV (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. HasLoc a => a -> SrcSpan
getHasLoc SrcSpanAnnN
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
PsErrInvalidInfixHole
type AnnoBody b
= ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO
, Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnLW
, Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
, Anno [LocatedA (StmtLR GhcPs GhcPs
(LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW
)
class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
type Body b :: Type -> Type
ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)
mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b))
mkHsLetPV
:: SrcSpan
-> EpToken "let"
-> HsLocalBinds GhcPs
-> EpToken "in"
-> LocatedA b
-> PV (LocatedA b)
type InfixOp b
superInfixOp
:: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)
mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b
-> PV (LocatedA b)
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)])
-> EpAnnHsCase -> PV (LocatedA b)
mkHsLamPV :: SrcSpan -> HsLamVariant
-> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam
-> PV (LocatedA b)
type FunArg b
superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)
mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)
mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> LocatedA b
-> Bool
-> LocatedA b
-> AnnsIf
-> PV (LocatedA b)
mkHsDoPV ::
SrcSpan ->
Maybe ModuleName ->
LocatedLW [LStmt GhcPs (LocatedA b)] ->
EpaLocation ->
EpaLocation ->
PV (LocatedA b)
mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)
mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)
mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b)
mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)
mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b)
mkHsTySigPV
:: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b)
mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b)
mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)
mkHsRecordPV ::
Bool ->
SrcSpan ->
SrcSpan ->
LocatedA b ->
([Fbind b], Maybe SrcSpan) ->
(Maybe (EpToken "{"), Maybe (EpToken "}")) ->
PV (LocatedA b)
mkHsNegAppPV :: SrcSpan -> LocatedA b -> EpToken "-" -> PV (LocatedA b)
mkHsSectionR_PV
:: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)
mkHsArrowPV
:: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsArrowOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)
mkHsMultPV
:: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsArrowOf (LocatedA b) GhcPs)
mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b)
checkContextPV :: LocatedA b -> PV (LocatedC [LocatedA b])
mkQualPV :: SrcSpan -> LocatedC [LocatedA b] -> LocatedA b -> PV (LocatedA b)
mkHsAsPatPV
:: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b)
mkHsLazyPatPV :: SrcSpan -> LocatedA b -> EpToken "~" -> PV (LocatedA b)
mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b)
mkSumOrTuplePV
:: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b)
mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)
rejectPragmaPV :: LocatedA b -> PV ()
instance DisambECP (HsCmd GhcPs) where
type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' :: LHsCmd GhcPs -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
ecpFromCmd' = LHsCmd GhcPs -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return
ecpFromExp' :: LHsExpr GhcPs -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
ecpFromExp' (L SrcSpanAnnA
l HsExpr GhcPs
e) = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
ecpFromPat' :: LPat GhcPs -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
ecpFromPat' (L SrcSpanAnnA
l Pat GhcPs
p) = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
p)
mkHsProjUpdatePV :: SrcSpan
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
_ GenLocated SrcSpanAnnA (HsCmd GhcPs)
_ Bool
_ Maybe (EpToken "=")
_ = MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))))
-> MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
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
$
PsMessage
PsErrOverloadedRecordDotInvalid
mkHsLamPV :: SrcSpan
-> HsLamVariant
-> LocatedLW [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
-> EpAnnLam
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsLamPV SrcSpan
l HsLamVariant
lam_variant (L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
m) EpAnnLam
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
let mg = Origin
-> HsLamVariant
-> LocatedLW
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> HsLamVariant
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkLamCaseMatchGroup Origin
FromSource HsLamVariant
lam_variant (SrcSpanAnnLW
-> [LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> LocatedLW
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg)
mkHsLetPV :: SrcSpan
-> EpToken "let"
-> HsLocalBinds GhcPs
-> EpToken "in"
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsLetPV SrcSpan
l EpToken "let"
tkLet HsLocalBinds GhcPs
bs EpToken "in"
tkIn GenLocated SrcSpanAnnA (HsCmd GhcPs)
e = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e)
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
superInfixOp :: (DisambInfixOp (InfixOp (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
superInfixOp DisambInfixOp (InfixOp (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
m = PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
DisambInfixOp (InfixOp (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
m
mkHsOpAppPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> LocatedN (InfixOp (HsCmd GhcPs))
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsOpAppPV SrcSpan
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
c1 LocatedN (InfixOp (HsCmd GhcPs))
op GenLocated SrcSpanAnnA (HsCmd GhcPs)
c2 = do
let cmdArg :: GenLocated a (HsCmd p) -> GenLocated l (HsCmdTop p)
cmdArg GenLocated a (HsCmd p)
c = l -> HsCmdTop p -> GenLocated l (HsCmdTop p)
forall l e. l -> e -> GenLocated l e
L (a -> l
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l (a -> l) -> a -> l
forall a b. (a -> b) -> a -> b
$ GenLocated a (HsCmd p) -> a
forall l e. GenLocated l e -> l
getLoc GenLocated a (HsCmd p)
c) (HsCmdTop p -> GenLocated l (HsCmdTop p))
-> HsCmdTop p -> GenLocated l (HsCmdTop p)
forall a b. (a -> b) -> a -> b
$ XCmdTop p -> XRec p (HsCmd p) -> HsCmdTop p
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop XCmdTop p
NoExtField
noExtField XRec p (HsCmd p)
GenLocated a (HsCmd p)
c
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm noAnn (reLoc op) Infix [cmdArg c1, cmdArg c2]
mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> LocatedLW [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
-> EpAnnHsCase
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsCasePV SrcSpan
l LHsExpr GhcPs
c (L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
m) EpAnnHsCase
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
let mg = Origin
-> LocatedLW
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource (SrcSpanAnnLW
-> [LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> LocatedLW
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
[LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg)
type FunArg (HsCmd GhcPs) = HsExpr GhcPs
superFunArg :: (DisambECP (FunArg (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
superFunArg DisambECP (FunArg (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
m = PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
DisambECP (FunArg (HsCmd GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
m
mkHsAppPV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> LocatedA (FunArg (HsCmd GhcPs))
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsAppPV SrcSpanAnnA
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
c LocatedA (FunArg (HsCmd GhcPs))
e = do
LHsCmd GhcPs -> PV ()
checkCmdBlockArguments LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
c
LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
LocatedA (FunArg (HsCmd GhcPs))
e
GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> HsCmd GhcPs -> GenLocated SrcSpanAnnA (HsCmd GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XCmdApp GhcPs -> LHsCmd GhcPs -> LHsExpr GhcPs -> HsCmd GhcPs
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcPs
NoExtField
noExtField LHsCmd GhcPs
GenLocated SrcSpanAnnA (HsCmd GhcPs)
c LHsExpr GhcPs
LocatedA (FunArg (HsCmd GhcPs))
e)
mkHsAppTypePV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> EpToken "@"
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsAppTypePV SrcSpanAnnA
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
c EpToken "@"
_ LHsType GhcPs
t = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t)
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> AnnsIf
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsIfPV SrcSpan
l LHsExpr GhcPs
c Bool
semi1 GenLocated SrcSpanAnnA (HsCmd GhcPs)
a Bool
semi2 GenLocated SrcSpanAnnA (HsCmd GhcPs)
b AnnsIf
anns = do
(HsExpr GhcPs
-> Bool -> HsCmd GhcPs -> Bool -> HsCmd GhcPs -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV ()
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 HsExpr GhcPs
-> Bool -> HsCmd GhcPs -> Bool -> HsCmd GhcPs -> PsMessage
PsErrSemiColonsInCondCmd LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
c Bool
semi1 GenLocated SrcSpanAnnA (HsCmd GhcPs)
a Bool
semi2 GenLocated SrcSpanAnnA (HsCmd GhcPs)
b
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> LocatedLW [LStmt GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
-> EpaLocation
-> EpaLocation
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsDoPV SrcSpan
l Maybe ModuleName
Nothing LocatedLW [LStmt GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
stmts EpaLocation
tok_loc EpaLocation
anc = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts)
mkHsDoPV SrcSpan
l (Just ModuleName
m) LocatedLW [LStmt GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
_ EpaLocation
_ EpaLocation
_ = MsgEnvelope PsMessage -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> MsgEnvelope PsMessage
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
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
$ ModuleName -> PsMessage
PsErrQualifiedDoInCmd ModuleName
m
mkHsParPV :: SrcSpan
-> EpToken "("
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> EpToken ")"
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsParPV SrcSpan
l EpToken "("
lpar GenLocated SrcSpanAnnA (HsCmd GhcPs)
c EpToken ")"
rpar = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
mkHsVarPV :: LocatedN RdrName -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsVarPV (L SrcSpanAnnN
l RdrName
v) = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
l) (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
v)
mkHsLitPV :: Located (HsLit GhcPs) -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsLitPV (L SrcSpan
l HsLit GhcPs
a) = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (HsLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit GhcPs
a)
mkHsOverLitPV :: forall a.
LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a (HsCmd GhcPs))
mkHsOverLitPV (L EpAnn a
l HsOverLit GhcPs
a) = SrcSpan -> SDoc -> PV (LocatedAn a (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (EpAnn a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn a
l) (HsOverLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcPs
a)
mkHsWildCardPV :: forall a. NoAnn a => SrcSpan -> PV (LocatedAn a (HsCmd GhcPs))
mkHsWildCardPV SrcSpan
l = SrcSpan -> SDoc -> PV (LocatedAn a (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_")
mkHsTySigPV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> LHsType GhcPs
-> TokDcolon
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsTySigPV SrcSpanAnnA
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
a LHsType GhcPs
sig TokDcolon
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"::" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
sig)
mkHsExplicitListPV :: SrcSpan
-> [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
-> AnnList ()
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsExplicitListPV SrcSpan
l [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
xs AnnList ()
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ((GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsCmd GhcPs)] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
xs)
mkHsSplicePV :: Located (HsUntypedSplice GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsSplicePV (L SrcSpan
l HsUntypedSplice GhcPs
sp) = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (Bool -> Maybe Name -> HsUntypedSplice GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True Maybe Name
forall a. Maybe a
Nothing HsUntypedSplice GhcPs
sp)
mkHsRecordPV :: Bool
-> SrcSpan
-> SrcSpan
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> ([Fbind (HsCmd GhcPs)], Maybe SrcSpan)
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsRecordPV Bool
_ SrcSpan
l SrcSpan
_ GenLocated SrcSpanAnnA (HsCmd GhcPs)
a ([Fbind (HsCmd GhcPs)]
fbinds, Maybe SrcSpan
ddLoc) (Maybe (EpToken "{"), Maybe (EpToken "}"))
_ = do
let ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
fs, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
ps) = [Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs))))]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))],
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Fbind (HsCmd GhcPs)]
[Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs))))]
fbinds
if Bool -> Bool
not ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
ps)
then MsgEnvelope PsMessage -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> MsgEnvelope PsMessage
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
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
$ PsMessage
PsErrOverloadedRecordDotInvalid
else SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([LocatedA
(HsRecField GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
-> Maybe SrcSpan
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall arg.
[LocatedA (HsRecField GhcPs arg)]
-> Maybe SrcSpan -> HsRecFields GhcPs arg
mk_rec_fields [LocatedA
(HsRecField GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
fs Maybe SrcSpan
ddLoc)
mkHsNegAppPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> EpToken "-"
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsNegAppPV SrcSpan
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
a EpToken "-"
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
a)
mkHsSectionR_PV :: SrcSpan
-> LocatedA (InfixOp (HsCmd GhcPs))
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsSectionR_PV SrcSpan
l LocatedA (InfixOp (HsCmd GhcPs))
op GenLocated SrcSpanAnnA (HsCmd GhcPs)
c = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
let pp_op :: SDoc
pp_op = SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe (String -> SDoc
forall a. HasCallStack => String -> a
panic String
"cannot print infix operator")
(HsExpr GhcPs -> Maybe SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
LocatedA (InfixOp (HsCmd GhcPs))
op))
in SDoc
pp_op SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
c
mkHsArrowPV :: forall lhs.
SrcSpan
-> ArrowParsingMode lhs (HsCmd GhcPs)
-> LocatedA lhs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (HsCmd GhcPs)
mode LocatedA lhs
a HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
arr GenLocated SrcSpanAnnA (HsCmd GhcPs)
b = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
case ArrowParsingMode lhs (HsCmd GhcPs)
mode of
ArrowParsingMode lhs (HsCmd GhcPs)
ArrowIsViewPat -> LocatedA lhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA lhs
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs -> SDoc
forall mult (pass :: Pass).
(Outputable mult, OutputableBndrId pass) =>
HsArrowOf mult (GhcPass pass) -> SDoc
pprHsArrow HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
arr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
b
ArrowParsingMode lhs (HsCmd GhcPs)
ArrowIsFunType -> LocatedA lhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA lhs
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs -> SDoc
forall mult (pass :: Pass).
(Outputable mult, OutputableBndrId pass) =>
HsArrowOf mult (GhcPass pass) -> SDoc
pprHsArrow HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
arr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
b
mkHsMultPV :: EpToken "%"
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV
(TokRarrow
-> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
mkHsMultPV EpToken "%"
pct GenLocated SrcSpanAnnA (HsCmd GhcPs)
mult = SrcSpan
-> SDoc
-> PV
(TokRarrow
-> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc
-> PV
(TokRarrow
-> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs))
-> SDoc
-> PV
(TokRarrow
-> HsArrowOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$
EpToken "%" -> SDoc
forall a. Outputable a => a -> SDoc
ppr EpToken "%"
pct SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
mult
where l :: SrcSpan
l = EpToken "%" -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc EpToken "%"
pct SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc GenLocated SrcSpanAnnA (HsCmd GhcPs)
mult
mkHsForallPV :: SrcSpan
-> HsForAllTelescope GhcPs
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsForallPV SrcSpan
l HsForAllTelescope GhcPs
tele GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
HsForAllTelescope GhcPs -> Maybe (LHsContext GhcPs) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsForAllTelescope (GhcPass p)
-> Maybe (LHsContext (GhcPass p)) -> SDoc
pprHsForAll HsForAllTelescope GhcPs
tele Maybe (LHsContext GhcPs)
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. Maybe a
Nothing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
checkContextPV :: GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)])
checkContextPV GenLocated SrcSpanAnnA (HsCmd GhcPs)
ctxt = SrcSpan
-> SDoc -> PV (LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)])
forall a. SrcSpan -> SDoc -> PV a
cmdFail (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsCmd GhcPs)
ctxt) (SDoc -> PV (LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)]))
-> SDoc -> PV (LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
ctxt
mkQualPV :: SrcSpan
-> LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkQualPV SrcSpan
l LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
ctxt GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedC [GenLocated SrcSpanAnnA (HsCmd GhcPs)]
ctxt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=>" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
cmd
mkHsAsPatPV :: SrcSpan
-> LocatedN RdrName
-> EpToken "@"
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsAsPatPV SrcSpan
l LocatedN RdrName
v EpToken "@"
_ GenLocated SrcSpanAnnA (HsCmd GhcPs)
c = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
RdrName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
v) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
c
mkHsLazyPatPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> EpToken "~"
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsLazyPatPV SrcSpan
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
c EpToken "~"
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"~" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
c
mkHsBangPatPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> EpToken "!"
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsBangPatPV SrcSpan
l GenLocated SrcSpanAnnA (HsCmd GhcPs)
c EpToken "!"
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
-> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"!" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsCmd GhcPs)
c
mkSumOrTuplePV :: SrcSpanAnnA
-> Boxity
-> SumOrTuple (HsCmd GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkSumOrTuplePV SrcSpanAnnA
l Boxity
boxity SumOrTuple (HsCmd GhcPs)
a (EpaLocation, EpaLocation)
_ = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (Boxity -> SumOrTuple (HsCmd GhcPs) -> SDoc
forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
boxity SumOrTuple (HsCmd GhcPs)
a)
mkHsEmbTyPV :: SrcSpan
-> EpToken "type"
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsEmbTyPV SrcSpan
l EpToken "type"
_ LHsType GhcPs
ty = SrcSpan -> SDoc -> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty)
rejectPragmaPV :: GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
rejectPragmaPV GenLocated SrcSpanAnnA (HsCmd GhcPs)
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cmdFail :: SrcSpan -> SDoc -> PV a
cmdFail :: forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
loc SDoc
e = 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
$ SDoc -> PsMessage
PsErrParseErrorInCmd SDoc
e
checkLamMatchGroup :: SrcSpan -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()
checkLamMatchGroup :: SrcSpan
-> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()
checkLamMatchGroup SrcSpan
l HsLamVariant
LamSingle (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnLW
_ (GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matches:[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_))}) = do
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LPat GhcPs]
forall (id :: Pass) body.
LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matches)) (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$ 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 SrcSpan
l PsMessage
PsErrEmptyLambda
checkLamMatchGroup SrcSpan
_ HsLamVariant
_ MatchGroup GhcPs (LHsExpr GhcPs)
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance DisambECP (HsExpr GhcPs) where
type Body (HsExpr GhcPs) = HsExpr
ecpFromCmd' :: LHsCmd GhcPs -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ecpFromCmd' (L SrcSpanAnnA
l HsCmd GhcPs
c) = 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ HsCmd GhcPs -> PsMessage
PsErrArrowCmdInExpr HsCmd GhcPs
c
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn))
ecpFromExp' :: LHsExpr GhcPs -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ecpFromExp' = LHsExpr GhcPs -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return
ecpFromPat' :: LPat GhcPs -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ecpFromPat' p :: LPat GhcPs
p@(L SrcSpanAnnA
l Pat GhcPs
_) = 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> PsMessage
PsErrOrPatInExpr LPat GhcPs
p
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn))
mkHsProjUpdatePV :: SrcSpan
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
fields GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
isPun Maybe (EpToken "=")
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns
mkHsLetPV :: SrcSpan
-> EpToken "let"
-> HsLocalBinds GhcPs
-> EpToken "in"
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsLetPV SrcSpan
l EpToken "let"
tkLet HsLocalBinds GhcPs
bs EpToken "in"
tkIn GenLocated SrcSpanAnnA (HsExpr GhcPs)
c = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c)
type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
superInfixOp :: (DisambInfixOp (InfixOp (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
superInfixOp DisambInfixOp (InfixOp (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m = PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
DisambInfixOp (InfixOp (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
mkHsOpAppPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedN (InfixOp (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsOpAppPV SrcSpan
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1 LocatedN (InfixOp (HsExpr GhcPs))
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2 = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp noExtField e1 (reLoc op) e2
mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> LocatedLW [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> EpAnnHsCase
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsCasePV SrcSpan
l LHsExpr GhcPs
e (L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
m) EpAnnHsCase
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
let mg = Origin
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource (SrcSpanAnnLW
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg)
mkHsLamPV :: SrcSpan
-> HsLamVariant
-> LocatedLW [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> EpAnnLam
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsLamPV SrcSpan
l HsLamVariant
lam_variant (L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
m) EpAnnLam
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
let mg = Origin
-> HsLamVariant
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> HsLamVariant
-> LocatedLW
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkLamCaseMatchGroup Origin
FromSource HsLamVariant
lam_variant (SrcSpanAnnLW
-> [GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLW
lm [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
[GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m)
checkLamMatchGroup l lam_variant mg
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg :: (DisambECP (FunArg (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
superFunArg DisambECP (FunArg (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m = PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
DisambECP (FunArg (HsExpr GhcPs)) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
mkHsAppPV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedA (FunArg (HsExpr GhcPs))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsAppPV SrcSpanAnnA
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1 LocatedA (FunArg (HsExpr GhcPs))
e2 = do
LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1
LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
LocatedA (FunArg (HsExpr GhcPs))
e2
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExtField
noExtField LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1 LHsExpr GhcPs
LocatedA (FunArg (HsExpr GhcPs))
e2)
mkHsAppTypePV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> EpToken "@"
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsAppTypePV SrcSpanAnnA
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
e EpToken "@"
at LHsType GhcPs
t = do
LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
EpToken "@"
at LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t))
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> AnnsIf
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsIfPV SrcSpan
l LHsExpr GhcPs
c Bool
semi1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
a Bool
semi2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
b AnnsIf
anns = do
(HsExpr GhcPs
-> Bool -> HsExpr GhcPs -> Bool -> HsExpr GhcPs -> PsMessage)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV ()
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 HsExpr GhcPs
-> Bool -> HsExpr GhcPs -> Bool -> HsExpr GhcPs -> PsMessage
PsErrSemiColonsInCondExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
c Bool
semi1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
a Bool
semi2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
b
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> LocatedLW [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> EpaLocation
-> EpaLocation
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsDoPV SrcSpan
l Maybe ModuleName
mod LocatedLW [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
stmts EpaLocation
loc_tok EpaLocation
anc = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts)
mkHsParPV :: SrcSpan
-> EpToken "("
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> EpToken ")"
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsParPV SrcSpan
l EpToken "("
lpar GenLocated SrcSpanAnnA (HsExpr GhcPs)
e EpToken ")"
rpar = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
mkHsVarPV :: LocatedN RdrName -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsVarPV v :: LocatedN RdrName
v@(L l :: SrcSpanAnnN
l@(EpAnn EpaLocation
anc NameAnn
_ EpAnnComments
_) RdrName
_) = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc SrcSpanAnnN
l)
return $ L (EpAnn anc noAnn cs) (HsVar noExtField v)
mkHsLitPV :: Located (HsLit GhcPs) -> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsLitPV (L SrcSpan
l HsLit GhcPs
a) = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a)
mkHsOverLitPV :: forall a.
LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a (HsExpr GhcPs))
mkHsOverLitPV (L (EpAnn EpaLocation
l a
an EpAnnComments
csIn) HsOverLit GhcPs
a) = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (EpaLocation -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpaLocation
l)
return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a)
mkHsWildCardPV :: forall a. NoAnn a => SrcSpan -> PV (LocatedAn a (HsExpr GhcPs))
mkHsWildCardPV SrcSpan
l = LocatedAn a (HsExpr GhcPs) -> PV (LocatedAn a (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn a (HsExpr GhcPs) -> PV (LocatedAn a (HsExpr GhcPs)))
-> LocatedAn a (HsExpr GhcPs) -> PV (LocatedAn a (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a -> HsExpr GhcPs -> LocatedAn a (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnn a
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn)
mkHsTySigPV :: SrcSpanAnnA
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LHsType GhcPs
-> TokDcolon
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsTySigPV l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
csIn) GenLocated SrcSpanAnnA (HsExpr GhcPs)
a LHsType GhcPs
sig TokDcolon
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig))
mkHsExplicitListPV :: SrcSpan
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> AnnList ()
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsExplicitListPV SrcSpan
l [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs AnnList ()
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs)
mkHsSplicePV :: Located (HsUntypedSplice GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsSplicePV (L SrcSpan
l HsUntypedSplice GhcPs
a) = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a)
mkHsRecordPV :: Bool
-> SrcSpan
-> SrcSpan
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsRecordPV Bool
opts SrcSpan
l SrcSpan
lrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
a ([Fbind (HsExpr GhcPs)]
fbinds, Maybe SrcSpan
ddLoc) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns
checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)
mkHsNegAppPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> EpToken "-"
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsNegAppPV SrcSpan
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
a EpToken "-"
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr)
mkHsSectionR_PV :: SrcSpan
-> LocatedA (InfixOp (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsSectionR_PV SrcSpan
l LocatedA (InfixOp (HsExpr GhcPs))
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e)
mkHsAsPatPV :: SrcSpan
-> LocatedN RdrName
-> EpToken "@"
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsAsPatPV SrcSpan
l LocatedN RdrName
v EpToken "@"
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = 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
l (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs -> PsMessage
PsErrTypeAppWithoutSpace (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
v) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e)
PV ()
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. PV a -> PV b -> PV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn))
mkHsLazyPatPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> EpToken "~"
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsLazyPatPV SrcSpan
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
e EpToken "~"
_ = 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
l (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> PsMessage
PsErrLazyPatWithoutSpace LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e)
PV ()
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. PV a -> PV b -> PV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn))
mkHsBangPatPV :: SrcSpan
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> EpToken "!"
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsBangPatPV SrcSpan
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
e EpToken "!"
_ = 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
l (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> PsMessage
PsErrBangPatWithoutSpace LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e)
PV ()
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. PV a -> PV b -> PV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
forall a. NoAnn a => a
noAnn))
mkSumOrTuplePV :: SrcSpanAnnA
-> Boxity
-> SumOrTuple (HsExpr GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkSumOrTuplePV = SrcSpanAnnA
-> Boxity
-> SumOrTuple (HsExpr GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LHsExpr GhcPs)
SrcSpanAnnA
-> Boxity
-> SumOrTuple (HsExpr GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkSumOrTupleExpr
mkHsEmbTyPV :: SrcSpan
-> EpToken "type"
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsEmbTyPV SrcSpan
l EpToken "type"
toktype LHsType GhcPs
ty =
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XEmbTy GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p. XEmbTy p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsEmbTy XEmbTy GhcPs
EpToken "type"
toktype (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty)
mkHsArrowPV :: forall lhs.
SrcSpan
-> ArrowParsingMode lhs (HsExpr GhcPs)
-> LocatedA lhs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (HsExpr GhcPs)
mode LocatedA lhs
arg HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
arr GenLocated SrcSpanAnnA (HsExpr GhcPs)
res =
ArrowParsingMode lhs (HsExpr GhcPs)
-> ((lhs ~ HsExpr GhcPs) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall lhs r.
ArrowParsingMode lhs (HsExpr GhcPs)
-> ((lhs ~ HsExpr GhcPs) => r) -> r
exprArrowParsingMode ArrowParsingMode lhs (HsExpr GhcPs)
mode (((lhs ~ HsExpr GhcPs) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ((lhs ~ HsExpr GhcPs) =>
PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XFunArr GhcPs
-> HsArrowOf (LHsExpr GhcPs) GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall p.
XFunArr p
-> HsArrowOf (LHsExpr p) p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsFunArr XFunArr GhcPs
NoExtField
noExtField HsArrowOf (LHsExpr GhcPs) GhcPs
HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
arr LHsExpr GhcPs
LocatedA lhs
arg LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
res
mkHsMultPV :: EpToken "%"
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV
(TokRarrow
-> HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs)
mkHsMultPV EpToken "%"
pct GenLocated SrcSpanAnnA (HsExpr GhcPs)
t =
(TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs)
-> PV (TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs)
-> PV (TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs))
-> (TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs)
-> PV (TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs)
forall a b. (a -> b) -> a -> b
$ EpToken "%"
-> LHsExpr GhcPs -> TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs
mkMultExpr EpToken "%"
pct LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
t
mkHsForallPV :: SrcSpan
-> HsForAllTelescope GhcPs
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsForallPV SrcSpan
l HsForAllTelescope GhcPs
telescope GenLocated SrcSpanAnnA (HsExpr GhcPs)
ty =
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XForAll GhcPs
-> HsForAllTelescope GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XForAll p -> HsForAllTelescope p -> LHsExpr p -> HsExpr p
HsForAll XForAll GhcPs
NoExtField
noExtField (NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
setTelescopeBndrsNameSpace NameSpace
varName HsForAllTelescope GhcPs
telescope) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
ty
checkContextPV :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
checkContextPV = LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
checkContextExpr
mkQualPV :: SrcSpan
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkQualPV SrcSpan
l GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
qual GenLocated SrcSpanAnnA (HsExpr GhcPs)
ty =
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XQual GhcPs
-> XRec GhcPs [LHsExpr GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XQual p -> XRec p [LHsExpr p] -> LHsExpr p -> HsExpr p
HsQual XQual GhcPs
NoExtField
noExtField XRec GhcPs [LHsExpr GhcPs]
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
qual LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
ty
rejectPragmaPV :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
rejectPragmaPV (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
e)) =
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
forall b. DisambECP b => LocatedA b -> PV ()
rejectPragmaPV LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
rejectPragmaPV (L SrcSpanAnnA
l (HsPragE XPragE GhcPs
_ HsPragE GhcPs
prag LHsExpr GhcPs
_)) = 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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsPragE GhcPs -> PsMessage
PsErrUnallowedPragma HsPragE GhcPs
prag)
rejectPragmaPV GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr Maybe EpAnnUnboundVar
anns = XUnboundVar GhcPs -> RdrName -> HsExpr GhcPs
forall p. XUnboundVar p -> RdrName -> HsExpr p
HsUnboundVar Maybe EpAnnUnboundVar
XUnboundVar GhcPs
anns (OccName -> RdrName
mkRdrUnqual (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"_")))
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA (PatBuilder GhcPs))
ecpFromCmd' (L SrcSpanAnnA
l HsCmd GhcPs
c) = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ HsCmd GhcPs -> PsMessage
PsErrArrowCmdInPat HsCmd GhcPs
c
ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA (PatBuilder GhcPs))
ecpFromExp' (L SrcSpanAnnA
l HsExpr GhcPs
e) = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> PsMessage
PsErrArrowExprInPat HsExpr GhcPs
e
ecpFromPat' :: LPat GhcPs -> PV (LocatedA (PatBuilder GhcPs))
ecpFromPat' (L SrcSpanAnnA
l Pat GhcPs
p) = LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs)))
-> LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat Pat GhcPs
p)
mkHsLetPV :: SrcSpan
-> EpToken "let"
-> HsLocalBinds GhcPs
-> EpToken "in"
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsLetPV SrcSpan
l EpToken "let"
_ HsLocalBinds GhcPs
_ EpToken "in"
_ LocatedA (PatBuilder GhcPs)
_ = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrLetInPat
mkHsProjUpdatePV :: SrcSpan
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LocatedA (PatBuilder GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (LocatedA (PatBuilder GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
_ LocatedA (PatBuilder GhcPs)
_ Bool
_ Maybe (EpToken "=")
_ = MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (LocatedA (PatBuilder GhcPs)))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (LocatedA (PatBuilder GhcPs))))
-> MsgEnvelope PsMessage
-> PV (LHsRecProj GhcPs (LocatedA (PatBuilder GhcPs)))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrOverloadedRecordDotInvalid
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp :: (DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs)))
-> PV (LocatedA (PatBuilder GhcPs))
superInfixOp DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs))
m = PV (LocatedA (PatBuilder GhcPs))
DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs))
m
mkHsOpAppPV :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> LocatedN (InfixOp (PatBuilder GhcPs))
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsOpAppPV SrcSpan
l LocatedA (PatBuilder GhcPs)
p1 LocatedN (InfixOp (PatBuilder GhcPs))
op LocatedA (PatBuilder GhcPs)
p2 = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[])
mkHsLamPV :: SrcSpan
-> HsLamVariant
-> LocatedLW [LMatch GhcPs (LocatedA (PatBuilder GhcPs))]
-> EpAnnLam
-> PV (LocatedA (PatBuilder GhcPs))
mkHsLamPV SrcSpan
l HsLamVariant
lam_variant LocatedLW [LMatch GhcPs (LocatedA (PatBuilder GhcPs))]
_ EpAnnLam
_ = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l (HsLamVariant -> PsMessage
PsErrLambdaInPat HsLamVariant
lam_variant)
mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> LocatedLW [LMatch GhcPs (LocatedA (PatBuilder GhcPs))]
-> EpAnnHsCase
-> PV (LocatedA (PatBuilder GhcPs))
mkHsCasePV SrcSpan
l LHsExpr GhcPs
_ LocatedLW [LMatch GhcPs (LocatedA (PatBuilder GhcPs))]
_ EpAnnHsCase
_ = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrCaseInPat
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg :: (DisambECP (FunArg (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs)))
-> PV (LocatedA (PatBuilder GhcPs))
superFunArg DisambECP (FunArg (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs))
m = PV (LocatedA (PatBuilder GhcPs))
DisambECP (FunArg (PatBuilder GhcPs)) =>
PV (LocatedA (PatBuilder GhcPs))
m
mkHsAppPV :: SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> LocatedA (FunArg (PatBuilder GhcPs))
-> PV (LocatedA (PatBuilder GhcPs))
mkHsAppPV SrcSpanAnnA
l LocatedA (PatBuilder GhcPs)
p1 LocatedA (FunArg (PatBuilder GhcPs))
p2 = LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs)))
-> LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (LocatedA (PatBuilder GhcPs)
-> LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p.
LocatedA (PatBuilder p) -> LocatedA (PatBuilder p) -> PatBuilder p
PatBuilderApp LocatedA (PatBuilder GhcPs)
p1 LocatedA (PatBuilder GhcPs)
LocatedA (FunArg (PatBuilder GhcPs))
p2)
mkHsAppTypePV :: SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> EpToken "@"
-> LHsType GhcPs
-> PV (LocatedA (PatBuilder GhcPs))
mkHsAppTypePV SrcSpanAnnA
l LocatedA (PatBuilder GhcPs)
p EpToken "@"
at LHsType GhcPs
t = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> LocatedA (PatBuilder GhcPs)
-> Bool
-> LocatedA (PatBuilder GhcPs)
-> AnnsIf
-> PV (LocatedA (PatBuilder GhcPs))
mkHsIfPV SrcSpan
l LHsExpr GhcPs
_ Bool
_ LocatedA (PatBuilder GhcPs)
_ Bool
_ LocatedA (PatBuilder GhcPs)
_ AnnsIf
_ = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrIfThenElseInPat
mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> LocatedLW [LStmt GhcPs (LocatedA (PatBuilder GhcPs))]
-> EpaLocation
-> EpaLocation
-> PV (LocatedA (PatBuilder GhcPs))
mkHsDoPV SrcSpan
l Maybe ModuleName
_ LocatedLW [LStmt GhcPs (LocatedA (PatBuilder GhcPs))]
_ EpaLocation
_ EpaLocation
_ = MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrDoNotationInPat
mkHsParPV :: SrcSpan
-> EpToken "("
-> LocatedA (PatBuilder GhcPs)
-> EpToken ")"
-> PV (LocatedA (PatBuilder GhcPs))
mkHsParPV SrcSpan
l EpToken "("
lpar LocatedA (PatBuilder GhcPs)
p EpToken ")"
rpar = LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs)))
-> LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (EpToken "("
-> LocatedA (PatBuilder GhcPs) -> EpToken ")" -> PatBuilder GhcPs
forall p.
EpToken "("
-> LocatedA (PatBuilder p) -> EpToken ")" -> PatBuilder p
PatBuilderPar EpToken "("
lpar LocatedA (PatBuilder GhcPs)
p EpToken ")"
rpar)
mkHsVarPV :: LocatedN RdrName -> PV (LocatedA (PatBuilder GhcPs))
mkHsVarPV v :: LocatedN RdrName
v@(LocatedN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc -> SrcSpanAnnN
l) = LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs)))
-> LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
l) (LocatedN RdrName -> PatBuilder GhcPs
forall p. LocatedN RdrName -> PatBuilder p
PatBuilderVar LocatedN RdrName
v)
mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
mkHsLitPV lit :: Located (HsLit GhcPs)
lit@(L SrcSpan
l HsLit GhcPs
a) = do
Located (HsLit GhcPs) -> PV ()
checkUnboxedLitPat Located (HsLit GhcPs)
lit
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a))
mkHsOverLitPV :: forall a.
LocatedAn a (HsOverLit GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
mkHsOverLitPV (L EpAnn a
l HsOverLit GhcPs
a) = LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs)))
-> LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a -> PatBuilder GhcPs -> LocatedAn a (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L EpAnn a
l (HsOverLit GhcPs -> PatBuilder GhcPs
forall p. HsOverLit GhcPs -> PatBuilder p
PatBuilderOverLit HsOverLit GhcPs
a)
mkHsWildCardPV :: forall a. NoAnn a => SrcSpan -> PV (LocatedAn a (PatBuilder GhcPs))
mkHsWildCardPV SrcSpan
l = LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs)))
-> LocatedAn a (PatBuilder GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a -> PatBuilder GhcPs -> LocatedAn a (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnn a
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExtField
noExtField))
mkHsTySigPV :: SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> LHsType GhcPs
-> TokDcolon
-> PV (LocatedA (PatBuilder GhcPs))
mkHsTySigPV SrcSpanAnnA
l LocatedA (PatBuilder GhcPs)
p LHsType GhcPs
t TokDcolon
anns = do
p' <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
p
let sig = EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnnCO
forall a. NoAnn a => a
noAnn LHsType GhcPs
t
sig_pat <- addSigPatP l p' sig anns
return $ fmap PatBuilderPat sig_pat
mkHsExplicitListPV :: SrcSpan
-> [LocatedA (PatBuilder GhcPs)]
-> AnnList ()
-> PV (LocatedA (PatBuilder GhcPs))
mkHsExplicitListPV SrcSpan
l [LocatedA (PatBuilder GhcPs)]
xs AnnList ()
anns = do
ps <- (LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [LocatedA (PatBuilder GhcPs)]
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat [LocatedA (PatBuilder GhcPs)]
xs
!cs <- getCommentsFor l
return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps)))
mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
mkHsSplicePV (L SrcSpan
l HsUntypedSplice GhcPs
sp) = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV :: Bool
-> SrcSpan
-> SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> ([Fbind (PatBuilder GhcPs)], Maybe SrcSpan)
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (LocatedA (PatBuilder GhcPs))
mkHsRecordPV Bool
_ SrcSpan
l SrcSpan
_ LocatedA (PatBuilder GhcPs)
a ([Fbind (PatBuilder GhcPs)]
fbinds, Maybe SrcSpan
ddLoc) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns = do
let ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))]
fs, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs)))]
ps) = [Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs))))]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))],
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs)))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Fbind (PatBuilder GhcPs)]
[Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs))))]
fbinds
if Bool -> Bool
not ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(LocatedA (PatBuilder GhcPs)))]
ps)
then MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrOverloadedRecordDotInvalid
else do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
r <- mkPatRec a (mk_rec_fields fs ddLoc) anns
checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)
mkHsNegAppPV :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> EpToken "-"
-> PV (LocatedA (PatBuilder GhcPs))
mkHsNegAppPV SrcSpan
l (L SrcSpanAnnA
lp PatBuilder GhcPs
p) EpToken "-"
anns = do
lit <- case PatBuilder GhcPs
p of
PatBuilderOverLit HsOverLit GhcPs
pos_lit -> LocatedAn NoEpAnns (HsOverLit GhcPs)
-> PV (LocatedAn NoEpAnns (HsOverLit GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpAnnCO -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnCO
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
lp) HsOverLit GhcPs
pos_lit)
PatBuilder GhcPs
_ -> SrcSpan -> PsMessage -> PV (LocatedAn NoEpAnns (HsOverLit GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
l (PsMessage -> PV (LocatedAn NoEpAnns (HsOverLit GhcPs)))
-> PsMessage -> PV (LocatedAn NoEpAnns (HsOverLit GhcPs))
forall a b. (a -> b) -> a -> b
$ PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage
PsErrInPat PatBuilder GhcPs
p PsErrInPatDetails
PEIP_NegApp
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns))
mkHsSectionR_PV :: SrcSpan
-> LocatedA (InfixOp (PatBuilder GhcPs))
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsSectionR_PV SrcSpan
l LocatedA (InfixOp (PatBuilder GhcPs))
op LocatedA (PatBuilder GhcPs)
p = SrcSpan -> PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
l (RdrName -> PatBuilder GhcPs -> PsMessage
PsErrParseRightOpSectionInPat (GenLocated SrcSpanAnnA RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA RdrName
LocatedA (InfixOp (PatBuilder GhcPs))
op) (LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall l e. GenLocated l e -> e
unLoc LocatedA (PatBuilder GhcPs)
p))
mkHsArrowPV :: forall lhs.
SrcSpan
-> ArrowParsingMode lhs (PatBuilder GhcPs)
-> LocatedA lhs
-> HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (PatBuilder GhcPs)
ArrowIsViewPat LocatedA lhs
a HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr LocatedA (PatBuilder GhcPs)
b = do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat tok a p))
where
tok :: TokRarrow
tok :: TokRarrow
tok = case HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr of
HsUnrestrictedArrow XUnrestrictedArrow (LocatedA (PatBuilder GhcPs)) GhcPs
x -> TokRarrow
XUnrestrictedArrow (LocatedA (PatBuilder GhcPs)) GhcPs
x
HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
_ ->
String -> TokRarrow
forall a. HasCallStack => String -> a
panic String
"mkHsArrowPV ArrowIsViewPat: expected HsUnrestrictedArrow"
mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (PatBuilder GhcPs)
ArrowIsFunType LocatedA lhs
a HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr LocatedA (PatBuilder GhcPs)
b =
SrcSpan -> PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
l (PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxInPat (LocatedA (PatBuilder GhcPs)
-> HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> LocatedA (PatBuilder GhcPs)
-> PsErrTypeSyntaxDetails
PETS_FunctionArrow LocatedA lhs
LocatedA (PatBuilder GhcPs)
a HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr LocatedA (PatBuilder GhcPs)
b))
mkHsMultPV :: EpToken "%"
-> LocatedA (PatBuilder GhcPs)
-> PV (TokRarrow -> HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs)
mkHsMultPV EpToken "%"
tok LocatedA (PatBuilder GhcPs)
arg =
let l :: SrcSpan
l = EpToken "%" -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc EpToken "%"
tok SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` LocatedA (PatBuilder GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LocatedA (PatBuilder GhcPs)
arg in
SrcSpan
-> PsMessage
-> PV (TokRarrow -> HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs)
forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
l (PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxInPat (EpToken "%"
-> LocatedA (PatBuilder GhcPs) -> PsErrTypeSyntaxDetails
PETS_Multiplicity EpToken "%"
tok LocatedA (PatBuilder GhcPs)
arg))
mkHsForallPV :: SrcSpan
-> HsForAllTelescope GhcPs
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsForallPV SrcSpan
l HsForAllTelescope GhcPs
tele LocatedA (PatBuilder GhcPs)
body = SrcSpan -> PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. SrcSpan -> PsMessage -> PV a
patFail SrcSpan
l (PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxInPat (HsForAllTelescope GhcPs
-> LocatedA (PatBuilder GhcPs) -> PsErrTypeSyntaxDetails
PETS_ForallTelescope HsForAllTelescope GhcPs
tele LocatedA (PatBuilder GhcPs)
body))
checkContextPV :: LocatedA (PatBuilder GhcPs)
-> PV (LocatedC [LocatedA (PatBuilder GhcPs)])
checkContextPV LocatedA (PatBuilder GhcPs)
ctx = SrcSpan -> PsMessage -> PV (LocatedC [LocatedA (PatBuilder GhcPs)])
forall a. SrcSpan -> PsMessage -> PV a
patFail (LocatedA (PatBuilder GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LocatedA (PatBuilder GhcPs)
ctx) (PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxInPat (LocatedA (PatBuilder GhcPs) -> PsErrTypeSyntaxDetails
PETS_ConstraintContext LocatedA (PatBuilder GhcPs)
ctx))
mkQualPV :: SrcSpan
-> LocatedC [LocatedA (PatBuilder GhcPs)]
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkQualPV SrcSpan
_ LocatedC [LocatedA (PatBuilder GhcPs)]
_ LocatedA (PatBuilder GhcPs)
_ =
String -> PV (LocatedA (PatBuilder GhcPs))
forall a. HasCallStack => String -> a
panic String
"mkQualPV in a pattern"
mkHsAsPatPV :: SrcSpan
-> LocatedN RdrName
-> EpToken "@"
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsAsPatPV SrcSpan
l LocatedN RdrName
v EpToken "@"
at LocatedA (PatBuilder GhcPs)
e = do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p))
mkHsLazyPatPV :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> EpToken "~"
-> PV (LocatedA (PatBuilder GhcPs))
mkHsLazyPatPV SrcSpan
l LocatedA (PatBuilder GhcPs)
e EpToken "~"
a = do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p))
mkHsBangPatPV :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> EpToken "!"
-> PV (LocatedA (PatBuilder GhcPs))
mkHsBangPatPV SrcSpan
l LocatedA (PatBuilder GhcPs)
e EpToken "!"
an = do
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
!cs <- getCommentsFor l
let pb = XBangPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcPs
EpToken "!"
an LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p
hintBangPat l pb
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb)
mkSumOrTuplePV :: SrcSpanAnnA
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LocatedA (PatBuilder GhcPs))
mkSumOrTuplePV = SrcSpanAnnA
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LocatedA (PatBuilder GhcPs))
mkSumOrTuplePat
mkHsEmbTyPV :: SrcSpan
-> EpToken "type"
-> LHsType GhcPs
-> PV (LocatedA (PatBuilder GhcPs))
mkHsEmbTyPV SrcSpan
l EpToken "type"
toktype LHsType GhcPs
ty =
LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs)))
-> LocatedA (PatBuilder GhcPs) -> PV (LocatedA (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs))
-> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$
Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XEmbTyPat GhcPs -> HsTyPat (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XEmbTyPat p -> HsTyPat (NoGhcTc p) -> Pat p
EmbTyPat XEmbTyPat GhcPs
EpToken "type"
toktype (LHsType GhcPs -> HsTyPat GhcPs
mkHsTyPat LHsType GhcPs
ty))
rejectPragmaPV :: LocatedA (PatBuilder GhcPs) -> PV ()
rejectPragmaPV LocatedA (PatBuilder GhcPs)
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addSigPatP :: SrcSpanAnnA -> LPat GhcPs -> HsPatSigType GhcPs -> TokDcolon -> PV (LPat GhcPs)
addSigPatP :: SrcSpanAnnA
-> LPat GhcPs -> HsPatSigType GhcPs -> TokDcolon -> PV (LPat GhcPs)
addSigPatP SrcSpanAnnA
l viewpat :: LPat GhcPs
viewpat@(L SrcSpanAnnA
_ ViewPat{}) HsPatSigType GhcPs
sig TokDcolon
anns =
do { let futureParse :: GenLocated SrcSpanAnnA (Pat GhcPs)
futureParse = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
TokDcolon
anns LPat GhcPs
viewpat HsPatSigType (NoGhcTc GhcPs)
HsPatSigType GhcPs
sig)
; legacyParse <- LPat GhcPs -> PV (LPat GhcPs)
go LPat GhcPs
viewpat
; addPsMessage (locA l) (PsWarnViewPatternSignatures legacyParse futureParse)
; return legacyParse }
where
sig_loc_no_comments :: SrcSpan
sig_loc_no_comments :: SrcSpan
sig_loc_no_comments = GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (HsPatSigType GhcPs -> LHsType GhcPs
forall pass. HsPatSigType pass -> LHsType pass
hsps_body HsPatSigType GhcPs
sig)
go :: LPat GhcPs -> PV (LPat GhcPs)
go :: LPat GhcPs -> PV (LPat GhcPs)
go (L (EpAnn (EpaSpan SrcSpan
view_pat_loc) AnnListItem
anns EpAnnComments
cs1) (ViewPat XViewPat GhcPs
anns' LHsExpr GhcPs
e' LPat GhcPs
p')) = do
sig' <- LPat GhcPs -> PV (LPat GhcPs)
go LPat GhcPs
p'
let new_loc = SrcSpan
view_pat_loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` SrcSpan
sig_loc_no_comments
cs2 <- getCommentsFor new_loc
let ep_ann_loc = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
new_loc) AnnListItem
anns (EpAnnComments
cs1 EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
pure (L ep_ann_loc (ViewPat anns' e' sig'))
go LPat GhcPs
p = LPat GhcPs -> PV (LPat GhcPs)
forall a. a -> PV a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPat GhcPs -> PV (LPat GhcPs)) -> LPat GhcPs -> PV (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
new_loc (XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
TokDcolon
anns LPat GhcPs
p HsPatSigType (NoGhcTc GhcPs)
HsPatSigType GhcPs
sig)
where new_loc :: SrcSpanAnnA
new_loc = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan ((GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p) SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` SrcSpan
sig_loc_no_comments)
addSigPatP SrcSpanAnnA
l LPat GhcPs
p HsPatSigType GhcPs
sig TokDcolon
anns = do
LPat GhcPs -> PV (LPat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> PV (LPat GhcPs)) -> LPat GhcPs -> PV (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
TokDcolon
anns LPat GhcPs
p HsPatSigType (NoGhcTc GhcPs)
HsPatSigType GhcPs
sig)
data ArrowParsingMode lhs rhs where
ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b
ArrowIsFunType :: ArrowParsingMode b b
exprArrowParsingMode :: ArrowParsingMode lhs (HsExpr GhcPs) -> (lhs ~ HsExpr GhcPs => r) -> r
exprArrowParsingMode :: forall lhs r.
ArrowParsingMode lhs (HsExpr GhcPs)
-> ((lhs ~ HsExpr GhcPs) => r) -> r
exprArrowParsingMode ArrowParsingMode lhs (HsExpr GhcPs)
ArrowIsViewPat (lhs ~ HsExpr GhcPs) => r
k = r
(lhs ~ HsExpr GhcPs) => r
k
exprArrowParsingMode ArrowParsingMode lhs (HsExpr GhcPs)
ArrowIsFunType (lhs ~ HsExpr GhcPs) => r
k = r
(lhs ~ HsExpr GhcPs) => r
k
withArrowParsingMode :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r) -> PV r
withArrowParsingMode :: forall b r.
DisambECP b =>
(forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r)
-> PV r
withArrowParsingMode forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r
cont = do
vpEnabled <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ViewPatternsBit
rtaEnabled <- getBit RequiredTypeArgumentsBit
if | vpEnabled -> cont ArrowIsViewPat
| rtaEnabled -> cont ArrowIsFunType
| otherwise -> cont ArrowIsViewPat
withArrowParsingMode' :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV (LocatedA b)) -> PV (LocatedA b)
withArrowParsingMode' :: forall b.
DisambECP b =>
(forall lhs.
DisambECP lhs =>
ArrowParsingMode lhs b -> PV (LocatedA b))
-> PV (LocatedA b)
withArrowParsingMode' = (forall lhs.
DisambECP lhs =>
ArrowParsingMode lhs b -> PV (GenLocated SrcSpanAnnA b))
-> PV (GenLocated SrcSpanAnnA b)
(forall lhs.
DisambECP lhs =>
ArrowParsingMode lhs (Body b GhcPs)
-> PV (GenLocated SrcSpanAnnA b))
-> PV (GenLocated SrcSpanAnnA b)
forall b r.
DisambECP b =>
(forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r)
-> PV r
withArrowParsingMode
setTelescopeBndrsNameSpace :: NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
setTelescopeBndrsNameSpace :: NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
setTelescopeBndrsNameSpace NameSpace
ns HsForAllTelescope GhcPs
forall_telescope =
case HsForAllTelescope GhcPs
forall_telescope of
HsForAllInvis XHsForAllInvis GhcPs
x [LHsTyVarBndr Specificity GhcPs]
bndrs -> XHsForAllInvis GhcPs
-> [LHsTyVarBndr Specificity GhcPs] -> HsForAllTelescope GhcPs
forall pass.
XHsForAllInvis pass
-> [LHsTyVarBndr Specificity pass] -> HsForAllTelescope pass
HsForAllInvis XHsForAllInvis GhcPs
x ([LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall flag. [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs]
set_bndrs_ns [LHsTyVarBndr Specificity GhcPs]
bndrs)
HsForAllVis XHsForAllVis GhcPs
x [LHsTyVarBndr () GhcPs]
bndrs -> XHsForAllVis GhcPs
-> [LHsTyVarBndr () GhcPs] -> HsForAllTelescope GhcPs
forall pass.
XHsForAllVis pass
-> [LHsTyVarBndr () pass] -> HsForAllTelescope pass
HsForAllVis XHsForAllVis GhcPs
x ([LHsTyVarBndr () GhcPs] -> [LHsTyVarBndr () GhcPs]
forall flag. [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs]
set_bndrs_ns [LHsTyVarBndr () GhcPs]
bndrs)
where
set_bndrs_ns :: [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs]
set_bndrs_ns :: forall flag. [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs]
set_bndrs_ns = (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs))
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (NameSpace
-> XRec GhcPs (HsTyVarBndr flag GhcPs)
-> XRec GhcPs (HsTyVarBndr flag GhcPs)
forall flag.
NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs
setLHsTyVarBndrNameSpace NameSpace
ns)
setLHsTyVarBndrNameSpace :: NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs
setLHsTyVarBndrNameSpace :: forall flag.
NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs
setLHsTyVarBndrNameSpace NameSpace
ns (L SrcSpanAnnA
l HsTyVarBndr flag GhcPs
tvb) = SrcSpanAnnA
-> HsTyVarBndr flag GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsTyVarBndr flag GhcPs
tvb'
where tvb' :: HsTyVarBndr flag GhcPs
tvb' = HsTyVarBndr flag GhcPs
tvb { tvb_var = setHsBndrVarNameSpace ns (tvb_var tvb) }
setHsBndrVarNameSpace :: NameSpace -> HsBndrVar GhcPs -> HsBndrVar GhcPs
setHsBndrVarNameSpace :: NameSpace -> HsBndrVar GhcPs -> HsBndrVar GhcPs
setHsBndrVarNameSpace NameSpace
ns (HsBndrVar XBndrVar GhcPs
x (L SrcSpanAnnN
l RdrName
rdr)) = XBndrVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsBndrVar GhcPs
forall pass. XBndrVar pass -> LIdP pass -> HsBndrVar pass
HsBndrVar XBndrVar GhcPs
x (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
rdr')
where rdr' :: RdrName
rdr' = RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
rdr NameSpace
ns
setHsBndrVarNameSpace NameSpace
_ (HsBndrWildCard XBndrWildCard GhcPs
x) = XBndrWildCard GhcPs -> HsBndrVar GhcPs
forall pass. XBndrWildCard pass -> HsBndrVar pass
HsBndrWildCard XBndrWildCard GhcPs
x
checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedLitPat (L SrcSpan
loc HsLit GhcPs
lit) =
case HsLit GhcPs
lit of
HsStringPrim {}
-> 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 SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsLit GhcPs -> PsMessage
PsErrIllegalUnboxedStringInPat HsLit GhcPs
lit)
HsLit GhcPs
_ | HsLit GhcPs -> Bool
is_floating_lit HsLit GhcPs
lit
-> 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 SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsLit GhcPs -> PsMessage
PsErrIllegalUnboxedFloatingLitInPat HsLit GhcPs
lit)
| Bool
otherwise
-> () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
is_floating_lit :: HsLit GhcPs -> Bool
is_floating_lit :: HsLit GhcPs -> Bool
is_floating_lit (HsFloatPrim {}) = Bool
True
is_floating_lit (HsDoublePrim {}) = Bool
True
is_floating_lit HsLit GhcPs
_ = Bool
False
mkPatRec ::
LocatedA (PatBuilder GhcPs) ->
HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->
(Maybe (EpToken "{"), Maybe (EpToken "}")) ->
PV (PatBuilder GhcPs)
mkPatRec :: LocatedA (PatBuilder GhcPs)
-> HsRecFields GhcPs (LocatedA (PatBuilder GhcPs))
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (PatBuilder GhcPs)
mkPatRec (LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall l e. GenLocated l e -> e
unLoc -> PatBuilderVar LocatedN RdrName
c) (HsRecFields XHsRecFields GhcPs
x [LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))]
fs Maybe (XRec GhcPs RecFieldsDotDot)
dd) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns
| RdrName -> Bool
isRdrDataCon (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
c)
= do fs <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))
-> PV
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs)))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))]
-> PV
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(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 LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))
-> PV
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (Pat GhcPs))))
checkPatField [LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(LocatedA (PatBuilder GhcPs)))]
fs
return $ PatBuilderPat $ ConPat
{ pat_con_ext = anns
, pat_con = c
, pat_args = RecCon (HsRecFields x fs dd)
}
mkPatRec LocatedA (PatBuilder GhcPs)
p HsRecFields GhcPs (LocatedA (PatBuilder GhcPs))
_ (Maybe (EpToken "{"), Maybe (EpToken "}"))
_ =
MsgEnvelope PsMessage -> PV (PatBuilder GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (PatBuilder GhcPs))
-> MsgEnvelope PsMessage -> PV (PatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (LocatedA (PatBuilder GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LocatedA (PatBuilder GhcPs)
p) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(PatBuilder GhcPs -> PsMessage
PsErrInvalidRecordCon (LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall l e. GenLocated l e -> e
unLoc LocatedA (PatBuilder GhcPs)
p))
class DisambTD b where
mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)
mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)
mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)
instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV :: LHsType GhcPs -> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkHsAppTyHeadPV = LHsType GhcPs -> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
GenLocated SrcSpanAnnA (HsType GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return
mkHsAppTyPV :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> LHsType GhcPs -> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkHsAppTyPV GenLocated SrcSpanAnnA (HsType GhcPs)
t1 LHsType GhcPs
t2 = GenLocated SrcSpanAnnA (HsType GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1 LHsType GhcPs
t2)
mkHsAppKindTyPV :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> EpToken "@"
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkHsAppKindTyPV GenLocated SrcSpanAnnA (HsType GhcPs)
t EpToken "@"
at LHsType GhcPs
ki = GenLocated SrcSpanAnnA (HsType GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy XAppKindTy GhcPs
EpToken "@"
at LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t LHsType GhcPs
ki)
mkHsOpTyPV :: PromotionFlag
-> LHsType GhcPs
-> LocatedN RdrName
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkHsOpTyPV PromotionFlag
prom LHsType GhcPs
t1 LocatedN RdrName
op LHsType GhcPs
t2 = do
let (L SrcSpanAnnA
l HsType GhcPs
ty) = PromotionFlag
-> LHsType GhcPs
-> LocatedN RdrName
-> LHsType GhcPs
-> LHsType GhcPs
mkLHsOpTy PromotionFlag
prom LHsType GhcPs
t1 LocatedN RdrName
op LHsType GhcPs
t2
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
return (L (addCommentsToEpAnn l cs) ty)
mkUnpackednessPV :: Located UnpackednessPragma
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkUnpackednessPV = Located UnpackednessPragma -> LHsType GhcPs -> PV (LHsType GhcPs)
Located UnpackednessPragma
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *).
MonadP m =>
Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP
dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
dataConBuilderCon (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
_ LocatedN RdrName
dc)) = LocatedN RdrName
dc
dataConBuilderCon (L SrcSpanAnnA
_ (InfixDataConBuilder LHsType GhcPs
_ LocatedN RdrName
dc LHsType GhcPs
_)) = LocatedN RdrName
dc
dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
dataConBuilderDetails (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds LocatedN RdrName
_))
| [L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
cs) (HsRecTy XRecTy GhcPs
an [LConDeclField GhcPs]
fields)] <- OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList (LHsType GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
flds
= GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> HsConDetails
Void
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (EpAnn (AnnList ())
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnList () -> EpAnnComments -> EpAnn (AnnList ())
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
anc XRecTy GhcPs
AnnList ()
an EpAnnComments
cs) [LConDeclField GhcPs]
[GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields)
dataConBuilderDetails (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds LocatedN RdrName
_))
= [Void]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HsConDetails
Void
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs ((GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear (OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList (LHsType GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
flds))
dataConBuilderDetails (L (EpAnn EpaLocation
_ AnnListItem
_ EpAnnComments
csl) (InfixDataConBuilder (L (EpAnn EpaLocation
anc AnnListItem
ann EpAnnComments
csll) HsType GhcPs
lhs) LocatedN RdrName
_ LHsType GhcPs
rhs))
= HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsConDetails
Void
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
anc AnnListItem
ann (EpAnnComments
csl EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csll)) HsType GhcPs
lhs)) (GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs)
instance DisambTD DataConBuilder where
mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
mkHsAppTyHeadPV = LHsType GhcPs -> PV (LocatedA DataConBuilder)
tyToDataConBuilder
mkHsAppTyPV :: LocatedA DataConBuilder
-> LHsType GhcPs -> PV (LocatedA DataConBuilder)
mkHsAppTyPV (L SrcSpanAnnA
l (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds LocatedN RdrName
fn)) LHsType GhcPs
t =
LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA DataConBuilder -> PV (LocatedA DataConBuilder))
-> LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> DataConBuilder -> LocatedA DataConBuilder
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t))
(OrdList (LHsType GhcPs) -> LocatedN RdrName -> DataConBuilder
PrefixDataConBuilder (OrdList (LHsType GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
flds OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. OrdList a -> a -> OrdList a
`snocOL` LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t) LocatedN RdrName
fn)
mkHsAppTyPV (L SrcSpanAnnA
_ InfixDataConBuilder{}) LHsType GhcPs
_ =
String -> PV (LocatedA DataConBuilder)
forall a. HasCallStack => String -> a
panic String
"mkHsAppTyPV: InfixDataConBuilder"
mkHsAppKindTyPV :: LocatedA DataConBuilder
-> EpToken "@" -> LHsType GhcPs -> PV (LocatedA DataConBuilder)
mkHsAppKindTyPV LocatedA DataConBuilder
lhs EpToken "@"
at LHsType GhcPs
ki =
MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder))
-> MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (EpToken "@" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "@"
at) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(DataConBuilder -> HsType GhcPs -> PsMessage
PsErrUnexpectedKindAppInDataCon (LocatedA DataConBuilder -> DataConBuilder
forall l e. GenLocated l e -> e
unLoc LocatedA DataConBuilder
lhs) (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ki))
mkHsOpTyPV :: PromotionFlag
-> LHsType GhcPs
-> LocatedN RdrName
-> LHsType GhcPs
-> PV (LocatedA DataConBuilder)
mkHsOpTyPV PromotionFlag
prom LHsType GhcPs
lhs LocatedN RdrName
tc LHsType GhcPs
rhs = do
HsType GhcPs -> PV ()
check_no_ops (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs)
data_con <- Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName)
forall (m :: * -> *) a.
MonadP m =>
Either (MsgEnvelope PsMessage) a -> m a
eitherToP (Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName))
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon LocatedN RdrName
tc
!cs <- getCommentsFor (locA l)
checkNotPromotedDataCon prom data_con
return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l :: SrcSpanAnnA
l = GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
combineLocsA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lhs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs
check_no_ops :: HsType GhcPs -> PV ()
check_no_ops (HsBangTy XBangTy GhcPs
_ HsBang
_ LHsType GhcPs
t) = HsType GhcPs -> PV ()
check_no_ops (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t)
check_no_ops (HsOpTy{}) =
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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsType GhcPs -> RdrName -> HsType GhcPs -> PsMessage
PsErrInvalidInfixDataCon (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lhs) (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc) (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs))
check_no_ops HsType GhcPs
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkUnpackednessPV :: Located UnpackednessPragma
-> LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
mkUnpackednessPV Located UnpackednessPragma
unpk LocatedA DataConBuilder
constr_stuff
| L SrcSpanAnnA
_ (InfixDataConBuilder LHsType GhcPs
lhs LocatedN RdrName
data_con LHsType GhcPs
rhs) <- LocatedA DataConBuilder
constr_stuff
=
do lhs' <- Located UnpackednessPragma -> LHsType GhcPs -> PV (LHsType GhcPs)
forall (m :: * -> *).
MonadP m =>
Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP Located UnpackednessPragma
unpk LHsType GhcPs
lhs
let l = GenLocated SrcSpanAnnA UnpackednessPragma
-> LocatedA DataConBuilder -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
combineLocsA (Located UnpackednessPragma
-> GenLocated SrcSpanAnnA UnpackednessPragma
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc Located UnpackednessPragma
unpk) LocatedA DataConBuilder
constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| Bool
otherwise =
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 (Located UnpackednessPragma -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located UnpackednessPragma
unpk) PsMessage
PsErrUnpackDataCon
LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA DataConBuilder
constr_stuff
tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
tyToDataConBuilder (L SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
prom XRec GhcPs (IdP GhcPs)
v)) = do
data_con <- Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName)
forall (m :: * -> *) a.
MonadP m =>
Either (MsgEnvelope PsMessage) a -> m a
eitherToP (Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName))
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
-> PV (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v
checkNotPromotedDataCon prom data_con
return $ L l (PrefixDataConBuilder nilOL data_con)
tyToDataConBuilder (L SrcSpanAnnA
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts)) = do
let data_con :: LocatedN RdrName
data_con = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
l) (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([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)))
LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA DataConBuilder -> PV (LocatedA DataConBuilder))
-> LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> DataConBuilder -> LocatedA DataConBuilder
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (OrdList (LHsType GhcPs) -> LocatedN RdrName -> DataConBuilder
PrefixDataConBuilder ([GenLocated SrcSpanAnnA (HsType GhcPs)]
-> OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. [a] -> OrdList a
toOL [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts) LocatedN RdrName
data_con)
tyToDataConBuilder (L SrcSpanAnnA
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsUnboxedTuple [LHsType GhcPs]
ts)) = do
let data_con :: LocatedN RdrName
data_con = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
l) (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([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)))
LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA DataConBuilder -> PV (LocatedA DataConBuilder))
-> LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> DataConBuilder -> LocatedA DataConBuilder
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (OrdList (LHsType GhcPs) -> LocatedN RdrName -> DataConBuilder
PrefixDataConBuilder ([GenLocated SrcSpanAnnA (HsType GhcPs)]
-> OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. [a] -> OrdList a
toOL [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts) LocatedN RdrName
data_con)
tyToDataConBuilder LHsType GhcPs
t =
MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder))
-> MsgEnvelope PsMessage -> PV (LocatedA DataConBuilder)
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. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(HsType GhcPs -> PsMessage
PsErrInvalidDataCon (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t))
checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()
checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()
checkNotPromotedDataCon PromotionFlag
NotPromoted LocatedN RdrName
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNotPromotedDataCon PromotionFlag
IsPromoted (L SrcSpanAnnN
l RdrName
name) =
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 (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
RdrName -> PsMessage
PsErrIllegalPromotionQuoteDataCon RdrName
name
mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
mkUnboxedSumCon :: LHsType GhcPs
-> Int -> Int -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
mkUnboxedSumCon LHsType GhcPs
t Int
tag Int
arity =
(RdrName -> LocatedN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Int -> Int -> DataCon
sumDataCon Int
tag Int
arity)), [Void]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HsConDetails
Void
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(GenLocated
(EpAnn (AnnList ())) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs [GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t])
checkPrecP
:: Located (SourceText,Int)
-> Located (OrdList (LocatedN RdrName))
-> P ()
checkPrecP :: Located (SourceText, Int)
-> Located (OrdList (LocatedN RdrName)) -> P ()
checkPrecP (L SrcSpan
l (SourceText
_,Int
i)) (L SrcSpan
_ OrdList (LocatedN RdrName)
ol)
| Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPrecedence = () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| (LocatedN RdrName -> Bool) -> OrdList (LocatedN RdrName) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LocatedN RdrName -> Bool
forall {l}. GenLocated l RdrName -> Bool
specialOp OrdList (LocatedN RdrName)
ol = () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = 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
l (Int -> PsMessage
PsErrPrecedenceOutOfRange Int
i)
where
specialOp :: GenLocated l RdrName -> Bool
specialOp GenLocated l RdrName
op = GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated l RdrName
op RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon
mkRecConstrOrUpdate
:: Bool
-> LHsExpr GhcPs
-> SrcSpan
-> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate :: Bool
-> LHsExpr GhcPs
-> SrcSpan
-> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate Bool
_ (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
l RdrName
c))) SrcSpan
_lrec ([Fbind (HsExpr GhcPs)]
fbinds,Maybe SrcSpan
dd) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns
| RdrName -> Bool
isRdrDataCon RdrName
c
= do
let ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fs, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ps) = [Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))],
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Fbind (HsExpr GhcPs)]
[Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))]
fbinds
case [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ps of
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
p:[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_ -> MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (HsExpr GhcPs))
-> MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
p) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrOverloadedRecordDotInvalid
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_ -> HsExpr GhcPs -> PV (HsExpr GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> HsRecordBinds GhcPs
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> HsExpr GhcPs
mkRdrRecordCon (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
c) ([LocatedA
(HsRecField GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe SrcSpan
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall arg.
[LocatedA (HsRecField GhcPs arg)]
-> Maybe SrcSpan -> HsRecFields GhcPs arg
mk_rec_fields [LocatedA
(HsRecField GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fs Maybe SrcSpan
dd) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns)
mkRecConstrOrUpdate Bool
overloaded_update LHsExpr GhcPs
exp SrcSpan
_ ([Fbind (HsExpr GhcPs)]
fs,Maybe SrcSpan
dd) (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns
| Just SrcSpan
dd_loc <- Maybe SrcSpan
dd = MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (HsExpr GhcPs))
-> MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
dd_loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrDotsInRecordUpdate
| Bool
otherwise = Bool
-> LHsExpr GhcPs
-> [Fbind (HsExpr GhcPs)]
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (HsExpr GhcPs)
mkRdrRecordUpd Bool
overloaded_update LHsExpr GhcPs
exp [Fbind (HsExpr GhcPs)]
fs (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns
mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (HsExpr GhcPs)
mkRdrRecordUpd :: Bool
-> LHsExpr GhcPs
-> [Fbind (HsExpr GhcPs)]
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> PV (HsExpr GhcPs)
mkRdrRecordUpd Bool
overloaded_on exp :: LHsExpr GhcPs
exp@(L SrcSpanAnnA
loc HsExpr GhcPs
_) [Fbind (HsExpr GhcPs)]
fbinds (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns = do
let ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fs, [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ps) = [Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))],
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Fbind (HsExpr GhcPs)]
[Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))]
fbinds
fs' :: [LHsRecUpdField GhcPs GhcPs]
fs' :: [LHsRecUpdField GhcPs GhcPs]
fs' = (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map ((HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsRecField GhcPs (LHsExpr GhcPs)
-> HsRecField GhcPs (LHsExpr GhcPs)
HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
mk_rec_upd_field) [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fs
case Bool
overloaded_on of
Bool
False | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ps ->
MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (HsExpr GhcPs))
-> MsgEnvelope PsMessage -> PV (HsExpr 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) PsMessage
PsErrOverloadedRecordUpdateNotEnabled
Bool
False ->
HsExpr GhcPs -> PV (HsExpr GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return RecordUpd {
rupd_ext :: XRecordUpd GhcPs
rupd_ext = (Maybe (EpToken "{"), Maybe (EpToken "}"))
XRecordUpd GhcPs
anns
, rupd_expr :: LHsExpr GhcPs
rupd_expr = LHsExpr GhcPs
exp
, rupd_flds :: LHsRecUpdFields GhcPs
rupd_flds =
RegularRecUpdFields
{ xRecUpdFields :: XLHsRecUpdLabels GhcPs
xRecUpdFields = XLHsRecUpdLabels GhcPs
NoExtField
noExtField
, recUpdFields :: [LHsRecUpdField GhcPs GhcPs]
recUpdFields = [LHsRecUpdField GhcPs GhcPs]
fs' } }
Bool
True -> do
let qualifiedFields :: [GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
qualifiedFields =
[ SrcSpanAnnA
-> FieldOcc GhcPs -> GenLocated SrcSpanAnnA (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l FieldOcc GhcPs
lbl | L SrcSpanAnnA
_ (HsFieldBind XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
_ (L SrcSpanAnnA
l FieldOcc GhcPs
lbl) GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ Bool
_) <- [LHsRecUpdField GhcPs GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fs'
, RdrName -> Bool
isQual (RdrName -> Bool)
-> (FieldOcc GhcPs -> RdrName) -> FieldOcc GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcPs -> RdrName
forall (p :: Pass). IsPass p => FieldOcc (GhcPass p) -> RdrName
fieldOccRdrName (FieldOcc GhcPs -> Bool) -> FieldOcc GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs
lbl
]
case [GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
qualifiedFields of
GenLocated SrcSpanAnnA (FieldOcc GhcPs)
qf:[GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
_ -> MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (HsExpr GhcPs))
-> MsgEnvelope PsMessage -> PV (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated SrcSpanAnnA (FieldOcc GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (FieldOcc GhcPs)
qf) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
PsMessage
PsErrOverloadedRecordUpdateNoQualifiedFields
[GenLocated SrcSpanAnnA (FieldOcc GhcPs)]
_ -> HsExpr GhcPs -> PV (HsExpr GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> PV (HsExpr GhcPs))
-> HsExpr GhcPs -> PV (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
RecordUpd
{ rupd_ext :: XRecordUpd GhcPs
rupd_ext = (Maybe (EpToken "{"), Maybe (EpToken "}"))
XRecordUpd GhcPs
anns
, rupd_expr :: LHsExpr GhcPs
rupd_expr = LHsExpr GhcPs
exp
, rupd_flds :: LHsRecUpdFields GhcPs
rupd_flds =
OverloadedRecUpdFields
{ xOLRecUpdFields :: XLHsOLRecUpdLabels GhcPs
xOLRecUpdFields = XLHsOLRecUpdLabels GhcPs
NoExtField
noExtField
, olRecUpdFields :: [LHsRecProj GhcPs (LHsExpr GhcPs)]
olRecUpdFields = [Fbind (HsExpr GhcPs)] -> [LHsRecProj GhcPs (LHsExpr GhcPs)]
toProjUpdates [Fbind (HsExpr GhcPs)]
fbinds } }
where
toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]
toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecProj GhcPs (LHsExpr GhcPs)]
toProjUpdates = (Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [Either
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))))]
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (\case { Right GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
p -> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
p; Left GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
f -> LHsRecUpdField GhcPs GhcPs -> LHsRecProj GhcPs (LHsExpr GhcPs)
recFieldToProjUpdate LHsRecUpdField GhcPs GhcPs
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
f })
recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs
recFieldToProjUpdate :: LHsRecUpdField GhcPs GhcPs -> LHsRecProj GhcPs (LHsExpr GhcPs)
recFieldToProjUpdate (L SrcSpanAnnA
l (HsFieldBind XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
anns (L SrcSpanAnnA
_ (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpanAnnN
loc RdrName
rdr))) GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
pun)) =
let f :: FastString
f = OccName -> FastString
occNameFS (OccName -> FastString)
-> (RdrName -> OccName) -> RdrName -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> FastString) -> RdrName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName
rdr
fl :: DotFieldOcc GhcPs
fl = XCDotFieldOcc GhcPs
-> XRec GhcPs FieldLabelString -> DotFieldOcc GhcPs
forall p.
XCDotFieldOcc p -> XRec p FieldLabelString -> DotFieldOcc p
DotFieldOcc XCDotFieldOcc GhcPs
AnnFieldLabel
forall a. NoAnn a => a
noAnn (SrcSpanAnnN
-> FieldLabelString -> GenLocated SrcSpanAnnN FieldLabelString
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (FastString -> FieldLabelString
FieldLabelString FastString
f))
lf :: SrcSpan
lf = SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc
in SrcSpanAnnA
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LHsExpr GhcPs
-> Bool
-> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate SrcSpanAnnA
l (SrcSpan
-> [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
lf [EpAnnCO
-> DotFieldOcc GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> EpAnnCO
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) DotFieldOcc GhcPs
fl]) (FastString -> LHsExpr GhcPs
punnedVar FastString
f) Bool
pun Maybe (EpToken "=")
XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
anns
where
punnedVar :: FastString -> LHsExpr GhcPs
punnedVar :: FastString -> LHsExpr GhcPs
punnedVar FastString
f = if Bool -> Bool
not Bool
pun then LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg else HsExpr GhcPs -> LHsExpr GhcPs
HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcPs -> LHsExpr GhcPs)
-> (FastString -> HsExpr GhcPs) -> FastString -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcPs -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (LocatedN RdrName -> HsExpr GhcPs)
-> (FastString -> LocatedN RdrName) -> FastString -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> LocatedN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (RdrName -> LocatedN RdrName)
-> (FastString -> RdrName) -> FastString -> LocatedN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual (OccName -> RdrName)
-> (FastString -> OccName) -> FastString -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> OccName
mkVarOccFS (FastString -> LHsExpr GhcPs) -> FastString -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ FastString
f
mkRdrRecordCon
:: LocatedN RdrName -> HsRecordBinds GhcPs -> (Maybe (EpToken "{"), Maybe (EpToken "}")) -> HsExpr GhcPs
mkRdrRecordCon :: LocatedN RdrName
-> HsRecordBinds GhcPs
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> HsExpr GhcPs
mkRdrRecordCon LocatedN RdrName
con HsRecordBinds GhcPs
flds (Maybe (EpToken "{"), Maybe (EpToken "}"))
anns
= RecordCon { rcon_ext :: XRecordCon GhcPs
rcon_ext = (Maybe (EpToken "{"), Maybe (EpToken "}"))
XRecordCon GhcPs
anns, rcon_con :: XRec GhcPs (ConLikeP GhcPs)
rcon_con = XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
con, rcon_flds :: HsRecordBinds GhcPs
rcon_flds = HsRecordBinds GhcPs
flds }
mk_rec_fields :: [LocatedA (HsRecField GhcPs arg)] -> Maybe SrcSpan -> HsRecFields GhcPs arg
mk_rec_fields :: forall arg.
[LocatedA (HsRecField GhcPs arg)]
-> Maybe SrcSpan -> HsRecFields GhcPs arg
mk_rec_fields [LocatedA (HsRecField GhcPs arg)]
fs Maybe SrcSpan
Nothing = HsRecFields { rec_ext :: XHsRecFields GhcPs
rec_ext = NoExtField
XHsRecFields GhcPs
noExtField, rec_flds :: [LHsRecField GhcPs arg]
rec_flds = [LHsRecField GhcPs arg]
[LocatedA (HsRecField GhcPs arg)]
fs, rec_dotdot :: Maybe (XRec GhcPs RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (LocatedE RecFieldsDotDot)
forall a. Maybe a
Nothing }
mk_rec_fields [LocatedA (HsRecField GhcPs arg)]
fs (Just SrcSpan
s) = HsRecFields { rec_ext :: XHsRecFields GhcPs
rec_ext = NoExtField
XHsRecFields GhcPs
noExtField, rec_flds :: [LHsRecField GhcPs arg]
rec_flds = [LHsRecField GhcPs arg]
[LocatedA (HsRecField GhcPs arg)]
fs
, rec_dotdot :: Maybe (XRec GhcPs RecFieldsDotDot)
rec_dotdot = LocatedE RecFieldsDotDot -> Maybe (LocatedE RecFieldsDotDot)
forall a. a -> Maybe a
Just (EpaLocation -> RecFieldsDotDot -> LocatedE RecFieldsDotDot
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
s) (Int -> RecFieldsDotDot
RecFieldsDotDot (Int -> RecFieldsDotDot) -> Int -> RecFieldsDotDot
forall a b. (a -> b) -> a -> b
$ [LocatedA
(HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs)) arg)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LocatedA (HsRecField GhcPs arg)]
[LocatedA
(HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs)) arg)]
fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs)
-> HsRecField GhcPs (LHsExpr GhcPs)
mk_rec_upd_field (HsFieldBind XHsFieldBind (LFieldOcc GhcPs)
noAnn (L SrcSpanAnnA
loc (FieldOcc XCFieldOcc GhcPs
_ XRec GhcPs (IdP GhcPs)
rdr)) LHsExpr GhcPs
arg Bool
pun)
= XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
-> GenLocated SrcSpanAnnA (FieldOcc GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall lhs rhs.
XHsFieldBind lhs -> lhs -> rhs -> Bool -> HsFieldBind lhs rhs
HsFieldBind XHsFieldBind (LFieldOcc GhcPs)
XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
noAnn (SrcSpanAnnA
-> FieldOcc GhcPs -> GenLocated SrcSpanAnnA (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XCFieldOcc GhcPs -> XRec GhcPs (IdP GhcPs) -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc XCFieldOcc GhcPs
NoExtField
noExtField XRec GhcPs (IdP GhcPs)
rdr)) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
pun
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
mkInlinePragma :: SourceText
-> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
mkInlinePragma SourceText
src (InlineSpec
inl, RuleMatchInfo
match_info) Maybe Activation
mb_act
= InlinePragma { inl_src :: SourceText
inl_src = SourceText
src
, inl_inline :: InlineSpec
inl_inline = InlineSpec
inl
, inl_sat :: Maybe Int
inl_sat = Maybe Int
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
act
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
match_info }
where
act :: Activation
act = case Maybe Activation
mb_act of
Just Activation
act -> Activation
act
Maybe Activation
Nothing ->
case InlineSpec
inl of
NoInline SourceText
_ -> Activation
NeverActive
Opaque SourceText
_ -> Activation
NeverActive
InlineSpec
_other -> Activation
AlwaysActive
mkOpaquePragma :: SourceText -> InlinePragma
mkOpaquePragma :: SourceText -> InlinePragma
mkOpaquePragma SourceText
src
= InlinePragma { inl_src :: SourceText
inl_src = SourceText
src
, inl_inline :: InlineSpec
inl_inline = SourceText -> InlineSpec
Opaque SourceText
src
, inl_sat :: Maybe Int
inl_sat = Maybe Int
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
NeverActive
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
FunLike
}
checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs))
checkNewOrData :: SrcSpan
-> RdrName
-> Bool
-> NewOrData
-> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs))
checkNewOrData SrcSpan
span RdrName
name Bool
is_type_data = ((NewOrData, [LConDecl GhcPs])
-> P (DataDefnCons (LConDecl GhcPs)))
-> NewOrData
-> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs))
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((NewOrData, [LConDecl GhcPs])
-> P (DataDefnCons (LConDecl GhcPs)))
-> NewOrData
-> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs)))
-> ((NewOrData, [LConDecl GhcPs])
-> P (DataDefnCons (LConDecl GhcPs)))
-> NewOrData
-> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ \ case
(NewOrData
NewType, [LConDecl GhcPs
a]) -> DataDefnCons (LConDecl GhcPs) -> P (DataDefnCons (LConDecl GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataDefnCons (LConDecl GhcPs)
-> P (DataDefnCons (LConDecl GhcPs)))
-> DataDefnCons (LConDecl GhcPs)
-> P (DataDefnCons (LConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ LConDecl GhcPs -> DataDefnCons (LConDecl GhcPs)
forall a. a -> DataDefnCons a
NewTypeCon LConDecl GhcPs
a
(NewOrData
DataType, [LConDecl GhcPs]
as) -> DataDefnCons (LConDecl GhcPs) -> P (DataDefnCons (LConDecl GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataDefnCons (LConDecl GhcPs)
-> P (DataDefnCons (LConDecl GhcPs)))
-> DataDefnCons (LConDecl GhcPs)
-> P (DataDefnCons (LConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ Bool -> [LConDecl GhcPs] -> DataDefnCons (LConDecl GhcPs)
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
is_type_data ([GenLocated SrcSpanAnnA (ConDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
handle_type_data [LConDecl GhcPs]
[GenLocated SrcSpanAnnA (ConDecl GhcPs)]
as)
(NewOrData
NewType, [LConDecl GhcPs]
as) -> MsgEnvelope PsMessage -> P (DataDefnCons (LConDecl GhcPs))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (DataDefnCons (LConDecl GhcPs)))
-> MsgEnvelope PsMessage -> P (DataDefnCons (LConDecl GhcPs))
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
$ RdrName -> Int -> PsMessage
PsErrMultipleConForNewtype RdrName
name ([GenLocated SrcSpanAnnA (ConDecl GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LConDecl GhcPs]
[GenLocated SrcSpanAnnA (ConDecl GhcPs)]
as)
where
handle_type_data :: [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
handle_type_data
| Bool
is_type_data = (GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ((ConDecl GhcPs -> ConDecl GhcPs)
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConDecl GhcPs -> ConDecl GhcPs
forall {pass} {f :: * -> *}.
(XRec pass (IdP pass) ~ f RdrName, Functor f) =>
ConDecl pass -> ConDecl pass
promote_constructor)
| Bool
otherwise = [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
forall a. a -> a
id
promote_constructor :: ConDecl pass -> ConDecl pass
promote_constructor (dc :: ConDecl pass
dc@ConDeclGADT { con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (XRec pass (IdP pass))
cons })
= ConDecl pass
dc { con_names = fmap (fmap promote_name) cons }
promote_constructor (dc :: ConDecl pass
dc@ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = XRec pass (IdP pass)
con })
= ConDecl pass
dc { con_name = fmap promote_name con }
promote_constructor ConDecl pass
dc = ConDecl pass
dc
promote_name :: RdrName -> RdrName
promote_name RdrName
name = RdrName -> Maybe RdrName -> RdrName
forall a. a -> Maybe a -> a
fromMaybe RdrName
name (RdrName -> Maybe RdrName
promoteRdrName RdrName
name)
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> (EpToken "import", TokDcolon)
-> P (EpToken "foreign" -> HsDecl GhcPs)
mkImport :: GenLocated SrcSpan CCallConv
-> GenLocated SrcSpan Safety
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> (EpToken "import", TokDcolon)
-> P (EpToken "foreign" -> HsDecl GhcPs)
mkImport GenLocated SrcSpan CCallConv
cconv GenLocated SrcSpan Safety
safety (L SrcSpan
loc (StringLiteral SourceText
esrc FastString
entity Maybe NoCommentsLocation
_), LocatedN RdrName
v, LHsSigType GhcPs
ty) (EpToken "import"
timport, TokDcolon
td) =
case GenLocated SrcSpan CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan CCallConv
cconv of
CCallConv
CCallConv -> ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs)
returnSpec (ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs))
-> P (ForeignImport GhcPs) -> P (EpToken "foreign" -> HsDecl GhcPs)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< P (ForeignImport GhcPs)
mkCImport
CCallConv
CApiConv -> do
imp <- P (ForeignImport GhcPs)
mkCImport
if isCWrapperImport imp
then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
else returnSpec imp
CCallConv
StdCallConv -> ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs)
returnSpec (ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs))
-> P (ForeignImport GhcPs) -> P (EpToken "foreign" -> HsDecl GhcPs)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< P (ForeignImport GhcPs)
mkCImport
CCallConv
PrimCallConv -> P (EpToken "foreign" -> HsDecl GhcPs)
mkOtherImport
CCallConv
JavaScriptCallConv -> P (EpToken "foreign" -> HsDecl GhcPs)
mkOtherImport
where
mkCImport :: P (ForeignImport GhcPs)
mkCImport = do
let e :: String
e = FastString -> String
unpackFS FastString
entity
case LocatedE CCallConv
-> LocatedE Safety
-> FastString
-> String
-> Located SourceText
-> Maybe (ForeignImport GhcPs)
forall (p :: Pass).
LocatedE CCallConv
-> LocatedE Safety
-> FastString
-> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport (GenLocated SrcSpan CCallConv -> LocatedE CCallConv
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan CCallConv
cconv) (GenLocated SrcSpan Safety -> LocatedE Safety
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan Safety
safety) (RdrName -> FastString
mkExtName (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
v)) String
e (SrcSpan -> SourceText -> Located SourceText
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc SourceText
esrc) of
Maybe (ForeignImport GhcPs)
Nothing -> MsgEnvelope PsMessage -> P (ForeignImport GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (ForeignImport GhcPs))
-> MsgEnvelope PsMessage -> P (ForeignImport 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
$
PsMessage
PsErrMalformedEntityString
Just ForeignImport GhcPs
importSpec -> ForeignImport GhcPs -> P (ForeignImport GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignImport GhcPs
importSpec
isCWrapperImport :: ForeignImport pass -> Bool
isCWrapperImport (CImport XCImport pass
_ XRec pass CCallConv
_ XRec pass Safety
_ Maybe Header
_ CImportSpec
CWrapper) = Bool
True
isCWrapperImport ForeignImport pass
_ = Bool
False
mkOtherImport :: P (EpToken "foreign" -> HsDecl GhcPs)
mkOtherImport = ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs)
returnSpec ForeignImport GhcPs
importSpec
where
entity' :: FastString
entity' = if FastString -> Bool
nullFS FastString
entity
then RdrName -> FastString
mkExtName (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
v)
else FastString
entity
funcTarget :: CImportSpec
funcTarget = CCallTarget -> CImportSpec
CFunction (SourceText -> FastString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
esrc FastString
entity' Maybe Unit
forall a. Maybe a
Nothing Bool
True)
importSpec :: ForeignImport GhcPs
importSpec = XCImport GhcPs
-> XRec GhcPs CCallConv
-> XRec GhcPs Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcPs
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport (EpaLocation -> SourceText -> GenLocated EpaLocation SourceText
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
loc) SourceText
esrc) (GenLocated SrcSpan CCallConv -> LocatedE CCallConv
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan CCallConv
cconv) (GenLocated SrcSpan Safety -> LocatedE Safety
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan Safety
safety) Maybe Header
forall a. Maybe a
Nothing CImportSpec
funcTarget
returnSpec :: ForeignImport GhcPs -> P (EpToken "foreign" -> HsDecl GhcPs)
returnSpec ForeignImport GhcPs
spec = (EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs))
-> (EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ \EpToken "foreign"
tforeign -> XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD XForD GhcPs
NoExtField
noExtField (ForeignDecl GhcPs -> HsDecl GhcPs)
-> ForeignDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ForeignImport
{ fd_i_ext :: XForeignImport GhcPs
fd_i_ext = (EpToken "foreign"
tforeign, EpToken "import"
timport, TokDcolon
td)
, fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v
, fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsSigType GhcPs
ty
, fd_fi :: ForeignImport GhcPs
fd_fi = ForeignImport GhcPs
spec
}
parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport :: forall (p :: Pass).
LocatedE CCallConv
-> LocatedE Safety
-> FastString
-> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport LocatedE CCallConv
cconv LocatedE Safety
safety FastString
nm String
str Located SourceText
sourceText =
[ForeignImport (GhcPass p)] -> Maybe (ForeignImport (GhcPass p))
forall a. [a] -> Maybe a
listToMaybe ([ForeignImport (GhcPass p)] -> Maybe (ForeignImport (GhcPass p)))
-> [ForeignImport (GhcPass p)] -> Maybe (ForeignImport (GhcPass p))
forall a b. (a -> b) -> a -> b
$ ((ForeignImport (GhcPass p), String) -> ForeignImport (GhcPass p))
-> [(ForeignImport (GhcPass p), String)]
-> [ForeignImport (GhcPass p)]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignImport (GhcPass p), String) -> ForeignImport (GhcPass p)
forall a b. (a, b) -> a
fst ([(ForeignImport (GhcPass p), String)]
-> [ForeignImport (GhcPass p)])
-> [(ForeignImport (GhcPass p), String)]
-> [ForeignImport (GhcPass p)]
forall a b. (a -> b) -> a -> b
$ ((ForeignImport (GhcPass p), String) -> Bool)
-> [(ForeignImport (GhcPass p), String)]
-> [(ForeignImport (GhcPass p), String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null(String -> Bool)
-> ((ForeignImport (GhcPass p), String) -> String)
-> (ForeignImport (GhcPass p), String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ForeignImport (GhcPass p), String) -> String
forall a b. (a, b) -> b
snd) ([(ForeignImport (GhcPass p), String)]
-> [(ForeignImport (GhcPass p), String)])
-> [(ForeignImport (GhcPass p), String)]
-> [(ForeignImport (GhcPass p), String)]
forall a b. (a -> b) -> a -> b
$
ReadP (ForeignImport (GhcPass p))
-> ReadS (ForeignImport (GhcPass p))
forall a. ReadP a -> ReadS a
readP_to_S ReadP (ForeignImport (GhcPass p))
parse String
str
where
parse :: ReadP (ForeignImport (GhcPass p))
parse = do
ReadP ()
skipSpaces
r <- [ReadP (ForeignImport (GhcPass p))]
-> ReadP (ForeignImport (GhcPass p))
forall a. [ReadP a] -> ReadP a
choice [
String -> ReadP String
string String
"dynamic" ReadP String
-> ReadP (ForeignImport (GhcPass p))
-> ReadP (ForeignImport (GhcPass p))
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport (GhcPass p) -> ReadP (ForeignImport (GhcPass p))
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport (GhcPass p)
mk Maybe Header
forall a. Maybe a
Nothing (CCallTarget -> CImportSpec
CFunction CCallTarget
DynamicTarget)),
String -> ReadP String
string String
"wrapper" ReadP String
-> ReadP (ForeignImport (GhcPass p))
-> ReadP (ForeignImport (GhcPass p))
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport (GhcPass p) -> ReadP (ForeignImport (GhcPass p))
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport (GhcPass p)
mk Maybe Header
forall a. Maybe a
Nothing CImportSpec
CWrapper),
do ReadP () -> ReadP ()
forall a. ReadP a -> ReadP ()
optional (String -> ReadP ()
token String
"static" ReadP () -> ReadP () -> ReadP ()
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces)
((Maybe Header -> CImportSpec -> ForeignImport (GhcPass p)
mk Maybe Header
forall a. Maybe a
Nothing (CImportSpec -> ForeignImport (GhcPass p))
-> ReadP CImportSpec -> ReadP (ForeignImport (GhcPass p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP CImportSpec
cimp FastString
nm) ReadP (ForeignImport (GhcPass p))
-> ReadP (ForeignImport (GhcPass p))
-> ReadP (ForeignImport (GhcPass p))
forall a. ReadP a -> ReadP a -> ReadP a
+++
(do h <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
hdr_char
skipSpaces
let src = String -> FastString
mkFastString String
h
mk (Just (Header (SourceText src) src))
<$> cimp nm))
]
skipSpaces
return r
token :: String -> ReadP ()
token String
str = do _ <- String -> ReadP String
string String
str
toks <- look
case toks of
Char
c : String
_
| Char -> Bool
id_char Char
c -> ReadP ()
forall a. ReadP a
pfail
String
_ -> () -> ReadP ()
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mk :: Maybe Header -> CImportSpec -> ForeignImport (GhcPass p)
mk Maybe Header
h CImportSpec
n = XCImport (GhcPass p)
-> XRec (GhcPass p) CCallConv
-> XRec (GhcPass p) Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport (GhcPass p)
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport (Located SourceText -> GenLocated EpaLocation SourceText
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc Located SourceText
sourceText) (LocatedE CCallConv -> LocatedE CCallConv
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc LocatedE CCallConv
cconv) (LocatedE Safety -> LocatedE Safety
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc LocatedE Safety
safety) Maybe Header
h CImportSpec
n
hdr_char :: Char -> Bool
hdr_char Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
id_first_char :: Char -> Bool
id_first_char Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
id_char :: Char -> Bool
id_char Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
cimp :: FastString -> ReadP CImportSpec
cimp FastString
nm = (Char -> ReadP Char
ReadP.char Char
'&' ReadP Char -> ReadP () -> ReadP ()
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces ReadP () -> ReadP CImportSpec -> ReadP CImportSpec
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FastString -> CImportSpec
CLabel (FastString -> CImportSpec)
-> ReadP FastString -> ReadP CImportSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP FastString
cid)
ReadP CImportSpec -> ReadP CImportSpec -> ReadP CImportSpec
forall a. ReadP a -> ReadP a -> ReadP a
+++ (do isFun <- case LocatedE CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc LocatedE CCallConv
cconv of
CCallConv
CApiConv ->
Bool -> ReadP Bool -> ReadP Bool
forall a. a -> ReadP a -> ReadP a
option Bool
True
(do String -> ReadP ()
token String
"value"
ReadP ()
skipSpaces
Bool -> ReadP Bool
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
CCallConv
_ -> Bool -> ReadP Bool
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
cid' <- cid
return (CFunction (StaticTarget NoSourceText cid'
Nothing isFun)))
where
cid :: ReadP FastString
cid = FastString -> ReadP FastString
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
nm ReadP FastString -> ReadP FastString -> ReadP FastString
forall a. ReadP a -> ReadP a -> ReadP a
+++
(do c <- (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
id_first_char
cs <- many (satisfy id_char)
return (mkFastString (c:cs)))
mkExport :: Located CCallConv
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> ( EpToken "export", TokDcolon)
-> P (EpToken "foreign" -> HsDecl GhcPs)
mkExport :: GenLocated SrcSpan CCallConv
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> (EpToken "export", TokDcolon)
-> P (EpToken "foreign" -> HsDecl GhcPs)
mkExport (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
le (StringLiteral SourceText
esrc FastString
entity Maybe NoCommentsLocation
_), LocatedN RdrName
v, LHsSigType GhcPs
ty) (EpToken "export"
texport, TokDcolon
td)
= (EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs))
-> (EpToken "foreign" -> HsDecl GhcPs)
-> P (EpToken "foreign" -> HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ \EpToken "foreign"
tforeign -> XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD XForD GhcPs
NoExtField
noExtField (ForeignDecl GhcPs -> HsDecl GhcPs)
-> ForeignDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
ForeignExport { fd_e_ext :: XForeignExport GhcPs
fd_e_ext = (EpToken "foreign"
tforeign, EpToken "export"
texport, TokDcolon
td), fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v, fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsSigType GhcPs
ty
, fd_fe :: ForeignExport GhcPs
fd_fe = XCExport GhcPs -> XRec GhcPs CExportSpec -> ForeignExport GhcPs
forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport (EpaLocation -> SourceText -> GenLocated EpaLocation SourceText
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
le) SourceText
esrc) (EpaLocation -> CExportSpec -> GenLocated EpaLocation CExportSpec
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
lc) (SourceText -> FastString -> CCallConv -> CExportSpec
CExportStatic SourceText
esrc FastString
entity' CCallConv
cconv)) }
where
entity' :: FastString
entity' | FastString -> Bool
nullFS FastString
entity = RdrName -> FastString
mkExtName (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
v)
| Bool
otherwise = FastString
entity
mkExtName :: RdrName -> CLabelString
mkExtName :: RdrName -> FastString
mkExtName RdrName
rdrNm = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
rdrNm)
data ImpExpSubSpec = ImpExpAbs
| ImpExpAll (EpToken "..")
| ImpExpList [LocatedA ImpExpQcSpec]
| ImpExpAllWith [LocatedA ImpExpQcSpec]
data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
| ImpExpQcType (EpToken "type") (LocatedN RdrName)
| ImpExpQcWildcard (EpToken "..") (EpToken ",")
mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec
-> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp :: Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleImpExp Maybe (LWarningTxt GhcPs)
warning (EpToken "("
top, EpToken ")"
tcp) (L SrcSpanAnnA
l ImpExpQcSpec
specname) ImpExpSubSpec
subs = do
case ImpExpSubSpec
subs of
ImpExpSubSpec
ImpExpAbs
| NameSpace -> Bool
isVarNameSpace (RdrName -> NameSpace
rdrNameSpace RdrName
name)
-> IE GhcPs -> P (IE GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (IE GhcPs -> P (IE GhcPs)) -> IE GhcPs -> P (IE GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEVar GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEVar pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEVar Maybe (LWarningTxt GhcPs)
XIEVar GhcPs
warning
(SrcSpanAnnA
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (ImpExpQcSpec -> IEWrappedName GhcPs
ieNameFromSpec ImpExpQcSpec
specname)) Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing
| Bool
otherwise -> XIEThingAbs GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEThingAbs pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEThingAbs Maybe (LWarningTxt GhcPs)
XIEThingAbs GhcPs
warning (GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> (IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs))
-> IEWrappedName GhcPs
-> Maybe (LHsDoc GhcPs)
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (IEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (IEWrappedName GhcPs) -> P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName GhcPs)
nameT P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (Maybe (LHsDoc GhcPs)) -> P (IE GhcPs)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (LHsDoc GhcPs) -> P (Maybe (LHsDoc GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsDoc GhcPs)
noExportDoc
ImpExpAll EpToken ".."
tok -> XIEThingAll GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEThingAll pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEThingAll (Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
warning, (EpToken "("
top, EpToken ".."
tok, EpToken ")"
tcp)) (GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> (IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs))
-> IEWrappedName GhcPs
-> Maybe (LHsDoc GhcPs)
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (IEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (IEWrappedName GhcPs) -> P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName GhcPs)
nameT P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (Maybe (LHsDoc GhcPs)) -> P (IE GhcPs)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (LHsDoc GhcPs) -> P (Maybe (LHsDoc GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsDoc GhcPs)
noExportDoc
ImpExpList [LocatedA ImpExpQcSpec]
xs ->
(\IEWrappedName GhcPs
newName -> XIEThingWith GhcPs
-> LIEWrappedName GhcPs
-> IEWildcard
-> [LIEWrappedName GhcPs]
-> Maybe (LHsDoc GhcPs)
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName pass
-> IEWildcard
-> [LIEWrappedName pass]
-> Maybe (ExportDoc pass)
-> IE pass
IEThingWith (Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
warning, (EpToken "("
top,EpToken ".."
forall (tok :: Symbol). EpToken tok
NoEpTok,EpToken ","
forall (tok :: Symbol). EpToken tok
NoEpTok,EpToken ")"
tcp)) (SrcSpanAnnA
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l IEWrappedName GhcPs
newName)
IEWildcard
NoIEWildcard ([LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
wrapped [LocatedA ImpExpQcSpec]
xs)) (IEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (IEWrappedName GhcPs) -> P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName GhcPs)
nameT P (Maybe (LHsDoc GhcPs) -> IE GhcPs)
-> P (Maybe (LHsDoc GhcPs)) -> P (IE GhcPs)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (LHsDoc GhcPs) -> P (Maybe (LHsDoc GhcPs))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsDoc GhcPs)
noExportDoc
ImpExpAllWith [LocatedA ImpExpQcSpec]
xs ->
do allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
PatternSynonymsBit
if allowed
then
let withs = (LocatedA ImpExpQcSpec -> ImpExpQcSpec)
-> [LocatedA ImpExpQcSpec] -> [ImpExpQcSpec]
forall a b. (a -> b) -> [a] -> [b]
map LocatedA ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc [LocatedA ImpExpQcSpec]
xs
pos = IEWildcard -> (Int -> IEWildcard) -> Maybe Int -> IEWildcard
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IEWildcard
NoIEWildcard Int -> IEWildcard
IEWildcard
((ImpExpQcSpec -> Bool) -> [ImpExpQcSpec] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ImpExpQcSpec -> Bool
isImpExpQcWildcard [ImpExpQcSpec]
withs)
(td,tc) = case find isImpExpQcWildcard withs of
Just (ImpExpQcWildcard EpToken ".."
td EpToken ","
tc) -> (EpToken ".."
td,EpToken ","
tc)
Maybe ImpExpQcSpec
_ -> (EpToken ".."
forall (tok :: Symbol). EpToken tok
NoEpTok, EpToken ","
forall (tok :: Symbol). EpToken tok
NoEpTok)
ies :: [LocatedA (IEWrappedName GhcPs)]
ies = [LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
wrapped ([LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)])
-> [LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
forall a b. (a -> b) -> a -> b
$ (LocatedA ImpExpQcSpec -> Bool)
-> [LocatedA ImpExpQcSpec] -> [LocatedA ImpExpQcSpec]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (LocatedA ImpExpQcSpec -> Bool) -> LocatedA ImpExpQcSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcSpec -> Bool)
-> (LocatedA ImpExpQcSpec -> ImpExpQcSpec)
-> LocatedA ImpExpQcSpec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc) [LocatedA ImpExpQcSpec]
xs
in (\IEWrappedName GhcPs
newName
-> XIEThingWith GhcPs
-> LIEWrappedName GhcPs
-> IEWildcard
-> [LIEWrappedName GhcPs]
-> Maybe (LHsDoc GhcPs)
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName pass
-> IEWildcard
-> [LIEWrappedName pass]
-> Maybe (ExportDoc pass)
-> IE pass
IEThingWith (Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
warning, (EpToken "("
top,EpToken ".."
td,EpToken ","
tc,EpToken ")"
tcp)) (SrcSpanAnnA
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l IEWrappedName GhcPs
newName) IEWildcard
pos [LIEWrappedName GhcPs]
[GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
ies)
<$> nameT <*> pure noExportDoc
else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
PsErrIllegalPatSynExport
where
noExportDoc :: Maybe (LHsDoc GhcPs)
noExportDoc :: Maybe (LHsDoc GhcPs)
noExportDoc = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing
name :: RdrName
name = ImpExpQcSpec -> RdrName
ieNameVal ImpExpQcSpec
specname
nameT :: P (IEWrappedName GhcPs)
nameT =
if NameSpace -> Bool
isVarNameSpace (RdrName -> NameSpace
rdrNameSpace RdrName
name)
then MsgEnvelope PsMessage -> P (IEWrappedName GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (IEWrappedName GhcPs))
-> MsgEnvelope PsMessage -> P (IEWrappedName 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
(RdrName -> PsMessage
PsErrVarForTyCon RdrName
name)
else IEWrappedName GhcPs -> P (IEWrappedName GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (IEWrappedName GhcPs -> P (IEWrappedName GhcPs))
-> IEWrappedName GhcPs -> P (IEWrappedName GhcPs)
forall a b. (a -> b) -> a -> b
$ ImpExpQcSpec -> IEWrappedName GhcPs
ieNameFromSpec ImpExpQcSpec
specname
ieNameVal :: ImpExpQcSpec -> RdrName
ieNameVal (ImpExpQcName LocatedN RdrName
ln) = LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
ln
ieNameVal (ImpExpQcType EpToken "type"
_ LocatedN RdrName
ln) = LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
ln
ieNameVal ImpExpQcWildcard{} = String -> RdrName
forall a. HasCallStack => String -> a
panic String
"ieNameVal got wildcard"
ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs
ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs
ieNameFromSpec (ImpExpQcName (L SrcSpanAnnN
l RdrName
n)) = XIEName GhcPs -> XRec GhcPs (IdP GhcPs) -> IEWrappedName GhcPs
forall p. XIEName p -> LIdP p -> IEWrappedName p
IEName XIEName GhcPs
NoExtField
noExtField (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
n)
ieNameFromSpec (ImpExpQcType EpToken "type"
r (L SrcSpanAnnN
l RdrName
n)) = XIEType GhcPs -> XRec GhcPs (IdP GhcPs) -> IEWrappedName GhcPs
forall p. XIEType p -> LIdP p -> IEWrappedName p
IEType XIEType GhcPs
EpToken "type"
r (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
n)
ieNameFromSpec ImpExpQcWildcard{} = String -> IEWrappedName GhcPs
forall a. HasCallStack => String -> a
panic String
"ieName got wildcard"
wrapped :: [LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
wrapped = (LocatedA ImpExpQcSpec
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs))
-> [LocatedA ImpExpQcSpec]
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ((ImpExpQcSpec -> IEWrappedName GhcPs)
-> LocatedA ImpExpQcSpec
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ImpExpQcSpec -> IEWrappedName GhcPs
ieNameFromSpec)
mkTypeImpExp :: LocatedN RdrName
-> P (LocatedN RdrName)
mkTypeImpExp :: LocatedN RdrName -> P (LocatedN RdrName)
mkTypeImpExp LocatedN RdrName
name =
do SrcSpan -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> m ()
requireExplicitNamespaces (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LocatedN RdrName
name)
LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((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 -> NameSpace -> RdrName
`setRdrNameSpace` NameSpace
tcClsName) LocatedN RdrName
name)
checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs])
checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs])
checkImportSpec ie :: LocatedLI [LIE GhcPs]
ie@(L SrcSpanAnnLI
_ [LIE GhcPs]
specs) =
case [SrcSpanAnnA
l | (L SrcSpanAnnA
l (IEThingWith XIEThingWith GhcPs
_ LIEWrappedName GhcPs
_ (IEWildcard Int
_) [LIEWrappedName GhcPs]
_ Maybe (LHsDoc GhcPs)
_)) <- [LIE GhcPs]
[GenLocated SrcSpanAnnA (IE GhcPs)]
specs] of
[] -> LocatedLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> P (LocatedLI [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedLI [LIE GhcPs]
LocatedLI [GenLocated SrcSpanAnnA (IE GhcPs)]
ie
(SrcSpanAnnA
l:[SrcSpanAnnA]
_) -> SrcSpan -> P (LocatedLI [GenLocated SrcSpanAnnA (IE GhcPs)])
forall {m :: * -> *} {a}. MonadP m => SrcSpan -> m a
importSpecError (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
where
importSpecError :: SrcSpan -> m a
importSpecError SrcSpan
l =
MsgEnvelope PsMessage -> m a
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> m a) -> MsgEnvelope PsMessage -> m a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l PsMessage
PsErrIllegalImportBundleForm
mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ImpExpSubSpec
mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ImpExpSubSpec
mkImpExpSubSpec [] = ImpExpSubSpec -> P ImpExpSubSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LocatedA ImpExpQcSpec] -> ImpExpSubSpec
ImpExpList [])
mkImpExpSubSpec [L SrcSpanAnnA
_ (ImpExpQcWildcard EpToken ".."
td EpToken ","
_tc)] =
ImpExpSubSpec -> P ImpExpSubSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpToken ".." -> ImpExpSubSpec
ImpExpAll EpToken ".."
td)
mkImpExpSubSpec [LocatedA ImpExpQcSpec]
xs =
if ((LocatedA ImpExpQcSpec -> Bool) -> [LocatedA ImpExpQcSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcSpec -> Bool)
-> (LocatedA ImpExpQcSpec -> ImpExpQcSpec)
-> LocatedA ImpExpQcSpec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc) [LocatedA ImpExpQcSpec]
xs)
then ImpExpSubSpec -> P ImpExpSubSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ImpExpSubSpec -> P ImpExpSubSpec)
-> ImpExpSubSpec -> P ImpExpSubSpec
forall a b. (a -> b) -> a -> b
$ ([LocatedA ImpExpQcSpec] -> ImpExpSubSpec
ImpExpAllWith [LocatedA ImpExpQcSpec]
xs)
else ImpExpSubSpec -> P ImpExpSubSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ImpExpSubSpec -> P ImpExpSubSpec)
-> ImpExpSubSpec -> P ImpExpSubSpec
forall a b. (a -> b) -> a -> b
$ ([LocatedA ImpExpQcSpec] -> ImpExpSubSpec
ImpExpList [LocatedA ImpExpQcSpec]
xs)
isImpExpQcWildcard :: ImpExpQcSpec -> Bool
isImpExpQcWildcard :: ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcWildcard EpToken ".."
_ EpToken ","
_) = Bool
True
isImpExpQcWildcard ImpExpQcSpec
_ = Bool
False
warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule SrcSpan
span =
SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage SrcSpan
span PsMessage
PsWarnImportPreQualified
failNotEnabledImportQualifiedPost :: SrcSpan -> P ()
failNotEnabledImportQualifiedPost :: SrcSpan -> P ()
failNotEnabledImportQualifiedPost SrcSpan
loc =
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
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
PsErrImportPostQualified
failImportQualifiedTwice :: SrcSpan -> P ()
failImportQualifiedTwice :: SrcSpan -> P ()
failImportQualifiedTwice SrcSpan
loc =
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
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
PsErrImportQualifiedTwice
warnStarIsType :: SrcSpan -> P ()
warnStarIsType :: SrcSpan -> P ()
warnStarIsType SrcSpan
span = SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage SrcSpan
span PsMessage
PsWarnStarIsType
failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
failOpFewArgs :: forall (m :: * -> *) a. MonadP m => LocatedN RdrName -> m a
failOpFewArgs (L SrcSpanAnnN
loc RdrName
op) =
do { star_is_type <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
StarIsTypeBit
; let is_star_type = if Bool
star_is_type then StarIsType
StarIsType else StarIsType
StarIsNotType
; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrOpFewArgs is_star_type op) }
requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()
requireExplicitNamespaces :: forall (m :: * -> *). MonadP m => SrcSpan -> m ()
requireExplicitNamespaces SrcSpan
l = do
allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ExplicitNamespacesBit
unless allowed $
addError $ mkPlainErrorMsgEnvelope l PsErrIllegalExplicitNamespace
data PV_Context =
PV_Context
{ PV_Context -> ParserOpts
pv_options :: ParserOpts
, PV_Context -> ParseContext
pv_details :: ParseContext
}
data PV_Accum =
PV_Accum
{ PV_Accum -> Messages PsMessage
pv_warnings :: Messages PsMessage
, PV_Accum -> Messages PsMessage
pv_errors :: Messages PsMessage
, :: Strict.Maybe [LEpaComment]
, :: [LEpaComment]
}
data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
deriving ((forall m. Monoid m => PV_Result m -> m)
-> (forall m a. Monoid m => (a -> m) -> PV_Result a -> m)
-> (forall m a. Monoid m => (a -> m) -> PV_Result a -> m)
-> (forall a b. (a -> b -> b) -> b -> PV_Result a -> b)
-> (forall a b. (a -> b -> b) -> b -> PV_Result a -> b)
-> (forall b a. (b -> a -> b) -> b -> PV_Result a -> b)
-> (forall b a. (b -> a -> b) -> b -> PV_Result a -> b)
-> (forall a. (a -> a -> a) -> PV_Result a -> a)
-> (forall a. (a -> a -> a) -> PV_Result a -> a)
-> (forall a. PV_Result a -> [a])
-> (forall a. PV_Result a -> Bool)
-> (forall a. PV_Result a -> Int)
-> (forall a. Eq a => a -> PV_Result a -> Bool)
-> (forall a. Ord a => PV_Result a -> a)
-> (forall a. Ord a => PV_Result a -> a)
-> (forall a. Num a => PV_Result a -> a)
-> (forall a. Num a => PV_Result a -> a)
-> Foldable PV_Result
forall a. Eq a => a -> PV_Result a -> Bool
forall a. Num a => PV_Result a -> a
forall a. Ord a => PV_Result a -> a
forall m. Monoid m => PV_Result m -> m
forall a. PV_Result a -> Bool
forall a. PV_Result a -> Int
forall a. PV_Result a -> [a]
forall a. (a -> a -> a) -> PV_Result a -> a
forall m a. Monoid m => (a -> m) -> PV_Result a -> m
forall b a. (b -> a -> b) -> b -> PV_Result a -> b
forall a b. (a -> b -> b) -> b -> PV_Result a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => PV_Result m -> m
fold :: forall m. Monoid m => PV_Result m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PV_Result a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> PV_Result a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PV_Result a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> PV_Result a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> PV_Result a -> b
foldr :: forall a b. (a -> b -> b) -> b -> PV_Result a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PV_Result a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> PV_Result a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PV_Result a -> b
foldl :: forall b a. (b -> a -> b) -> b -> PV_Result a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PV_Result a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> PV_Result a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> PV_Result a -> a
foldr1 :: forall a. (a -> a -> a) -> PV_Result a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PV_Result a -> a
foldl1 :: forall a. (a -> a -> a) -> PV_Result a -> a
$ctoList :: forall a. PV_Result a -> [a]
toList :: forall a. PV_Result a -> [a]
$cnull :: forall a. PV_Result a -> Bool
null :: forall a. PV_Result a -> Bool
$clength :: forall a. PV_Result a -> Int
length :: forall a. PV_Result a -> Int
$celem :: forall a. Eq a => a -> PV_Result a -> Bool
elem :: forall a. Eq a => a -> PV_Result a -> Bool
$cmaximum :: forall a. Ord a => PV_Result a -> a
maximum :: forall a. Ord a => PV_Result a -> a
$cminimum :: forall a. Ord a => PV_Result a -> a
minimum :: forall a. Ord a => PV_Result a -> a
$csum :: forall a. Num a => PV_Result a -> a
sum :: forall a. Num a => PV_Result a -> a
$cproduct :: forall a. Num a => PV_Result a -> a
product :: forall a. Num a => PV_Result a -> a
Foldable, (forall a b. (a -> b) -> PV_Result a -> PV_Result b)
-> (forall a b. a -> PV_Result b -> PV_Result a)
-> Functor PV_Result
forall a b. a -> PV_Result b -> PV_Result a
forall a b. (a -> b) -> PV_Result a -> PV_Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PV_Result a -> PV_Result b
fmap :: forall a b. (a -> b) -> PV_Result a -> PV_Result b
$c<$ :: forall a b. a -> PV_Result b -> PV_Result a
<$ :: forall a b. a -> PV_Result b -> PV_Result a
Functor, Functor PV_Result
Foldable PV_Result
(Functor PV_Result, Foldable PV_Result) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PV_Result a -> f (PV_Result b))
-> (forall (f :: * -> *) a.
Applicative f =>
PV_Result (f a) -> f (PV_Result a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PV_Result a -> m (PV_Result b))
-> (forall (m :: * -> *) a.
Monad m =>
PV_Result (m a) -> m (PV_Result a))
-> Traversable PV_Result
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
PV_Result (m a) -> m (PV_Result a)
forall (f :: * -> *) a.
Applicative f =>
PV_Result (f a) -> f (PV_Result a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PV_Result a -> m (PV_Result b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PV_Result a -> f (PV_Result b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PV_Result a -> f (PV_Result b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PV_Result a -> f (PV_Result b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PV_Result (f a) -> f (PV_Result a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PV_Result (f a) -> f (PV_Result a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PV_Result a -> m (PV_Result b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PV_Result a -> m (PV_Result b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PV_Result (m a) -> m (PV_Result a)
sequence :: forall (m :: * -> *) a.
Monad m =>
PV_Result (m a) -> m (PV_Result a)
Traversable)
newtype PV a = PV { forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV :: PV_Context -> PV_Accum -> PV_Result a }
deriving ((forall a b. (a -> b) -> PV a -> PV b)
-> (forall a b. a -> PV b -> PV a) -> Functor PV
forall a b. a -> PV b -> PV a
forall a b. (a -> b) -> PV a -> PV b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PV a -> PV b
fmap :: forall a b. (a -> b) -> PV a -> PV b
$c<$ :: forall a b. a -> PV b -> PV a
<$ :: forall a b. a -> PV b -> PV a
Functor)
instance Applicative PV where
pure :: forall a. a -> PV a
pure a
a = a
a a -> PV a -> PV a
forall a b. a -> b -> b
`seq` (PV_Context -> PV_Accum -> PV_Result a) -> PV a
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV (\PV_Context
_ PV_Accum
acc -> PV_Accum -> a -> PV_Result a
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc a
a)
<*> :: forall a b. PV (a -> b) -> PV a -> PV b
(<*>) = PV (a -> b) -> PV a -> PV b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad PV where
PV a
m >>= :: forall a b. PV a -> (a -> PV b) -> PV b
>>= a -> PV b
f = (PV_Context -> PV_Accum -> PV_Result b) -> PV b
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result b) -> PV b)
-> (PV_Context -> PV_Accum -> PV_Result b) -> PV b
forall a b. (a -> b) -> a -> b
$ \PV_Context
ctx PV_Accum
acc ->
case PV a -> PV_Context -> PV_Accum -> PV_Result a
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV PV a
m PV_Context
ctx PV_Accum
acc of
PV_Ok PV_Accum
acc' a
a -> PV b -> PV_Context -> PV_Accum -> PV_Result b
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV (a -> PV b
f a
a) PV_Context
ctx PV_Accum
acc'
PV_Failed PV_Accum
acc' -> PV_Accum -> PV_Result b
forall a. PV_Accum -> PV_Result a
PV_Failed PV_Accum
acc'
runPV :: PV a -> P a
runPV :: forall a. PV a -> P a
runPV = ParseContext -> PV a -> P a
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
noParseContext
askParseContext :: PV ParseContext
askParseContext :: PV ParseContext
askParseContext = (PV_Context -> PV_Accum -> PV_Result ParseContext)
-> PV ParseContext
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ParseContext)
-> PV ParseContext)
-> (PV_Context -> PV_Accum -> PV_Result ParseContext)
-> PV ParseContext
forall a b. (a -> b) -> a -> b
$ \(PV_Context ParserOpts
_ ParseContext
details) PV_Accum
acc -> PV_Accum -> ParseContext -> PV_Result ParseContext
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc ParseContext
details
runPV_details :: ParseContext -> PV a -> P a
runPV_details :: forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
details PV a
m =
(PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s ->
let
pv_ctx :: PV_Context
pv_ctx = PV_Context
{ pv_options :: ParserOpts
pv_options = PState -> ParserOpts
options PState
s
, pv_details :: ParseContext
pv_details = ParseContext
details }
pv_acc :: PV_Accum
pv_acc = PV_Accum
{ pv_warnings :: Messages PsMessage
pv_warnings = PState -> Messages PsMessage
warnings PState
s
, pv_errors :: Messages PsMessage
pv_errors = PState -> Messages PsMessage
errors PState
s
, pv_header_comments :: Maybe [LEpaComment]
pv_header_comments = PState -> Maybe [LEpaComment]
header_comments PState
s
, pv_comment_q :: [LEpaComment]
pv_comment_q = PState -> [LEpaComment]
comment_q PState
s }
mkPState :: PV_Accum -> PState
mkPState PV_Accum
acc' =
PState
s { warnings = pv_warnings acc'
, errors = pv_errors acc'
, comment_q = pv_comment_q acc' }
in
case PV a -> PV_Context -> PV_Accum -> PV_Result a
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV PV a
m PV_Context
pv_ctx PV_Accum
pv_acc of
PV_Ok PV_Accum
acc' a
a -> PState -> a -> ParseResult a
forall a. PState -> a -> ParseResult a
POk (PV_Accum -> PState
mkPState PV_Accum
acc') a
a
PV_Failed PV_Accum
acc' -> PState -> ParseResult a
forall a. PState -> ParseResult a
PFailed (PV_Accum -> PState
mkPState PV_Accum
acc')
instance MonadP PV where
addError :: MsgEnvelope PsMessage -> PV ()
addError MsgEnvelope PsMessage
err =
(PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ()) -> PV ())
-> (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ctx PV_Accum
acc -> PV_Accum -> () -> PV_Result ()
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc{pv_errors = err `addMessage` pv_errors acc} ()
addWarning :: MsgEnvelope PsMessage -> PV ()
addWarning MsgEnvelope PsMessage
w =
(PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ()) -> PV ())
-> (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ctx PV_Accum
acc ->
PV_Accum -> () -> PV_Result ()
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc{pv_warnings= w `addMessage` pv_warnings acc} ()
addFatalError :: forall a. MsgEnvelope PsMessage -> PV a
addFatalError MsgEnvelope PsMessage
err =
MsgEnvelope PsMessage -> PV ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError MsgEnvelope PsMessage
err PV () -> PV a -> PV a
forall a b. PV a -> PV b -> PV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (PV_Context -> PV_Accum -> PV_Result a) -> PV a
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Accum -> PV_Result a) -> PV_Context -> PV_Accum -> PV_Result a
forall a b. a -> b -> a
const PV_Accum -> PV_Result a
forall a. PV_Accum -> PV_Result a
PV_Failed)
getParserOpts :: PV ParserOpts
getParserOpts = (PV_Context -> PV_Accum -> PV_Result ParserOpts) -> PV ParserOpts
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ParserOpts) -> PV ParserOpts)
-> (PV_Context -> PV_Accum -> PV_Result ParserOpts)
-> PV ParserOpts
forall a b. (a -> b) -> a -> b
$ \PV_Context
ctx PV_Accum
acc -> PV_Accum -> ParserOpts -> PV_Result ParserOpts
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc (ParserOpts -> PV_Result ParserOpts)
-> ParserOpts -> PV_Result ParserOpts
forall a b. (a -> b) -> a -> b
$! PV_Context -> ParserOpts
pv_options PV_Context
ctx
allocateCommentsP :: RealSrcSpan -> PV EpAnnComments
allocateCommentsP RealSrcSpan
ss = (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments)
-> (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ PV_Accum
s ->
if [LEpaComment] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PV_Accum -> [LEpaComment]
pv_comment_q PV_Accum
s) then PV_Accum -> EpAnnComments -> PV_Result EpAnnComments
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
s EpAnnComments
emptyComments else
let ([LEpaComment]
comment_q', [LEpaComment]
newAnns) = RealSrcSpan -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
allocateComments RealSrcSpan
ss (PV_Accum -> [LEpaComment]
pv_comment_q PV_Accum
s) in
PV_Accum -> EpAnnComments -> PV_Result EpAnnComments
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
s {
pv_comment_q = comment_q'
} ([LEpaComment] -> EpAnnComments
EpaComments [LEpaComment]
newAnns)
allocatePriorCommentsP :: RealSrcSpan -> PV EpAnnComments
allocatePriorCommentsP RealSrcSpan
ss = (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments)
-> (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ PV_Accum
s ->
let (Maybe [LEpaComment]
header_comments', [LEpaComment]
comment_q', [LEpaComment]
newAnns)
= RealSrcSpan
-> [LEpaComment]
-> Maybe [LEpaComment]
-> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])
allocatePriorComments RealSrcSpan
ss (PV_Accum -> [LEpaComment]
pv_comment_q PV_Accum
s) (PV_Accum -> Maybe [LEpaComment]
pv_header_comments PV_Accum
s) in
PV_Accum -> EpAnnComments -> PV_Result EpAnnComments
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
s {
pv_header_comments = header_comments',
pv_comment_q = comment_q'
} ([LEpaComment] -> EpAnnComments
EpaComments [LEpaComment]
newAnns)
allocateFinalCommentsP :: RealSrcSpan -> PV EpAnnComments
allocateFinalCommentsP RealSrcSpan
ss = (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments)
-> (PV_Context -> PV_Accum -> PV_Result EpAnnComments)
-> PV EpAnnComments
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ PV_Accum
s ->
let (Maybe [LEpaComment]
header_comments', [LEpaComment]
comment_q', [LEpaComment]
newAnns)
= RealSrcSpan
-> [LEpaComment]
-> Maybe [LEpaComment]
-> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])
allocateFinalComments RealSrcSpan
ss (PV_Accum -> [LEpaComment]
pv_comment_q PV_Accum
s) (PV_Accum -> Maybe [LEpaComment]
pv_header_comments PV_Accum
s) in
PV_Accum -> EpAnnComments -> PV_Result EpAnnComments
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
s {
pv_header_comments = header_comments',
pv_comment_q = comment_q'
} ([LEpaComment] -> [LEpaComment] -> EpAnnComments
EpaCommentsBalanced ([LEpaComment] -> Maybe [LEpaComment] -> [LEpaComment]
forall a. a -> Maybe a -> a
Strict.fromMaybe [] Maybe [LEpaComment]
header_comments') [LEpaComment]
newAnns)
hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat SrcSpan
span Pat GhcPs
e = do
bang_on <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BangPatBit
unless bang_on $
addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e
mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LHsExpr GhcPs)
mkSumOrTupleExpr :: SrcSpanAnnA
-> Boxity
-> SumOrTuple (HsExpr GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LHsExpr GhcPs)
mkSumOrTupleExpr l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
csIn) Boxity
boxity (Tuple [Either (EpAnn Bool) (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
es) (EpaLocation, EpaLocation)
anns = do
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity)
where
toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs
toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs
toTupArg (Left EpAnn Bool
ann) = EpAnn Bool -> HsTupArg GhcPs
missingTupArg EpAnn Bool
ann
toTupArg (Right LHsExpr GhcPs
a) = XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
NoExtField
noExtField LHsExpr GhcPs
a
mkSumOrTupleExpr l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
anIn EpAnnComments
csIn) Boxity
Unboxed (Sum Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcPs)
e [EpToken "|"]
barsp [EpToken "|"]
barsa) (EpaLocation
o, EpaLocation
c) = do
let an :: AnnExplicitSum
an = EpaLocation
-> [EpToken "|"] -> [EpToken "|"] -> EpaLocation -> AnnExplicitSum
AnnExplicitSum EpaLocation
o [EpToken "|"]
barsp [EpToken "|"]
barsa EpaLocation
c
!cs <- SrcSpan -> PV EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)
mkSumOrTupleExpr SrcSpanAnnA
l Boxity
Boxed a :: SumOrTuple (HsExpr GhcPs)
a@Sum{} (EpaLocation, EpaLocation)
_ =
MsgEnvelope PsMessage -> PV (LHsExpr GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LHsExpr GhcPs))
-> MsgEnvelope PsMessage -> PV (LHsExpr 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SumOrTuple (HsExpr GhcPs) -> PsMessage
PsErrUnsupportedBoxedSumExpr SumOrTuple (HsExpr GhcPs)
a
mkSumOrTuplePat
:: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation)
-> PV (LocatedA (PatBuilder GhcPs))
mkSumOrTuplePat :: SrcSpanAnnA
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> (EpaLocation, EpaLocation)
-> PV (LocatedA (PatBuilder GhcPs))
mkSumOrTuplePat SrcSpanAnnA
l Boxity
boxity (Tuple [Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))]
ps) (EpaLocation, EpaLocation)
anns = do
ps' <- (Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))]
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
-> PV (LPat GhcPs)
Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
toTupPat [Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))]
ps
return $ L l (PatBuilderPat (TuplePat anns ps' boxity))
where
toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)
toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
-> PV (LPat GhcPs)
toTupPat Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
p = case Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs))
p of
Left EpAnn Bool
_ -> MsgEnvelope PsMessage -> PV (LPat GhcPs)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LPat GhcPs))
-> MsgEnvelope PsMessage -> PV (LPat 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) PsMessage
PsErrTupleSectionInPat
Right LocatedA (PatBuilder GhcPs)
p' -> LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
p'
mkSumOrTuplePat SrcSpanAnnA
l Boxity
Unboxed (Sum Int
alt Int
arity LocatedA (PatBuilder GhcPs)
p [EpToken "|"]
barsb [EpToken "|"]
barsa) (EpaLocation, EpaLocation)
anns = do
p' <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
p
let an = (EpaLocation, EpaLocation)
-> [EpToken "|"] -> [EpToken "|"] -> EpAnnSumPat
EpAnnSumPat (EpaLocation, EpaLocation)
anns [EpToken "|"]
barsb [EpToken "|"]
barsa
return $ L l (PatBuilderPat (SumPat an p' alt arity))
mkSumOrTuplePat SrcSpanAnnA
l Boxity
Boxed a :: SumOrTuple (PatBuilder GhcPs)
a@Sum{} (EpaLocation, EpaLocation)
_ =
MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs))
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder GhcPs)))
-> MsgEnvelope PsMessage -> PV (LocatedA (PatBuilder 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SumOrTuple (PatBuilder GhcPs) -> PsMessage
PsErrUnsupportedBoxedSumPat SumOrTuple (PatBuilder GhcPs)
a
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy :: PromotionFlag
-> LHsType GhcPs
-> LocatedN RdrName
-> LHsType GhcPs
-> LHsType GhcPs
mkLHsOpTy PromotionFlag
prom LHsType GhcPs
x LocatedN RdrName
op LHsType GhcPs
y =
let loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` LocatedN RdrName -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA LocatedN RdrName
op SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y
in SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (PromotionFlag
-> LHsType GhcPs
-> LocatedN (IdP GhcPs)
-> LHsType GhcPs
-> HsType GhcPs
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
PromotionFlag
-> LHsType (GhcPass p)
-> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy PromotionFlag
prom LHsType GhcPs
x LocatedN (IdP GhcPs)
LocatedN RdrName
op LHsType GhcPs
y)
mkMultTy :: EpToken "%" -> LHsType GhcPs -> TokRarrow -> HsArrow GhcPs
mkMultTy :: EpToken "%" -> LHsType GhcPs -> TokRarrow -> HsArrow GhcPs
mkMultTy EpToken "%"
pct t :: LHsType GhcPs
t@(L SrcSpanAnnA
_ (HsTyLit XTyLit GhcPs
_ (HsNumTy (SourceText (FastString -> String
unpackFS -> String
"1")) Integer
1))) TokRarrow
arr
= XLinearArrow (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall mult pass. XLinearArrow mult pass -> HsArrowOf mult pass
HsLinearArrow (EpToken "%1" -> TokRarrow -> EpLinearArrow
EpPct1 EpToken "%1"
pct1 TokRarrow
arr)
where
pct1 :: EpToken "%1"
pct1 :: EpToken "%1"
pct1 = EpToken "%" -> SrcSpan -> EpToken "%1"
forall (tok :: Symbol) (tok' :: Symbol).
EpToken tok -> SrcSpan -> EpToken tok'
epTokenWidenR EpToken "%"
pct (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t))
mkMultTy EpToken "%"
pct LHsType GhcPs
t TokRarrow
arr = XExplicitMult (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall mult pass.
XExplicitMult mult pass -> mult -> HsArrowOf mult pass
HsExplicitMult (EpToken "%"
pct, TokRarrow
arr) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t
mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs
mkMultExpr :: EpToken "%"
-> LHsExpr GhcPs -> TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs
mkMultExpr EpToken "%"
pct t :: LHsExpr GhcPs
t@(L SrcSpanAnnA
_ (HsOverLit XOverLitE GhcPs
_ (OverLit XOverLit GhcPs
_ (HsIntegral (IL (SourceText (FastString -> String
unpackFS -> String
"1")) Bool
_ Integer
1))))) TokRarrow
arr
= XLinearArrow (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
forall mult pass. XLinearArrow mult pass -> HsArrowOf mult pass
HsLinearArrow (EpToken "%1" -> TokRarrow -> EpLinearArrow
EpPct1 EpToken "%1"
pct1 TokRarrow
arr)
where
pct1 :: EpToken "%1"
pct1 :: EpToken "%1"
pct1 = EpToken "%" -> SrcSpan -> EpToken "%1"
forall (tok :: Symbol) (tok' :: Symbol).
EpToken tok -> SrcSpan -> EpToken tok'
epTokenWidenR EpToken "%"
pct (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
t))
mkMultExpr EpToken "%"
pct LHsExpr GhcPs
t TokRarrow
arr = XExplicitMult (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
forall mult pass.
XExplicitMult mult pass -> mult -> HsArrowOf mult pass
HsExplicitMult (EpToken "%"
pct, TokRarrow
arr) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
t
mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs
mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs
mkMultAnn EpToken "%"
pct t :: LHsType GhcPs
t@(L SrcSpanAnnA
_ (HsTyLit XTyLit GhcPs
_ (HsNumTy (SourceText (FastString -> String
unpackFS -> String
"1")) Integer
1)))
= XPct1Ann GhcPs -> HsMultAnn GhcPs
forall pass. XPct1Ann pass -> HsMultAnn pass
HsPct1Ann EpToken "%1"
XPct1Ann GhcPs
pct1
where
pct1 :: EpToken "%1"
pct1 :: EpToken "%1"
pct1 = EpToken "%" -> SrcSpan -> EpToken "%1"
forall (tok :: Symbol) (tok' :: Symbol).
EpToken tok -> SrcSpan -> EpToken tok'
epTokenWidenR EpToken "%"
pct (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t))
mkMultAnn EpToken "%"
pct LHsType GhcPs
t = XMultAnn GhcPs -> LHsType (NoGhcTc GhcPs) -> HsMultAnn GhcPs
forall pass.
XMultAnn pass -> LHsType (NoGhcTc pass) -> HsMultAnn pass
HsMultAnn EpToken "%"
XMultAnn GhcPs
pct LHsType (NoGhcTc GhcPs)
LHsType GhcPs
t
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan UnhelpfulSpanReason
_) = TokenLocation
NoTokenLoc
mkTokenLocation (RealSrcSpan RealSrcSpan
r Maybe BufSpan
mb) = EpaLocation -> TokenLocation
TokenLoc (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
mb))
epTokenWidenR :: EpToken tok -> SrcSpan -> EpToken tok'
epTokenWidenR :: forall (tok :: Symbol) (tok' :: Symbol).
EpToken tok -> SrcSpan -> EpToken tok'
epTokenWidenR EpToken tok
NoEpTok SrcSpan
_ = EpToken tok'
forall (tok :: Symbol). EpToken tok
NoEpTok
epTokenWidenR (EpTok EpaLocation
l) (UnhelpfulSpan UnhelpfulSpanReason
_) = EpaLocation -> EpToken tok'
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok EpaLocation
l
epTokenWidenR (EpTok (EpaSpan SrcSpan
s1)) SrcSpan
s2 = EpaLocation -> EpToken tok'
forall (tok :: Symbol). EpaLocation -> EpToken tok
EpTok (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
s1 SrcSpan
s2))
epTokenWidenR (EpTok EpaDelta{}) SrcSpan
_ =
String -> EpToken tok'
forall a. HasCallStack => String -> a
panic String
"epTokenWidenR: EpaDelta"
starSym :: Bool -> FastString
starSym :: Bool -> FastString
starSym Bool
True = String -> FastString
fsLit String
"★"
starSym Bool
False = String -> FastString
fsLit String
"*"
mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)
-> HsExpr GhcPs
mkRdrGetField :: LHsExpr GhcPs
-> LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> HsExpr GhcPs
mkRdrGetField LHsExpr GhcPs
arg LocatedAn NoEpAnns (DotFieldOcc GhcPs)
field =
HsGetField {
gf_ext :: XGetField GhcPs
gf_ext = XGetField GhcPs
NoExtField
NoExtField
, gf_expr :: LHsExpr GhcPs
gf_expr = LHsExpr GhcPs
arg
, gf_field :: XRec GhcPs (DotFieldOcc GhcPs)
gf_field = XRec GhcPs (DotFieldOcc GhcPs)
LocatedAn NoEpAnns (DotFieldOcc GhcPs)
field
}
mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs
mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
-> AnnProjection -> HsExpr GhcPs
mkRdrProjection NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
flds AnnProjection
anns =
HsProjection {
proj_ext :: XProjection GhcPs
proj_ext = XProjection GhcPs
AnnProjection
anns
, proj_flds :: NonEmpty (DotFieldOcc GhcPs)
proj_flds = (LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> DotFieldOcc GhcPs)
-> NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
-> NonEmpty (DotFieldOcc GhcPs)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> DotFieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
flds
}
mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate :: SrcSpanAnnA
-> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LHsExpr GhcPs
-> Bool
-> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate SrcSpanAnnA
_ (L SrcSpan
_ []) LHsExpr GhcPs
_ Bool
_ Maybe (EpToken "=")
_ = String
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. HasCallStack => String -> a
panic String
"mkRdrProjUpdate: The impossible has happened!"
mkRdrProjUpdate SrcSpanAnnA
loc (L SrcSpan
l [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
flds) LHsExpr GhcPs
arg Bool
isPun Maybe (EpToken "=")
anns =
SrcSpanAnnA
-> HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated EpAnnCO (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsFieldBind {
hfbAnn :: XHsFieldBind (GenLocated EpAnnCO (FieldLabelStrings GhcPs))
hfbAnn = Maybe (EpToken "=")
XHsFieldBind (GenLocated EpAnnCO (FieldLabelStrings GhcPs))
anns
, hfbLHS :: GenLocated EpAnnCO (FieldLabelStrings GhcPs)
hfbLHS = EpAnnCO
-> FieldLabelStrings GhcPs
-> GenLocated EpAnnCO (FieldLabelStrings GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) ([XRec GhcPs (DotFieldOcc GhcPs)] -> FieldLabelStrings GhcPs
forall p. [XRec p (DotFieldOcc p)] -> FieldLabelStrings p
FieldLabelStrings [XRec GhcPs (DotFieldOcc GhcPs)]
[LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
flds)
, hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
hfbRHS = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
, hfbPun :: Bool
hfbPun = Bool
isPun
}
punsAllowed :: P Bool
punsAllowed :: P Bool
punsAllowed = ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ListTuplePunsBit
punsIfElse :: a -> a -> P a
punsIfElse :: forall a. a -> a -> P a
punsIfElse a
enabled a
disabled = do
allowed <- P Bool
punsAllowed
pure (if allowed then enabled else disabled)
requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P ()
requireLTPuns :: forall a b. PsErrPunDetails -> Located a -> Located b -> P ()
requireLTPuns PsErrPunDetails
err Located a
start Located b
end =
P Bool -> P () -> P ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM P Bool
punsAllowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ do
MsgEnvelope PsMessage -> P ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (PsErrPunDetails -> PsMessage
PsErrInvalidPun PsErrPunDetails
err))
where
loc :: SrcSpan
loc = (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located a -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located a
start) (Located b -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located b
end))
withCombinedComments ::
HasLoc l1 =>
HasLoc l2 =>
l1 ->
l2 ->
(SrcSpan -> P a) ->
P (LocatedA a)
l1
start l2
end SrcSpan -> P a
use = do
cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
fullSpan
a <- use fullSpan
pure (L (EpAnn (spanAsAnchor fullSpan) noAnn cs) a)
where
fullSpan :: SrcSpan
fullSpan = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (l1 -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc l1
start) (l2 -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc l2
end)
mkTupleSyntaxTy :: EpToken "("
-> [LocatedA (HsType GhcPs)]
-> EpToken ")"
-> P (HsType GhcPs)
mkTupleSyntaxTy :: EpToken "("
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> EpToken ")"
-> P (HsType GhcPs)
mkTupleSyntaxTy EpToken "("
parOpen [GenLocated SrcSpanAnnA (HsType GhcPs)]
args EpToken ")"
parClose =
HsType GhcPs -> HsType GhcPs -> P (HsType GhcPs)
forall a. a -> a -> P a
punsIfElse HsType GhcPs
enabled HsType GhcPs
disabled
where
enabled :: HsType GhcPs
enabled =
XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
AnnParen
annParen HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
args
disabled :: HsType GhcPs
disabled =
XExplicitTupleTy GhcPs -> [LHsType GhcPs] -> HsType GhcPs
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy (EpToken "'", EpToken "(", EpToken ")")
XExplicitTupleTy GhcPs
annsKeyword [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
args
annParen :: AnnParen
annParen = EpToken "(" -> EpToken ")" -> AnnParen
AnnParens EpToken "("
parOpen EpToken ")"
parClose
annsKeyword :: (EpToken "'", EpToken "(", EpToken ")")
annsKeyword = (EpToken "'"
forall (tok :: Symbol). EpToken tok
NoEpTok, EpToken "("
parOpen, EpToken ")"
parClose)
mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName
mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName
mkTupleSyntaxTycon Boxity
boxity Int
n =
RdrName -> RdrName -> P RdrName
forall a. a -> a -> P a
punsIfElse
(TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
n))
(DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
n))
mkListSyntaxTy0 :: EpToken "["
-> EpToken "]"
-> SrcSpan
-> P (HsType GhcPs)
mkListSyntaxTy0 :: EpToken "[" -> EpToken "]" -> SrcSpan -> P (HsType GhcPs)
mkListSyntaxTy0 EpToken "["
brkOpen EpToken "]"
brkClose SrcSpan
span =
HsType GhcPs -> HsType GhcPs -> P (HsType GhcPs)
forall a. a -> a -> P a
punsIfElse HsType GhcPs
enabled HsType GhcPs
disabled
where
enabled :: HsType GhcPs
enabled = XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpToken "'"
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted XRec GhcPs (IdP GhcPs)
LocatedN RdrName
rn
rn :: LocatedN RdrName
rn = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (EpaLocation -> NameAnn -> EpAnnComments -> SrcSpanAnnN
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
fullLoc NameAnn
rdrNameAnn EpAnnComments
emptyComments) RdrName
listTyCon_RDR
disabled :: HsType GhcPs
disabled =
XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy (EpToken "'", EpToken "[", EpToken "]")
XExplicitListTy GhcPs
annsKeyword PromotionFlag
NotPromoted []
rdrNameAnn :: NameAnn
rdrNameAnn = NameAdornment -> [TrailingAnn] -> NameAnn
NameAnnOnly (EpToken "[" -> EpToken "]" -> NameAdornment
NameSquare EpToken "["
brkOpen EpToken "]"
brkClose) []
annsKeyword :: (EpToken "'", EpToken "[", EpToken "]")
annsKeyword = (EpToken "'"
forall (tok :: Symbol). EpToken tok
NoEpTok, EpToken "["
brkOpen, EpToken "]"
brkClose)
fullLoc :: EpaLocation
fullLoc = SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan SrcSpan
span
mkListSyntaxTy1 :: EpToken "["
-> LocatedA (HsType GhcPs)
-> EpToken "]"
-> P (HsType GhcPs)
mkListSyntaxTy1 :: EpToken "["
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> EpToken "]"
-> P (HsType GhcPs)
mkListSyntaxTy1 EpToken "["
brkOpen GenLocated SrcSpanAnnA (HsType GhcPs)
t EpToken "]"
brkClose =
HsType GhcPs -> HsType GhcPs -> P (HsType GhcPs)
forall a. a -> a -> P a
punsIfElse HsType GhcPs
enabled HsType GhcPs
disabled
where
enabled :: HsType GhcPs
enabled = XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
AnnParen
annParen LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t
disabled :: HsType GhcPs
disabled =
XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy (EpToken "'", EpToken "[", EpToken "]")
XExplicitListTy GhcPs
annsKeyword PromotionFlag
NotPromoted [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t]
annsKeyword :: (EpToken "'", EpToken "[", EpToken "]")
annsKeyword = (EpToken "'"
forall (tok :: Symbol). EpToken tok
NoEpTok, EpToken "["
brkOpen, EpToken "]"
brkClose)
annParen :: AnnParen
annParen = EpToken "[" -> EpToken "]" -> AnnParen
AnnParensSquare EpToken "["
brkOpen EpToken "]"
brkClose