{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}

--
--  (c) The University of Glasgow 2002-2006
--

-- Functions over HsSyn specialised to RdrName.

module GHC.Parser.PostProcess (
        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot
        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,
        addModifiersToDecl,

        cvBindGroup,
        cvBindsAndSigs,
        cvTopDecls,
        placeHolderPunRhs,

        -- Stuff to do with Foreign declarations
        mkImport,
        parseCImport,
        mkExport,
        mkExtName,    -- RdrName -> CLabelString
        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName
        mkConDeclH98,

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
        checkImportDecl,
        checkExpBlockArguments, checkCmdBlockArguments,
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
        checkPattern_details,
        incompleteDoBlock,
        ParseContext(..),
        checkMonadComp,
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSigLhs,
        LRuleTyTmVar, RuleTyTmVar(..),
        mkRuleBndrs,
        ruleBndrsOrDef,
        checkRuleTyVarBndrNames,
        mkSpecSig,
        checkRecordSyntax,
        checkEmptyGADTs,
        addFatalError, hintBangPat,
        mkBangTy,
        UnpackednessPragma(..),
        mkMultField,

        -- Help with processing exports
        ImpExpSubSpec(..),
        ImpExpQcSpec(..),
        mkModuleImp,
        mkModuleExp,
        mkModuleImpExp,
        mkPlainImpExp,
        mkTypeImpExp,
        mkDataImpExp,
        mkTypeWcImpExp,
        mkDataWcImpExp,
        mkWholeTypeWcImpExp,
        mkWholeDataWcImpExp,
        mkPlainWcImpExp,
        mkImpExpSubSpec,
        warnPatternNamespaceSpecifier,

        -- Token symbols
        starSym,

        -- Warnings and errors
        warnStarIsType,
        warnPrepositiveQualifiedModule,
        failOpFewArgs,
        failNotEnabledImportQualifiedPost,
        failImportQualifiedTwice,
        failSpliceOrQuoteTwice,

        SumOrTuple (..),

        -- Expression/command/pattern ambiguity resolution
        PV,
        runPV,
        ECP(ECP, unECP),
        DisambInfixOp(..),
        DisambECP(..),
        ecpFromExp,
        ecpFromCmd,
        ecpFromPat,
        ArrowParsingMode(..),
        withArrowParsingMode, withArrowParsingMode',
        mkStarPV,
        setTelescopeBndrsNameSpace,
        PatBuilder,

        -- Type/datacon ambiguity resolution
        DisambTD(..),
        addUnpackednessP,
        dataConBuilderCon,
        dataConBuilderDetails,
        mkUnboxedSumCon,

        -- ListTuplePuns related parsers
        mkTupleSyntaxTy,
        mkTupleSyntaxTycon,
        mkListSyntaxTy0,
        mkListSyntaxTy1,
        withCombinedComments,
        requireLTPuns,
    ) where

import GHC.Prelude
import GHC.Hs           -- Lots of it
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 ( 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.ForeignCall
import GHC.Types.Hint
import GHC.Types.InlinePragma
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.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 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 (..) )

{- **********************************************************************

  Construction functions for Rdr stuff

  ********************************************************************* -}

-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
-- datacon by deriving them from the name of the class.  We fill in the names
-- for the tycon and datacon corresponding to the class, by deriving them
-- from the name of the class itself.  This saves recording the names in the
-- interface file (which would be equally good).

-- Similarly for mkConDecl, mkClassOpSig and default-method names.

--         *** See Note [The Naming story] in GHC.Hs.Decls ****

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
                                  , tcdModifiers = [] })) }

mkTyData :: SrcSpan
         -> Bool
         -> NewOrData
         -> Maybe (LocatedP (CType GhcPs))
         -> 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 GhcPs))
-> 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 GhcPs))
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 (GenLocated SrcSpanAnnN 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,
                                   tcdModifiers = [] })) }

mkDataDefn :: Maybe (LocatedP (CType GhcPs))
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> DataDefnCons (LConDecl GhcPs)
           -> HsDeriving GhcPs
           -> AnnDataDefn
           -> P (HsDataDefn GhcPs)
mkDataDefn :: Maybe (LocatedP (CType GhcPs))
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> DataDefnCons (LConDecl GhcPs)
-> HsDeriving GhcPs
-> AnnDataDefn
-> P (HsDataDefn GhcPs)
mkDataDefn Maybe (LocatedP (CType GhcPs))
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 GhcPs))
dd_cType = Maybe (XRec GhcPs (CType GhcPs))
Maybe (LocatedP (CType GhcPs))
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  -- LHS
            -> LHsType GhcPs  -- RHS
            -> 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 (GenLocated SrcSpanAnnN 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]   -- LHS
  -> LHsSigType GhcPs             -- RHS
  -> (EpToken "type", TokDcolon)
  -> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [GenLocated SrcSpanAnnN RdrName]
-> LHsSigType GhcPs
-> (EpToken "type", TokDcolon)
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [GenLocated SrcSpanAnnN RdrName]
lhs LHsSigType GhcPs
rhs (EpToken "type", TokDcolon)
anns =
  do { vs <- (GenLocated SrcSpanAnnN RdrName
 -> P (GenLocated SrcSpanAnnN RdrName))
-> [GenLocated SrcSpanAnnN RdrName]
-> P [GenLocated SrcSpanAnnN 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 GenLocated SrcSpanAnnN RdrName
-> P (GenLocated SrcSpanAnnN RdrName)
forall {m :: * -> *} {l}.
(MonadP m, HasLoc l) =>
GenLocated l RdrName -> m (GenLocated l RdrName)
check_lhs_name (Located [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
forall l e. GenLocated l e -> e
unLoc Located [GenLocated SrcSpanAnnN 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 :: [GenLocated SrcSpanAnnN RdrName]
-> P (GenLocated SrcSpanAnnN RdrName)
check_singular_lhs [GenLocated SrcSpanAnnN RdrName]
vs =
      case [GenLocated SrcSpanAnnN RdrName]
vs of
        [] -> String -> P (GenLocated SrcSpanAnnN RdrName)
forall a. HasCallStack => String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
        [GenLocated SrcSpanAnnN RdrName
v] -> GenLocated SrcSpanAnnN RdrName
-> P (GenLocated SrcSpanAnnN RdrName)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnN RdrName
v
        [GenLocated SrcSpanAnnN RdrName]
_ -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName))
-> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (Located [GenLocated SrcSpanAnnN RdrName] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [GenLocated SrcSpanAnnN 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)]
[GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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 GhcPs))
              -> (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 GhcPs))
-> (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 GhcPs))
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 (GenLocated SrcSpanAnnN 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                   -- LHS
          -> LFamilyResultSig GhcPs          -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> 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 (GenLocated SrcSpanAnnN 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)
-- If the user wrote
--      [pads| ... ]   then return a QuasiQuoteD
--      $(e)           then return a SpliceD
-- but if they wrote, say,
--      f x            then behave as if they'd written $(f x)
--                     ie a SpliceD
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
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                -- type being annotated
                -> [Located (Maybe FastString)]    -- roles
                -> (EpToken "type", EpToken "role")
                -> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> GenLocated SrcSpanAnnN RdrName
-> [Located (Maybe FastString)]
-> (EpToken "type", EpToken "role")
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc GenLocated SrcSpanAnnN 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))
forall {m :: * -> *} {l}.
(HasAnnotation l, MonadP m) =>
Located (Maybe FastString) -> m (GenLocated l (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) -> m (GenLocated l (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated l (Maybe Role) -> m (GenLocated l (Maybe Role))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated l (Maybe Role) -> m (GenLocated l (Maybe Role)))
-> GenLocated l (Maybe Role) -> m (GenLocated l (Maybe Role))
forall a b. (a -> b) -> a -> b
$ l -> Maybe Role -> GenLocated l (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> l
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 l (Maybe Role) -> m (GenLocated l (Maybe Role))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated l (Maybe Role) -> m (GenLocated l (Maybe Role)))
-> GenLocated l (Maybe Role) -> m (GenLocated l (Maybe Role))
forall a b. (a -> b) -> a -> b
$ l -> Maybe Role -> GenLocated l (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> l
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc_role) (Maybe Role -> GenLocated l (Maybe Role))
-> Maybe Role -> GenLocated l (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 -> m (GenLocated l (Maybe Role))
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> m (GenLocated l (Maybe Role)))
-> MsgEnvelope PsMessage -> m (GenLocated l (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 [])

-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
-- any of the provided binders has an 'InferredSpec' annotation.
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

-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without
-- annotations. Only accepts specified variables, and errors if the provided
-- binder has an 'InferredSpec' annotation.
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)

-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@
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"
 -- EpaDelta should only be used for transformations

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

-- If the decl list for where binds is empty, the anchor ends up
-- invalid. In this case, use the parent one
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

-- | The anchor for a stmtlist is based on either the location or
-- the first semicolon annotion.
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
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
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

{- **********************************************************************

  #cvBinds-etc# Converting to @HsBinds@, etc.

  ********************************************************************* -}

-- | Function definitions are restructured here. Each is assumed to be recursive
-- initially, and non recursive definitions are discovered by the dependency
-- analyser.


--  | Groups together bindings for a single function
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)

-- Declaration list may only contain value bindings and signatures.
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])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
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
    -- cvBindsAndSigs is called in several places in the parser,
    -- and its items can be produced by various productions:
    --
    --    * decl       (when parsing a where clause or a let-expression)
    --    * decl_inst  (when parsing an instance declaration)
    --    * decl_cls   (when parsing a class declaration)
    --
    -- partitionBindsAndSigs can handle almost all declaration forms produced
    -- by the aforementioned productions, except for SpliceD, which we filter
    -- out here (in drop_bad_decls).
    --
    -- We're not concerned with every declaration form possible, such as those
    -- produced by the topdecl parser production, because cvBindsAndSigs is not
    -- called on top-level declarations.
    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

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
-- Suppose      (b',ds') = getMonoBind b ds
--      ds is a list of parsed bindings
--      b is a MonoBinds that has just been read off the front

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
-- All Haddock comments between equations inside the group are
-- discarded.
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

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
    -- See Note [Exact Print Annotations for FunBind]
    go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun
       -> SrcSpanAnnA                    -- current top level loc
       -> [LHsDecl GhcPs]                -- Any docbinds seen
       -> [LHsDecl GhcPs]                -- rest of decls to be processed
       -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls
    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 -- Guaranteed at least one
            (SrcSpanAnnA
llm',SrcSpanAnnA
loc') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsOnlyA SrcSpanAnnA
llm SrcSpanAnnA
loc -- Keep comments, transfer trailing

            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'' (GenLocated SrcSpanAnnN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN 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)
        -- Reverse the final matches, to get it back in the right order
        -- Do the same thing with the trailing doc comments

getMonoBind LHsBind GhcPs
bind [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)

{- Note [Exact Print Annotations for FunBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

An individual Match that ends up in a FunBind MatchGroup is initially
parsed as a LHsDecl. This takes the form

   L loc (ValD NoExtField (FunBind ... [L lm (Match ..)]))

The loc contains the annotations, in particular comments, which are to
precede the declaration when printed, and [TrailingAnn] which are to
follow it. The [TrailingAnn] captures semicolons that may appear after
it when using the braces and semis style of coding.

The match location (lm) has only a location in it at this point, no
annotations. Its location is the same as the top level location in
loc.

What getMonoBind does it to take a sequence of FunBind LHsDecls that
belong to the same function and group them into a single function with
the component declarations all combined into the single MatchGroup as
[LMatch GhcPs].

Given that when exact printing a FunBind the exact printer simply
iterates over all the matches and prints each in turn, the simplest
behaviour would be to simply take the top level annotations (loc) for
each declaration, and use them for the individual component matches
(lm).

The problem is the exact printer first has to deal with the top level
LHsDecl, which means annotations for the loc. This needs to be able to
be exact printed in the context of surrounding declarations, and if
some refactor decides to move the declaration elsewhere, the leading
comments and trailing semicolons need to be handled at that level.

So the solution is to combine all the matches into one, pushing the
annotations into the LMatch's, and then at the end extract the
comments from the first match and [TrailingAnn] from the last to go in
the top level LHsDecl.
-}

-- Group together adjacent FunBinds for every function.
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)
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).

{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion

  ********************************************************************* -}

{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The problem with parsing data constructors is that they look a lot like types.
Compare:

  (s1)   data T = C t1 t2
  (s2)   type T = C t1 t2

Syntactically, there's little difference between these declarations, except in
(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.

This similarity would pose no problem if we knew ahead of time if we are
parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple
(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing
data constructors, and in other contexts (e.g. 'type' declarations) assume we
are parsing type constructors.

This simple rule does not work because of two problematic cases:

  (p1)   data T = C t1 t2 :+ t3
  (p2)   data T = C t1 t2 => t3

In (p1) we encounter (:+) and it turns out we are parsing an infix data
declaration, so (C t1 t2) is a type and 'C' is a type constructor.
In (p2) we encounter (=>) and it turns out we are parsing an existential
context, so (C t1 t2) is a constraint and 'C' is a type constructor.

As the result, in order to determine whether (C t1 t2) declares a data
constructor, a type, or a context, we would need unlimited lookahead which
'happy' is not so happy with.
-}

-- | Reinterpret a type constructor, including type operators, as a data
--   constructor.
-- See Note [Parsing data constructors is hard]
tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon :: GenLocated SrcSpanAnnN RdrName
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
tyConToDataCon (L SrcSpanAnnN
loc RdrName
tc)
  | String -> Bool
okConOcc (OccName -> String
occNameString OccName
occ)
  = GenLocated SrcSpanAnnN RdrName
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
forall a. a -> Either (MsgEnvelope PsMessage) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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) (GenLocated SrcSpanAnnN RdrName)
MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
forall a b. a -> Either a b
Left (MsgEnvelope PsMessage
 -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName))
-> MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN 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 :: GenLocated SrcSpanAnnN 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))
                               [LHsModifier 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
           -- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty
           ; let ann_fun :: AnnFunRhs
ann_fun = [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
mk_ann_funrhs [] []
           ; match <- case HsConPatDetails GhcPs
details of
               PrefixCon [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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName)
ctxt = FunRhs { mc_fun :: GenLocated SrcSpanAnnN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName)
ctxt = FunRhs { mc_fun :: GenLocated SrcSpanAnnN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
GenLocated SrcSpanAnnN 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 ".")) -> [LHsModifier GhcPs]
             -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
                -> ConDecl GhcPs

mkConDeclH98 :: (TokDarrow, (TokForall, EpToken "."))
-> [LHsModifier GhcPs]
-> GenLocated SrcSpanAnnN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 (TokDarrow
tdarrow, (TokForall
tforall,EpToken "."
tdot)) [LHsModifier GhcPs]
mods GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN 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_modifiers :: [LHsModifier GhcPs]
con_modifiers = [LHsModifier GhcPs]
mods
               , con_doc :: Maybe (LHsDoc GhcPs)
con_doc    = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing }

-- | Construct a GADT-style data constructor from the constructor names and
-- their type. Some interesting aspects of this function:
--
-- * This splits up the constructor type into its quantified type variables (if
--   provided), context (if provided), argument types, and result type, and
--   records whether this is a prefix or record GADT constructor. See
--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: SrcSpan
           -> [LHsModifier GhcPs]
           -> NonEmpty (LocatedN RdrName)
           -> TokDcolon
           -> LHsSigType GhcPs
           -> P (LConDecl GhcPs)
mkGadtDecl :: SrcSpan
-> [LHsModifier GhcPs]
-> NonEmpty (GenLocated SrcSpanAnnN RdrName)
-> TokDcolon
-> LHsSigType GhcPs
-> P (LConDecl GhcPs)
mkGadtDecl SrcSpan
loc [LHsModifier GhcPs]
mods NonEmpty (GenLocated SrcSpanAnnN 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
_ HsModifiedFunArr GhcPs
hsArr (L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
cs) (XHsType (HsRecTy AnnList ()
an [LHsConDeclRecField GhcPs]
rf))) LHsType GhcPs
res_ty) -> do
       arr <- case HsModifiedFunArr GhcPs
hsArr of
         HsModifiedFunArr XHsModifiedFunArr (LHsType (NoGhcTc GhcPs)) GhcPs
_ [] (HsStandardArr (EpArrow TokRarrow
arr)) -> TokRarrow -> P TokRarrow
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return TokRarrow
arr
         HsModifiedFunArr 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
$
                                 (HsModifiedFunArr GhcPs -> PsMessage
PsErrIllegalGadtRecordModifier HsModifiedFunArr 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, [HsConDeclField GhcPs]
arg_types, LHsType GhcPs
res_type) = LHsType GhcPs
-> (([EpToken "("], [EpToken ")"]), EpAnnComments,
    [HsConDeclField GhcPs], LHsType GhcPs)
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
-> [HsConDeclField GhcPs] -> HsConDeclGADTDetails GhcPs
forall pass.
XPrefixConGADT pass
-> [HsConDeclField pass] -> HsConDeclGADTDetails pass
PrefixConGADT NoExtField
XPrefixConGADT GhcPs
noExtField [HsConDeclField GhcPs]
arg_types, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_type, ([EpToken "("]
ops,[EpToken ")"]
cps), EpAnnComments
cs)

  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_outer_bndrs = L outer_bndrs_loc outer_bndrs
                     , con_inner_bndrs = inner_bndrs
                     , con_mb_cxt = mcxt
                     , con_g_args = args
                     , con_res_ty = res_ty
                     , con_modifiers = mods
                     , con_doc    = Nothing }
  where
    (HsOuterSigTyVarBndrs GhcPs
outer_bndrs, [HsForAllTelescope GhcPs]
inner_bndrs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsSigType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs],
    Maybe (LHsContext GhcPs), LHsType GhcPs)
splitLHsGadtTy LHsSigType GhcPs
ty
    outer_bndrs_loc :: SrcSpanAnnA
outer_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


setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
--
-- Case #1. When parsing:
--
-- > data T a = T | T1 Int
--
-- we parse the data constructors as /types/ because of parser ambiguities,
-- so then we need to change the /type constr/ to a /data constr/
--
-- The exact-name case /can/ occur when parsing:
--
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
--
-- Case #2. When parsing:
--
-- > x = fn (forall a. a)   -- RequiredTypeArguments
--
-- we use setRdrNameSpace to set the namespace of forall-bound variables.
--
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
    -- Preserve Exact Names for wired-in things,
    -- notably tuples and lists

  | Name -> Bool
isExternalName Name
n
  = Module -> OccName -> RdrName
Orig (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n) OccName
occ

  | Bool
otherwise   -- This can happen when quoting and then
                -- splicing a fixity declaration for a type
  = 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)      -- No-op

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)      -- No-op

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  -- See Note [setRdrNameSpace for wired-in names]
  = 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  -- See Note [setRdrNameSpace for wired-in names]
  = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tcClsName (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))



{- Note [setRdrNameSpace for wired-in names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC.Types, which declares (:), we have
  infixr 5 :
The ambiguity about which ":" is meant is resolved by parsing it as a
data constructor, but then using dataTcOccs to try the type constructor too;
and that in turn calls setRdrNameSpace to change the name-space of ":" to
tcClsName.  There isn't a corresponding ":" type constructor, but it's painful
to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}

eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a
-- Adapts the Either monad to the P monad
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)  -- the synthesized type variables
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
checkTyVars :: SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars SDoc
pp_what SDoc
equals_or_where GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tc))
        -- Keep around an action for adjusting the annotations of extra parens
    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

        -- Check that the name space is correct!
    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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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
_ LIdOccP GhcPs
tv) | RdrName -> Bool
isRdrTyVar (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdOccP GhcPs
GenLocated SrcSpanAnnN 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 LIdOccP GhcPs
XRec GhcPs (IdP GhcPs)
tv)
    match_bndr_var (HsWildCardTy XWildCardTy GhcPs
tok)
      = (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 XWildCardTy GhcPs
XBndrWildCard GhcPs
tok)
    match_bndr_var HsType GhcPs
_ = Maybe (EpToken "'", HsBndrVar GhcPs)
forall a. Maybe a
Nothing

    -- Return a EpaLocation for use in widenLocatedAnL.
    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
-- Second argument to checkTyVars
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))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@

ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
ruleBndrsOrDef (Just RuleBndrs GhcPs
bndrs) = RuleBndrs GhcPs
bndrs
ruleBndrsOrDef Maybe (RuleBndrs GhcPs)
Nothing      = HsRuleBndrsAnn
-> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
mkRuleBndrs HsRuleBndrsAnn
forall a. NoAnn a => a
noAnn Maybe [LRuleTyTmVar]
forall a. Maybe a
Nothing []

mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
mkRuleBndrs :: HsRuleBndrsAnn
-> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
mkRuleBndrs HsRuleBndrsAnn
ann Maybe [LRuleTyTmVar]
tvbs [LRuleTyTmVar]
tmbs
  = RuleBndrs { rb_ext :: XCRuleBndrs GhcPs
rb_ext = XCRuleBndrs GhcPs
HsRuleBndrsAnn
ann
              , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
rb_tyvs = ([LRuleTyTmVar] -> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)])
-> Maybe [LRuleTyTmVar]
-> Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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_tv)) Maybe [LRuleTyTmVar]
tvbs
              , rb_tmvs :: [LRuleBndr (NoGhcTc GhcPs)]
rb_tmvs = (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_tm) [LRuleTyTmVar]
tmbs }
  where
    -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward
    cvt_tm :: RuleTyTmVar -> RuleBndr GhcPs
cvt_tm (RuleTyTmVar AnnTyVarBndr
ann GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN RdrName
v
    cvt_tm (RuleTyTmVar AnnTyVarBndr
ann GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN RdrName
v (EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnnCO
forall a. NoAnn a => a
noAnn LHsType GhcPs
sig)

    -- cvt_tv turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
    cvt_tv :: GenLocated a RuleTyTmVar -> GenLocated l (HsTyVarBndr () GhcPs)
cvt_tv (L a
l (RuleTyTmVar AnnTyVarBndr
ann GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN 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 :: [LRuleTyTmVar] -> P ()
-- See Note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P ()
checkRuleTyVarBndrNames [LRuleTyTmVar]
bndrs
   = [P ()] -> P ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ GenLocated SrcSpanAnnN RdrName -> P ()
forall {m :: * -> *} {a}.
(MonadP m, HasLoc a) =>
GenLocated a RdrName -> m ()
check GenLocated SrcSpanAnnN RdrName
lname | L EpAnnCO
_ (RuleTyTmVar AnnTyVarBndr
_ GenLocated SrcSpanAnnN RdrName
lname Maybe (LHsType GhcPs)
_) <- [LRuleTyTmVar]
bndrs ]
  where
    check :: GenLocated a RdrName -> m ()
check (L a
loc (Unqual OccName
occ)) =
          Bool -> m () -> m ()
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"]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          MsgEnvelope PsMessage -> m ()
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (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
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
                          OccName -> PsMessage
PsErrParseErrorOnInput OccName
occ
    check GenLocated a RdrName
_ = String -> m ()
forall a. HasCallStack => String -> a
panic String
"checkRuleTyVarBndrNames"

-- | Deal with both old-form and new-form specialise pragmas, using the new
-- 'SpecSigE' form unless there are multiple comma-separated type signatures,
-- in which case we use the old-form.
--
-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig.
mkSpecSig :: InlinePragma GhcPs
          -> AnnSpecSig
          -> Maybe (RuleBndrs GhcPs)
          -> LHsExpr GhcPs
          -> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
          -> P (Sig GhcPs)
mkSpecSig :: InlinePragma GhcPs
-> AnnSpecSig
-> Maybe (RuleBndrs GhcPs)
-> LHsExpr GhcPs
-> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
-> P (Sig GhcPs)
mkSpecSig InlinePragma GhcPs
inl_prag AnnSpecSig
activation_anns Maybe (RuleBndrs GhcPs)
m_rule_binds LHsExpr GhcPs
expr Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
m_sigtypes_ascr
  = case Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
m_sigtypes_ascr of
      Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
Nothing
        -- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-}
        -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcPs -> P (Sig GhcPs)) -> Sig GhcPs -> P (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$
           XSpecSigE GhcPs
-> RuleBndrs GhcPs
-> LHsExpr GhcPs
-> InlinePragma GhcPs
-> Sig GhcPs
forall pass.
XSpecSigE pass
-> RuleBndrs pass -> LHsExpr pass -> InlinePragma pass -> Sig pass
SpecSigE XSpecSigE GhcPs
AnnSpecSig
activation_anns
                    (Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
ruleBndrsOrDef Maybe (RuleBndrs GhcPs)
m_rule_binds) LHsExpr GhcPs
expr InlinePragma GhcPs
inl_prag

      Just (L SrcSpan
lt (TokDcolon
colon_ann, OrdList (LHsSigType GhcPs)
sigtype_ol))

        -- Singleton, e.g.  {-# SPECIALISE f :: ty #-}
        -- Use the SpecSigE route
        | [GenLocated SrcSpanAnnA (HsSigType GhcPs)
sigtype] <- [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
sigtype_list
        -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcPs -> P (Sig GhcPs)) -> Sig GhcPs -> P (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$
           XSpecSigE GhcPs
-> RuleBndrs GhcPs
-> LHsExpr GhcPs
-> InlinePragma GhcPs
-> Sig GhcPs
forall pass.
XSpecSigE pass
-> RuleBndrs pass -> LHsExpr pass -> InlinePragma pass -> Sig pass
SpecSigE XSpecSigE GhcPs
AnnSpecSig
activation_anns
                    (Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
ruleBndrsOrDef Maybe (RuleBndrs GhcPs)
m_rule_binds)
                    (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L ((SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => EpAnn a -> EpAnn a -> EpAnn a
combineSrcSpansA (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr) (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
lt)))
                       (XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
TokDcolon
colon_ann LHsExpr GhcPs
expr (GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
sigtype)))
                    InlinePragma GhcPs
inl_prag

        -- So we must have the old form  {# SPECIALISE f :: ty1, ty2, ty3 #-}
        -- Use the old SpecSig route
        | Maybe (RuleBndrs GhcPs)
Nothing <- Maybe (RuleBndrs GhcPs)
m_rule_binds
        , L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdOccP GhcPs
var) <- LHsExpr GhcPs
expr
        -> do SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage SrcSpan
sigs_loc PsMessage
PsWarnSpecMultipleTypeAscription
              Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcPs -> P (Sig GhcPs)) -> Sig GhcPs -> P (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$
                XSpecSig GhcPs
-> XRec GhcPs (IdP GhcPs)
-> [LHsSigType GhcPs]
-> InlinePragma GhcPs
-> Sig GhcPs
forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma pass -> Sig pass
SpecSig (AnnSpecSig
activation_anns {ass_dcolon = Just colon_ann })
                        LIdOccP GhcPs
XRec GhcPs (IdP GhcPs)
var [LHsSigType GhcPs]
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
sigtype_list InlinePragma GhcPs
inl_prag

        | Bool
otherwise ->
            MsgEnvelope PsMessage -> P (Sig GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (Sig GhcPs))
-> MsgEnvelope PsMessage -> P (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$
              SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
sigs_loc PsMessage
PsErrSpecExprMultipleTypeAscription

        where
          sigtype_list :: [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
sigtype_list = OrdList (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
forall a. OrdList a -> [a]
fromOL OrdList (LHsSigType GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsSigType GhcPs))
sigtype_ol
          sigs_loc :: SrcSpan
sigs_loc =
            TokDcolon -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc TokDcolon
colon_ann SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc ([GenLocated SrcSpanAnnA (HsSigType GhcPs)]
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a. HasCallStack => [a] -> a
last [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
sigtype_list)

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

-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
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 "}")
_, []))           -- Empty GADT declaration.
    = do gadtSyntax <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit   -- GADTs implies GADTSyntax
         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              -- Ordinary GADT declaration.

checkTyClHdr :: Bool               -- True  <=> class header
                                   -- False <=> type header
             -> LHsType GhcPs
             -> P (LocatedN RdrName,     -- the head symbol (type or class name)
                   [LHsTypeArg GhcPs],   -- parameters of head symbol
                   LexicalFixity,        -- the declaration is in infix format
                   [EpToken "("],        -- API Annotation for HsParTy
                   [EpToken ")"],        -- when stripping parens
                   EpAnnComments)        -- Accumulated comments from re-arranging
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
--              Int :*: Bool   into    (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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

    -- workaround to define '*' despite StarIsType
    go :: EpAnnComments
-> SrcSpanAnnA
-> HsType GhcPs
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [EpToken "("]
-> [EpToken ")"]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN 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
tok))) [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 isUni :: IsUnicodeSyntax
isUni = case XStarTy GhcPs
tok of { XStarTy GhcPs
EpUniToken "*" "\9733"
NoEpUniTok    -> IsUnicodeSyntax
NormalSyntax
                                     ; EpUniTok EpaLocation
_ IsUnicodeSyntax
iu -> IsUnicodeSyntax
iu }
           ; let name :: OccName
name = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
tcClsName (IsUnicodeSyntax -> FastString
starSym IsUnicodeSyntax
isUni)
           ; let a' :: SrcSpanAnnN
a' = SrcSpanAnnA
-> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN
newAnns SrcSpanAnnA
ll SrcSpanAnnA
l (EpToken "(", EpToken ")")
XParTy GhcPs
an
           ; (GenLocated SrcSpanAnnN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (GenLocated SrcSpanAnnN 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 -> GenLocated SrcSpanAnnN 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 :: LIdOccP 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               = (GenLocated SrcSpanAnnN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (GenLocated SrcSpanAnnN 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 (LIdOccP GhcPs
GenLocated SrcSpanAnnN 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
_ LHsType GhcPs
t1 LHsType GhcPs
tyop 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 (GenLocated SrcSpanAnnN 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)
tyop (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) [EpToken "("]
ops [EpToken ")"]
cps LexicalFixity
Infix
      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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN 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
      = (GenLocated SrcSpanAnnN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments)
-> P (GenLocated SrcSpanAnnN 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 -> GenLocated SrcSpanAnnN 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)
          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
    go EpAnnComments
_ SrcSpanAnnA
l HsType GhcPs
_ [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
_ [EpToken "("]
_ [EpToken ")"]
_ LexicalFixity
_
      = MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName,
       [HsArg
          GhcPs
          (GenLocated SrcSpanAnnA (HsType GhcPs))
          (GenLocated SrcSpanAnnA (HsType GhcPs))],
       LexicalFixity, [EpToken "("], [EpToken ")"], EpAnnComments))
-> MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnN 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)

    -- Combine the annotations from the HsParTy and HsStarTy into a
    -- new one for the LocatedN RdrName
    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)

-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
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)

-- | Validate the context constraints and break up a context into a list
-- of predicates.
--
-- @
--     (Eq a, Ord b)        -->  [Eq a, Ord b]
--     Eq a                 -->  [Eq a]
--     (Eq a)               -->  [Eq a]
--     (((Eq a)))           -->  [Eq 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))
    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
    -- be used as context constraints.
    -- Ditto ()
    = ([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

  -- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure
  -- downstream.
  -- This converts them just like when they are parsed as types in the punned case.
  check ([EpToken "("]
oparens,[EpToken ")"]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsExplicitTupleTy (EpToken "'"
q,EpToken "("
o,EpToken ")"
c) PromotionFlag
_ [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))
                                             -- to be sure HsParTy doesn't get into the way
    = ([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

  -- No need for anns, returning original
  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 =
    -- Append parens so that the original order in the source is maintained
    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)

-- | The same as `checkContext`, but for expressions.
--
-- Validate the context constraints and break up a context into a list
-- of predicates.
--
-- @
--     (Eq a, Ord b)        -->  [Eq a, Ord b]
--     Eq a                 -->  [Eq a]
--     (Eq a)               -->  [Eq a]
--     (((Eq a)))           -->  [Eq a]
-- @
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))
             -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context
      | 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 =
      -- Append parens so that the original order in the source is maintained
      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")
                -> Maybe EpAnnLevel
                -> Maybe EpAnnLevel
                -> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
                     , (Maybe EpAnnLevel, ImportDeclLevelStyle))
checkImportDecl :: Maybe (EpToken "qualified")
-> Maybe (EpToken "qualified")
-> Maybe EpAnnLevel
-> Maybe EpAnnLevel
-> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle),
      (Maybe EpAnnLevel, ImportDeclLevelStyle))
checkImportDecl Maybe (EpToken "qualified")
mPre Maybe (EpToken "qualified")
mPost Maybe EpAnnLevel
preLevel Maybe EpAnnLevel
postLevel = 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

  -- Error if 'qualified' found in postpositive position and
  -- 'ImportQualifiedPost' is not in effect.
  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)

  -- Error if 'qualified' occurs in both pre and postpositive
  -- positions.
  qualSpec <- importDeclQualifiedStyle mPre mPost
  levelSpec <- importDeclLevelStyle preLevel postLevel

  -- Warn if 'qualified' found in prepositive position and
  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
  whenJust mPre $ \EpToken "qualified"
pre ->
    SrcSpan -> P ()
warnPrepositiveQualifiedModule (EpToken "qualified" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
tokenSpan EpToken "qualified"
pre)

  return (qualSpec, levelSpec)

-- | Given two possible located 'qualified' tokens, compute a style
-- (in a conforming Haskell program only one of the two can be not
-- 'Nothing'). This is called from "GHC.Parser".
importDeclQualifiedStyle :: Maybe (EpToken "qualified")
                         -> Maybe (EpToken "qualified")
                         -> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
importDeclQualifiedStyle :: Maybe (EpToken "qualified")
-> Maybe (EpToken "qualified")
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
importDeclQualifiedStyle Maybe (EpToken "qualified")
mPre Maybe (EpToken "qualified")
mPost =
  case (Maybe (EpToken "qualified")
mPre, Maybe (EpToken "qualified")
mPost) of
    (Just {}, Just EpToken "qualified"
post) -> SrcSpan -> P ()
failImportQualifiedTwice (EpToken "qualified" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "qualified"
post)
                            P ()
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpToken "qualified" -> Maybe (EpToken "qualified")
forall a. a -> Maybe a
Just EpToken "qualified"
post, ImportDeclQualifiedStyle
QualifiedPost)
    (Maybe (EpToken "qualified")
Nothing, Just EpToken "qualified"
post) -> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpToken "qualified" -> Maybe (EpToken "qualified")
forall a. a -> Maybe a
Just EpToken "qualified"
post, ImportDeclQualifiedStyle
QualifiedPost)
    (Just EpToken "qualified"
pre, Maybe (EpToken "qualified")
Nothing) -> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpToken "qualified" -> Maybe (EpToken "qualified")
forall a. a -> Maybe a
Just EpToken "qualified"
pre, ImportDeclQualifiedStyle
QualifiedPre)
    (Maybe (EpToken "qualified")
Nothing, Maybe (EpToken "qualified")
Nothing) -> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
-> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EpToken "qualified")
forall a. Maybe a
Nothing, ImportDeclQualifiedStyle
NotQualified)

importDeclLevelStyle :: (Maybe EpAnnLevel)
                     -> (Maybe EpAnnLevel)
                     -> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
importDeclLevelStyle :: Maybe EpAnnLevel
-> Maybe EpAnnLevel -> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
importDeclLevelStyle Maybe EpAnnLevel
preImportLevel Maybe EpAnnLevel
postImportLevel =
  case (Maybe EpAnnLevel
preImportLevel, Maybe EpAnnLevel
postImportLevel) of
    (Just {}, Just EpAnnLevel
tok) -> EpAnnLevel -> P ()
failSpliceOrQuoteTwice EpAnnLevel
tok
                            P ()
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe EpAnnLevel, ImportDeclLevelStyle)
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpAnnLevel -> Maybe EpAnnLevel
forall a. a -> Maybe a
Just EpAnnLevel
tok, ImportDeclLevel -> ImportDeclLevelStyle
LevelStylePost (EpAnnLevel -> ImportDeclLevel
tokToLevel EpAnnLevel
tok))
    (Maybe EpAnnLevel
Nothing, Just EpAnnLevel
post) -> (Maybe EpAnnLevel, ImportDeclLevelStyle)
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpAnnLevel -> Maybe EpAnnLevel
forall a. a -> Maybe a
Just EpAnnLevel
post, ImportDeclLevel -> ImportDeclLevelStyle
LevelStylePost (EpAnnLevel -> ImportDeclLevel
tokToLevel EpAnnLevel
post))
    (Just EpAnnLevel
pre, Maybe EpAnnLevel
Nothing) -> (Maybe EpAnnLevel, ImportDeclLevelStyle)
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpAnnLevel -> Maybe EpAnnLevel
forall a. a -> Maybe a
Just EpAnnLevel
pre, ImportDeclLevel -> ImportDeclLevelStyle
LevelStylePre (EpAnnLevel -> ImportDeclLevel
tokToLevel EpAnnLevel
pre))
    (Maybe EpAnnLevel
Nothing, Maybe EpAnnLevel
Nothing) -> (Maybe EpAnnLevel, ImportDeclLevelStyle)
-> P (Maybe EpAnnLevel, ImportDeclLevelStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EpAnnLevel
forall a. Maybe a
Nothing, ImportDeclLevelStyle
NotLevelled)
  where
    tokToLevel :: EpAnnLevel -> ImportDeclLevel
tokToLevel EpAnnLevel
tok = case EpAnnLevel
tok of
      EpAnnLevelSplice {} -> ImportDeclLevel
ImportDeclSplice
      EpAnnLevelQuote {} -> ImportDeclLevel
ImportDeclQuote



-- -------------------------------------------------------------------------
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs))
 -> P (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (LocatedA (PatBuilder GhcPs)
    -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> LocatedA (PatBuilder GhcPs)
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat

checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_details ParseContext
extraDetails PV (LocatedA (PatBuilder GhcPs))
pp = ParseContext
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
extraDetails (PV (LocatedA (PatBuilder GhcPs))
pp PV (LocatedA (PatBuilder GhcPs))
-> (LocatedA (PatBuilder GhcPs)
    -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. PV a -> (a -> PV b) -> PV b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat)

checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (L l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
_) PatBuilder GhcPs
p) = do
  (L l' p', cs) <- SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder 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) -> [LPat GhcPs]
         -> PV (LPat GhcPs, EpAnnComments)
-- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat`
-- productions
checkPat :: SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder 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))) [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 -- AZ: where should this come from?
      , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ln RdrName
c
      , pat_args :: HsConPatDetails GhcPs
pat_args = [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [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)) [LPat GhcPs]
args =
  SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder 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 (EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs
mkInvisLPat EpToken "@"
at HsTyPat GhcPs
t GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args)
checkPat SrcSpanAnnA
loc 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 [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)

mkInvisLPat :: EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs
mkInvisLPat :: EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs
mkInvisLPat EpToken "@"
tok HsTyPat GhcPs
ty_pat = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcPs
invis_pat
  where
    HsTP XHsTP GhcPs
_ (L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
_) HsType GhcPs
_) = HsTyPat GhcPs
ty_pat
    l :: SrcSpanAnnA
l = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpaLocation -> EpToken "@" -> EpaLocation
forall (tok :: Symbol). EpaLocation -> EpToken tok -> EpaLocation
widenAnchorT EpaLocation
anc EpToken "@"
tok) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
emptyComments
    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

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 GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN RdrName
x)

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
   -- NB. Negative *primitive* literals are already handled by the lexer
   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)

   -- n+k patterns
   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 (GenLocated SrcSpanAnnN RdrName
-> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+" -> Pat GhcPs
mkNPlusKPat (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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 "+"
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))

   -- Improve error messages for the @-operator when the user meant an @-pattern
   PatBuilderOpApp LocatedA (PatBuilder GhcPs)
_ GenLocated SrcSpanAnnN RdrName
op LocatedA (PatBuilder GhcPs)
_ ([EpToken "("], [EpToken ")"])
_ | RdrName -> Bool
opIsAt (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnN 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)

   PatBuilderModifiers [LHsModifier GhcPs]
mods LocatedA (PatBuilder GhcPs)
pat -> XModifiedPat GhcPs
-> [LHsModifier GhcPs] -> LPat GhcPs -> Pat GhcPs
forall p. XModifiedPat p -> [LHsModifier p] -> LPat p -> Pat p
ModifiedPat XModifiedPat GhcPs
NoExtField
noExtField [LHsModifier GhcPs]
mods (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> PV (Pat GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
pat

   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)
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when
-- debugging
placeHolderPunRhs :: forall b. DisambECP b => PV (LocatedA b)
placeHolderPunRhs = GenLocated SrcSpanAnnN RdrName -> PV (LocatedA b)
forall b.
DisambECP b =>
GenLocated SrcSpanAnnN RdrName -> PV (LocatedA b)
mkHsVarPV (RdrName -> GenLocated SrcSpanAnnN 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
"+") -- Hack
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")

---------------------------------------------------------------------------
-- Check Equation Syntax

-- We distinguish between modifiers attached to bindings (which are used for
-- multiplicity annotations) and modifiers attached to patterns (which are
-- currently unused). Both are parsed as PatBuilderModifiers; if that's the
-- top-level constructor, it's attached to the binding.
--
-- Binding: let %m p = ... (PatBuilderModifiers ...)
-- Pattern: let (%m p) = ... (PatBuilderPar (PatBuilderModifiers ...))
-- Pattern: let %m x:y = ... (PatBuilderOpApp (PatBuilderModifiers ...) ":" (...))
--
-- See Note [Modifiers on patterns vs bindings] in Language.Haskell.Syntax.Pat.
extract_pat_builder_modifiers
  :: LocatedA (PatBuilder p) -> (LocatedA (PatBuilder p), [LHsModifier p])
extract_pat_builder_modifiers :: forall p.
LocatedA (PatBuilder p)
-> (LocatedA (PatBuilder p), [LHsModifier p])
extract_pat_builder_modifiers = \case
  L SrcSpanAnnA
_ (PatBuilderModifiers [LHsModifier p]
m LocatedA (PatBuilder p)
p) -> (LocatedA (PatBuilder p)
p, [LHsModifier p]
m)
  LocatedA (PatBuilder p)
x -> (LocatedA (PatBuilder p)
x, [])

checkValDef :: SrcSpan
            -> LocatedA (PatBuilder GhcPs)
            -> Maybe (TokDcolon, LHsType GhcPs)
            -> Located (GRHSs GhcPs (LHsExpr GhcPs))
            -> P (HsBind GhcPs)

checkValDef :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> Maybe (TokDcolon, LHsType GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (Just (TokDcolon
sigAnn, LHsType GhcPs
sig)) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
        -- x :: ty = rhs  parses as a *pattern* binding
  = do let (LocatedA (PatBuilder GhcPs)
lhs', [LHsModifier GhcPs]
mods) = LocatedA (PatBuilder GhcPs)
-> (LocatedA (PatBuilder GhcPs), [LHsModifier GhcPs])
forall p.
LocatedA (PatBuilder p)
-> (LocatedA (PatBuilder p), [LHsModifier p])
extract_pat_builder_modifiers LocatedA (PatBuilder GhcPs)
lhs
       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 mods

checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs Maybe (TokDcolon, LHsType GhcPs)
Nothing Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
        -- %p x = rhs  parses as a *pattern* binding
  = do let (LocatedA (PatBuilder GhcPs)
lhs', [LHsModifier GhcPs]
mods) = LocatedA (PatBuilder GhcPs)
-> (LocatedA (PatBuilder GhcPs), [LHsModifier GhcPs])
forall p.
LocatedA (PatBuilder p)
-> (LocatedA (PatBuilder p), [LHsModifier p])
extract_pat_builder_modifiers LocatedA (PatBuilder GhcPs)
lhs
       mb_fun <- LocatedA (PatBuilder GhcPs)
-> P (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder GhcPs)], [EpToken "("], [EpToken ")"]))
isFunLhs LocatedA (PatBuilder GhcPs)
lhs'
       case (mods, mb_fun) of
         ([], Just (GenLocated SrcSpanAnnN RdrName
fun, LexicalFixity
is_infix, [LocatedA (PatBuilder 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 (PatBuilder GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LocatedA (PatBuilder GhcPs)]
pats
              SrcSpan
-> AnnFunRhs
-> GenLocated SrcSpanAnnN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcSpan
loc AnnFunRhs
ann_fun
                           GenLocated SrcSpanAnnN RdrName
fun LexicalFixity
is_infix (EpaLocation
-> [LocatedA (PatBuilder GhcPs)]
-> LocatedE [LocatedA (PatBuilder GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LocatedA (PatBuilder GhcPs)]
pats) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
         ([GenLocated
    SrcSpanAnnA
    (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)],
 Maybe
   (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
    [LocatedA (PatBuilder GhcPs)], [EpToken "("], [EpToken ")"]))
_ -> do
              lhs'' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs'
              checkPatBind loc lhs'' grhss mods

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 (PatBuilder GhcPs)]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P (HsBind GhcPs)
checkFunBind :: SrcSpan
-> AnnFunRhs
-> GenLocated SrcSpanAnnN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (PatBuilder 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 (PatBuilder 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 (PatBuilder GhcPs)
 -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [LocatedA (PatBuilder GhcPs)]
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat [LocatedA (PatBuilder GhcPs)]
pats)
        let match_span = 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 })]))
        -- The span of the match covers the entire equation.
        -- That isn't quite right, but it'll do for now.
  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
-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
makeFunBind :: GenLocated SrcSpanAnnN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN 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 }

-- See Note [FunBind vs PatBind]
checkPatBind :: SrcSpan
             -> LPat GhcPs
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> [LHsModifier GhcPs]
             -> P (HsBind GhcPs)
checkPatBind :: SrcSpan
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> [LHsModifier 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) []
      = HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
-> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN 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 "!"
-> GenLocated SrcSpanAnnN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m XBangPat GhcPs
EpToken "!"
an XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN RdrName
v)]))
  where
    m :: EpToken "!"
-> GenLocated SrcSpanAnnN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m EpToken "!"
a GenLocated SrcSpanAnnN 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 :: GenLocated SrcSpanAnnN RdrName
mc_fun    = GenLocated SrcSpanAnnN 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) [LHsModifier GhcPs]
mods = 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
-> [LHsModifier GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> [LHsModifier idL]
-> GRHSs idR (LHsExpr idR)
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExtField
noExtField LPat GhcPs
lhs [LHsModifier GhcPs]
mods GRHSs GhcPs (LHsExpr GhcPs)
grhss)


checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (GenLocated SrcSpanAnnN RdrName)
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpanAnnA
l HsExpr GhcPs
lhs_expr) =
  case HsExpr GhcPs
lhs_expr of
    HsVar XVar GhcPs
_ lrdr :: LIdOccP GhcPs
lrdr@(L SrcSpanAnnN
_ RdrName
v) -> RdrName
-> GenLocated SrcSpanAnnN RdrName
-> P (GenLocated SrcSpanAnnN RdrName)
check_var RdrName
v LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
lrdr
    HsExpr GhcPs
_                    -> PsInvalidTypeSignature -> P (GenLocated SrcSpanAnnN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Other
  where
    check_var :: RdrName
-> GenLocated SrcSpanAnnN RdrName
-> P (GenLocated SrcSpanAnnN RdrName)
check_var RdrName
v GenLocated SrcSpanAnnN RdrName
lrdr
      | Bool -> Bool
not (RdrName -> Bool
isUnqual RdrName
v) = PsInvalidTypeSignature -> P (GenLocated SrcSpanAnnN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Qualified
      | OccName -> Bool
isDataOcc OccName
occ_n  = PsInvalidTypeSignature -> P (GenLocated SrcSpanAnnN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_DataCon
      | Bool
otherwise        = GenLocated SrcSpanAnnN RdrName
-> P (GenLocated SrcSpanAnnN RdrName)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnN RdrName
lrdr
      where occ_n :: OccName
occ_n = RdrName -> OccName
rdrNameOcc RdrName
v
    make_err :: PsInvalidTypeSignature -> P (GenLocated SrcSpanAnnN RdrName)
make_err PsInvalidTypeSignature
reason = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName))
-> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN 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 (PatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder GhcPs)], [EpToken "("], [EpToken ")"]))
isFunLhs LocatedA (PatBuilder GhcPs)
e = LocatedA (PatBuilder GhcPs)
-> [LocatedA (PatBuilder GhcPs)]
-> [EpToken "("]
-> [EpToken ")"]
-> P (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder GhcPs)], [EpToken "("], [EpToken ")"]))
forall {p} {m :: * -> *}.
(XInvisPat p ~ (EpToken "@", Specificity), NoGhcTc p ~ GhcPs,
 Monad m) =>
GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go LocatedA (PatBuilder GhcPs)
e [] [] []
 where
   go :: GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go (L SrcSpanAnnA
l (PatBuilderVar (L SrcSpanAnnN
loc RdrName
f))) [GenLocated SrcSpanAnnA (PatBuilder p)]
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
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
   [EpToken ")"])
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnN RdrName, LexicalFixity,
 [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
 [EpToken ")"])
-> Maybe
     (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
      [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
      [EpToken ")"])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
f, LexicalFixity
Prefix, [GenLocated SrcSpanAnnA (PatBuilder p)]
es, ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops), [EpToken ")"]
cps))
   go (L SrcSpanAnnA
l (PatBuilderApp (L SrcSpanAnnA
lf PatBuilder p
f) GenLocated SrcSpanAnnA (PatBuilder p)
e))   [GenLocated SrcSpanAnnA (PatBuilder p)]
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
     GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lf' PatBuilder p
f) (GenLocated SrcSpanAnnA (PatBuilder p)
eGenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (PatBuilder p)]
es) [EpToken "("]
ops [EpToken ")"]
cps
   go (L SrcSpanAnnA
l (PatBuilderPar EpToken "("
_ (L SrcSpanAnnA
le PatBuilder p
e) EpToken ")"
_)) es :: [GenLocated SrcSpanAnnA (PatBuilder p)]
es@(GenLocated SrcSpanAnnA (PatBuilder p)
_:[GenLocated SrcSpanAnnA (PatBuilder p)]
_) [EpToken "("]
ops [EpToken ")"]
cps = GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
le' PatBuilder p
e) [GenLocated SrcSpanAnnA (PatBuilder p)]
es (EpToken "("
oEpToken "(" -> [EpToken "("] -> [EpToken "("]
forall a. a -> [a] -> [a]
:[EpToken "("]
ops) (EpToken ")"
cEpToken ")" -> [EpToken ")"] -> [EpToken ")"]
forall a. a -> [a] -> [a]
:[EpToken ")"]
cps)
      -- NB: es@(_:_) means that there must be an arg after the parens for the
      -- LHS to be a function LHS. This corresponds to the Haskell Report's definition
      -- of funlhs.
     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 p
l) (L SrcSpanAnnN
loc' RdrName
op) GenLocated SrcSpanAnnA (PatBuilder p)
r ([EpToken "("]
os,[EpToken ")"]
cs))) [GenLocated SrcSpanAnnA (PatBuilder p)]
es [EpToken "("]
ops [EpToken ")"]
cps
      | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)         -- We have found the function!
      = 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
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
   [EpToken ")"])
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnN RdrName, LexicalFixity,
 [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
 [EpToken ")"])
-> Maybe
     (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
      [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
      [EpToken ")"])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op, LexicalFixity
Infix, ((SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ll' PatBuilder p
l)GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
:GenLocated SrcSpanAnnA (PatBuilder p)
rGenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (PatBuilder p)]
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                     -- Infix data con; keep going
      = 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 <- GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ll' PatBuilder p
l) [GenLocated SrcSpanAnnA (PatBuilder p)]
es [EpToken "("]
ops [EpToken ")"]
cps
           ; return (reassociate =<< mb_l) }
        where
          reassociate :: (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
 [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
 [EpToken ")"])
-> Maybe
     (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
      [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
      [EpToken ")"])
reassociate (GenLocated SrcSpanAnnN RdrName
op', LexicalFixity
Infix, GenLocated SrcSpanAnnA (PatBuilder p)
j : L SrcSpanAnnA
k_loc PatBuilder p
k : [GenLocated SrcSpanAnnA (PatBuilder p)]
es', [EpToken "("]
ops', [EpToken ")"]
cps')
            = (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
 [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
 [EpToken ")"])
-> Maybe
     (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
      [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
      [EpToken ")"])
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN RdrName
op', LexicalFixity
Infix, GenLocated SrcSpanAnnA (PatBuilder p)
j GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
: GenLocated SrcSpanAnnA (PatBuilder p)
op_app GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (PatBuilder p)]
es', [EpToken "("]
ops', [EpToken ")"]
cps')
            where
              op_app :: GenLocated SrcSpanAnnA (PatBuilder p)
op_app = SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnA (PatBuilder p)
-> ([EpToken "("], [EpToken ")"])
-> PatBuilder p
forall p.
LocatedA (PatBuilder p)
-> GenLocated SrcSpanAnnN RdrName
-> LocatedA (PatBuilder p)
-> ([EpToken "("], [EpToken ")"])
-> PatBuilder p
PatBuilderOpApp (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
k_loc PatBuilder p
k)
                                    (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op) GenLocated SrcSpanAnnA (PatBuilder p)
r ([EpToken "("] -> [EpToken "("]
forall a. [a] -> [a]
reverse [EpToken "("]
ops, [EpToken ")"]
cps))
          reassociate (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
 [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
 [EpToken ")"])
_other = Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
   [EpToken ")"])
forall a. Maybe a
Nothing
   go (L SrcSpanAnnA
l (PatBuilderAppType (L SrcSpanAnnA
lp PatBuilder p
pat) EpToken "@"
tok ty_pat :: HsTyPat GhcPs
ty_pat@(HsTP XHsTP GhcPs
_ (L (EpAnn EpaLocation
anc AnnListItem
ann EpAnnComments
cs) HsType GhcPs
_)))) [GenLocated SrcSpanAnnA (PatBuilder p)]
es [EpToken "("]
ops [EpToken ")"]
cps
             = GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [EpToken "("]
-> [EpToken ")"]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
go (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lp' PatBuilder p
pat) (SrcSpanAnnA
-> PatBuilder p -> GenLocated SrcSpanAnnA (PatBuilder p)
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 p -> PatBuilder p
forall p. Pat p -> PatBuilder p
PatBuilderPat Pat p
invis_pat) GenLocated SrcSpanAnnA (PatBuilder p)
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
-> [GenLocated SrcSpanAnnA (PatBuilder p)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (PatBuilder p)]
es) [EpToken "("]
ops [EpToken ")"]
cps
             where invis_pat :: Pat p
invis_pat = XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
forall p. XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
InvisPat (EpToken "@"
tok, Specificity
SpecifiedSpec) HsTyPat (NoGhcTc p)
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 GenLocated SrcSpanAnnA (PatBuilder p)
_ [GenLocated SrcSpanAnnA (PatBuilder p)]
_ [EpToken "("]
_ [EpToken ")"]
_ = Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
   [EpToken ")"])
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
         [EpToken ")"]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [GenLocated SrcSpanAnnA (PatBuilder p)], [EpToken "("],
   [EpToken ")"])
forall a. Maybe a
Nothing

mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy EpaLocation
tok_loc SrcStrictness
strictness LHsType GhcPs
lty =
  XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType ((EpaLocation, EpToken "#-}", EpaLocation)
-> HsSrcBang -> LHsType GhcPs -> HsTypeGhcPsExt
HsBangTy (EpaLocation
forall a. NoAnn a => a
noAnn, EpToken "#-}"
forall a. NoAnn a => a
noAnn, EpaLocation
tok_loc) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness) LHsType GhcPs
lty)

-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
  UnpackednessPragma (EpaLocation, EpToken "#-}") SourceText SrcUnpackedness

-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
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
    -- If we have a HsBangTy that only has a strictness annotation,
    -- such as ~T or !T, then add the pragma to the existing HsBangTy.
    --
    -- Otherwise, wrap the type in a new HsBangTy constructor.
    addUnpackedness :: (EpaLocation, EpToken "#-}")
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
addUnpackedness (EpaLocation
o,EpToken "#-}"
c) (L SrcSpanAnnA
_ (XHsType (HsBangTy (EpaLocation
_,EpToken "#-}"
_,EpaLocation
tl) HsSrcBang
bang LHsType GhcPs
t)))
      | HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness <- HsSrcBang
bang
      = XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType ((EpaLocation, EpToken "#-}", EpaLocation)
-> HsSrcBang -> LHsType GhcPs -> HsTypeGhcPsExt
HsBangTy (EpaLocation
o,EpToken "#-}"
c,EpaLocation
tl) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
strictness) LHsType GhcPs
t)
    addUnpackedness (EpaLocation
o,EpToken "#-}"
c) GenLocated SrcSpanAnnA (HsType GhcPs)
t
      = XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType ((EpaLocation, EpToken "#-}", EpaLocation)
-> HsSrcBang -> LHsType GhcPs -> HsTypeGhcPsExt
HsBangTy (EpaLocation
o,EpToken "#-}"
c,EpaLocation
forall a. NoAnn a => a
noAnn) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t)

---------------------------------------------------------------------------
-- | Check for monad comprehensions
--
-- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context

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

-- -------------------------------------------------------------------------
-- Expression/command/pattern ambiguity.
-- See Note [Ambiguous syntactic categories]
--

-- See Note [Ambiguous syntactic categories]
--
-- This newtype is required to avoid impredicative types in monadic
-- productions. That is, in a production that looks like
--
--    | ... {% return (ECP ...) }
--
-- we are dealing with
--    P ECP
-- whereas without a newtype we would be dealing with
--    P (forall b. DisambECP b => PV (Located b))
--
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)

-- The 'fbinds' parser rule produces values of this type. See Note
-- [RecordDotSyntax field updates].
type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))

-- | Disambiguate infix operators.
-- See Note [Ambiguous syntactic categories]
class DisambInfixOp b where
  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)
  mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)
  mkHsInfixHolePV :: LocatedN RdrName -> PV (LocatedN b)

instance DisambInfixOp (HsExpr GhcPs) where
  mkHsVarOpPV :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsVarOpPV GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnN RdrName
v) (XVar GhcPs -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
v)
  mkHsConOpPV :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsConOpPV GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnN RdrName
v) (XVar GhcPs -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
v)
  mkHsInfixHolePV :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsInfixHolePV GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnN RdrName
v) (XHole GhcPs -> HsExpr GhcPs
forall p. XHole p -> HsExpr p
HsHole (XRec GhcPs (IdP GhcPs) -> HoleKind
HoleVar XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN RdrName
v))

instance DisambInfixOp RdrName where
  mkHsConOpPV :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
mkHsConOpPV (L SrcSpanAnnN
l RdrName
v) = GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
 -> PV (GenLocated SrcSpanAnnN RdrName))
-> GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
  mkHsVarOpPV :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
mkHsVarOpPV (L SrcSpanAnnN
l RdrName
v) = GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
 -> PV (GenLocated SrcSpanAnnN RdrName))
-> GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
  mkHsInfixHolePV :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
mkHsInfixHolePV (L SrcSpanAnnN
l RdrName
_) = MsgEnvelope PsMessage -> PV (GenLocated SrcSpanAnnN RdrName)
forall a. MsgEnvelope PsMessage -> PV a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> PV (GenLocated SrcSpanAnnN RdrName))
-> MsgEnvelope PsMessage -> PV (GenLocated SrcSpanAnnN 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
    )

-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
-- parsing an expression, a command, or a pattern.
-- See Note [Ambiguous syntactic categories]
class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
  -- | See Note [Body in DisambECP]
  type Body b :: Type -> Type
  -- | Return a command without ambiguity, or fail in a non-command context.
  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
  -- | Return an expression without ambiguity, or fail in a non-expression context.
  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
  -- | Return a pattern without ambiguity, or fail in a non-pattern context.
  ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)
  mkHsProjUpdatePV :: SrcSpan -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
    -> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b))
  -- | Disambiguate "let ... in ..."
  mkHsLetPV
    :: SrcSpan
    -> EpToken "let"
    -> HsLocalBinds GhcPs
    -> EpToken "in"
    -> LocatedA b
    -> PV (LocatedA b)
  -- | Infix operator representation
  type InfixOp b
  -- | Bring superclass constraints on InfixOp into scope.
  -- See Note [UndecidableSuperClasses for associated types]
  superInfixOp
    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)
  -- | Disambiguate "f # x" (infix operator)
  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b
              -> PV (LocatedA b)
  -- | Disambiguate "case ... of ..."
  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)])
             -> EpAnnHsCase -> PV (LocatedA b)
  -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases"
  mkHsLamPV :: SrcSpan -> HsLamVariant
            -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam
            -> PV (LocatedA b)
  -- | Function argument representation
  type FunArg b
  -- | Bring superclass constraints on FunArg into scope.
  -- See Note [UndecidableSuperClasses for associated types]
  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)
  -- | Disambiguate "f x" (function application)
  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)
  -- | Disambiguate "f @t" (visible type application)
  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate "if ... then ... else ..."
  mkHsIfPV :: SrcSpan
         -> LHsExpr GhcPs
         -> Bool  -- semicolon?
         -> LocatedA b
         -> Bool  -- semicolon?
         -> LocatedA b
         -> AnnsIf
         -> PV (LocatedA b)
  -- | Disambiguate "do { ... }" (do notation)
  mkHsDoPV ::
    SrcSpan ->
    Maybe ModuleName ->
    LocatedLW [LStmt GhcPs (LocatedA b)] ->
    EpaLocation -> -- Token
    EpaLocation -> -- Anchor
    PV (LocatedA b)
  -- | Disambiguate "( ... )" (parentheses)
  mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)
  -- | Disambiguate a variable "f" or a data constructor "MkF".
  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)
  -- | Disambiguate a monomorphic literal
  mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b)
  -- | Disambiguate an overloaded literal
  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)
  -- | Disambiguate a qualified literal
  mkHsQualLitPV :: LocatedAn a (HsQualLit GhcPs) -> PV (LocatedAn a b)
  -- | Disambiguate a wildcard
  mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b)
  -- | Disambiguate "a :: t" (type annotation)
  mkHsTySigPV
    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b)
  -- | Disambiguate "[a,b,c]" (list syntax)
  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b)
  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
  mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)
  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
  mkHsRecordPV ::
    Bool -> -- Is OverloadedRecordUpdate in effect?
    SrcSpan ->
    SrcSpan ->
    LocatedA b ->
    ([Fbind b], Maybe SrcSpan) ->
    (Maybe (EpToken "{"), Maybe (EpToken "}")) ->
    PV (LocatedA b)
  -- | Disambiguate "-a" (negation)
  mkHsNegAppPV :: SrcSpan -> LocatedA b -> EpToken "-" -> PV (LocatedA b)
  -- | Disambiguate "(# a)" (right operator section)
  mkHsSectionR_PV
    :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)
  -- | Disambiguate "(a -> b)" (view pattern or function type arrow)
  mkHsArrowPV
    :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsModifiedFunArrOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)
  -- | Disambiguate "%m" to the left of "->" (multiplicity)
  mkHsMultPV
    :: Located [LHsModifierOf (LocatedA b) GhcPs] -> TokRarrow -> PV (HsModifiedFunArrOf (LocatedA b) GhcPs)
  -- | Disambiguate "forall a. b" and "forall a -> b" (forall telescope)
  mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b)
  -- | Disambiguate "(a,b,c)" to the left of "=>" (constraint list)
  checkContextPV :: LocatedA b -> PV (LocatedC [LocatedA b])
  -- | Disambiguate "a => b" (constraint context)
  mkQualPV :: SrcSpan -> LocatedC [LocatedA b] -> LocatedA b -> PV (LocatedA b)
  -- | Disambiguate "a@b" (as-pattern)
  mkHsAsPatPV
    :: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b)
  -- | Disambiguate "~a" (lazy pattern)
  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> EpToken "~" -> PV (LocatedA b)
  -- | Disambiguate "!a" (bang pattern)
  mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b)
  -- | Disambiguate tuple sections and unboxed sums
  mkSumOrTuplePV
    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b)
  -- | Disambiguate "type t" (embedded type)
  mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate modifiers (%a)
  mkHsModifiedPV
    :: SrcSpan -> [LHsModifier GhcPs] -> LocatedA b -> PV (LocatedA b)
  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
  rejectPragmaPV :: LocatedA b -> PV ()

{- Note [UndecidableSuperClasses for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(This Note is about the code in GHC, not about the user code that we are parsing)

Assume we have a class C with an associated type T:

  class C a where
    type T a
    ...

If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:

  {-# LANGUAGE UndecidableSuperClasses #-}
  class C (T a) => C a where
    type T a
    ...

Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes
making GHC loop. The workaround is to bring this constraint into scope
manually with a helper method:

  class C a where
    type T a
    superT :: (C (T a) => r) -> r

In order to avoid ambiguous types, 'r' must mention 'a'.

For consistency, we use this approach for all constraints on associated types,
even when -XUndecidableSuperClasses are not required.
-}

{- Note [Body in DisambECP]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that
require their argument to take a form of (body GhcPs) for some (body :: Type ->
*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the
superclass constraints of DisambECP.

The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop
this requirement. It is possible and would allow removing the type index of
PatBuilder, but leads to worse type inference, breaking some code in the
typechecker.
-}

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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located (NonEmpty (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
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 :: GenLocated SrcSpanAnnN 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)
  mkHsQualLitPV :: forall a.
LocatedAn a (HsQualLit GhcPs) -> PV (LocatedAn a (HsCmd GhcPs))
mkHsQualLitPV (L EpAnn a
l HsQualLit 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) (HsQualLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQualLit 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
<+> SDoc
dcolon 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
-> HsModifiedFunArrOf (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 HsModifiedFunArrOf (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  -- matching on the mode brings Outputable instances into scope
      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
<+> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> SDoc
forall mult (pass :: Pass).
(Outputable mult, OutputableBndrId pass) =>
HsModifiedFunArrOf mult (GhcPass pass) -> SDoc
pprHsModifiedFunArr HsModifiedFunArrOf (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
<+> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> SDoc
forall mult (pass :: Pass).
(Outputable mult, OutputableBndrId pass) =>
HsModifiedFunArrOf mult (GhcPass pass) -> SDoc
pprHsModifiedFunArr HsModifiedFunArrOf (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 :: Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
-> TokRarrow
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
mkHsMultPV Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
lMods TokRarrow
tok = case GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA
     (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
forall l e. GenLocated l e -> e
unLoc Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA
     (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
lMods of
    [] -> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a. a -> PV a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
 -> PV
      (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs))
-> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsModifiedFunArr (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
-> HsFunArr GhcPs
-> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
forall mult pass.
XHsModifiedFunArr mult pass
-> [LHsModifierOf mult pass]
-> HsFunArr pass
-> HsModifiedFunArrOf mult pass
HsModifiedFunArr NoExtField
XHsModifiedFunArr (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
noExtField [] (HsFunArr GhcPs
 -> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
-> HsFunArr GhcPs
-> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs
forall a b. (a -> b) -> a -> b
$ XHsStandardArr GhcPs -> HsFunArr GhcPs
forall pass. XHsStandardArr pass -> HsFunArr pass
HsStandardArr (TokRarrow -> EpArrowOrColon
EpArrow TokRarrow
tok)
    [GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
mods -> SrcSpan
-> SDoc
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail (GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA
     (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
-> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA
     (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
lMods) (SDoc
 -> PV
      (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs))
-> SDoc
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
-> SDoc
forall (p :: Pass) ty.
(OutputableBndrId p, Outputable ty) =>
[LHsModifierOf ty (GhcPass p)] -> SDoc
pprLHsModifiers [LHsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsCmd GhcPs)) GhcPs)]
mods
  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
-> GenLocated SrcSpanAnnN RdrName
-> EpToken "@"
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsAsPatPV SrcSpan
l GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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)
  mkHsModifiedPV :: SrcSpan
-> [LHsModifier GhcPs]
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsCmd GhcPs))
mkHsModifiedPV SrcSpan
l [LHsModifier GhcPs]
mods GenLocated SrcSpanAnnA (HsCmd GhcPs)
_ = 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
"modifiers" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LHsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs]
-> SDoc
forall (p :: Pass) ty.
(OutputableBndrId p, Outputable ty) =>
[LHsModifierOf ty (GhcPass p)] -> SDoc
pprLHsModifiers [LHsModifier GhcPs]
[LHsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs]
mods)
  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 HsExpr GhcPs
parseError)
  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 HsExpr GhcPs
parseError)
  mkHsProjUpdatePV :: SrcSpan
-> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located (NonEmpty (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
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 :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsVarPV v :: GenLocated SrcSpanAnnN 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)
  mkHsQualLitPV :: forall a.
LocatedAn a (HsQualLit GhcPs) -> PV (LocatedAn a (HsExpr GhcPs))
mkHsQualLitPV (L (EpAnn EpaLocation
l a
an EpAnnComments
csIn) HsQualLit 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)) (HsQualLit noExtField a)
  mkHsWildCardPV :: forall a. NoAnn a => SrcSpan -> PV (LocatedAn a (HsExpr GhcPs))
mkHsWildCardPV SrcSpan
l = GenLocated (EpAnn a) (HsExpr GhcPs)
-> PV (GenLocated (EpAnn a) (HsExpr GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (EpAnn a) (HsExpr GhcPs)
 -> PV (GenLocated (EpAnn a) (HsExpr GhcPs)))
-> GenLocated (EpAnn a) (HsExpr GhcPs)
-> PV (GenLocated (EpAnn a) (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a -> HsExpr GhcPs -> GenLocated (EpAnn a) (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnn a
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (XHole GhcPs -> HsExpr GhcPs
forall p. XHole p -> HsExpr p
HsHole (XRec GhcPs (IdP GhcPs) -> HoleKind
HoleVar (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"_")))))
  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
-> GenLocated SrcSpanAnnN RdrName
-> EpToken "@"
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsAsPatPV SrcSpan
l GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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) HsExpr GhcPs
parseError)
  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) HsExpr GhcPs
parseError)
  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) HsExpr GhcPs
parseError)
  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
-> HsModifiedFunArrOf (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 HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
arr GenLocated SrcSpanAnnA (HsExpr GhcPs)
res =
    -- In expressions, (e1 -> e2) is always parsed as a function type,
    -- even if ViewPatterns are enabled.
    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
-> HsModifiedFunArrOf (LHsExpr GhcPs) GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall p.
XFunArr p
-> HsModifiedFunArrOf (LHsExpr p) p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsFunArr XFunArr GhcPs
NoExtField
noExtField HsModifiedFunArrOf (LHsExpr GhcPs) GhcPs
HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
arr LHsExpr GhcPs
LocatedA lhs
arg LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
res
  mkHsMultPV :: Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
-> TokRarrow
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs)
mkHsMultPV Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
lMods TokRarrow
tok =
    HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
 -> PV
      (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs))
-> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> PV
     (HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsModifiedFunArr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
-> HsFunArr GhcPs
-> HsModifiedFunArrOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
forall mult pass.
XHsModifiedFunArr mult pass
-> [LHsModifierOf mult pass]
-> HsFunArr pass
-> HsModifiedFunArrOf mult pass
HsModifiedFunArr NoExtField
XHsModifiedFunArr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs
noExtField
                              ([LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
forall a. [a] -> [a]
reverse ([LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
 -> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs])
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
forall a b. (a -> b) -> a -> b
$ Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
-> [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
forall l e. GenLocated l e -> e
unLoc Located
  [LHsModifierOf (GenLocated SrcSpanAnnA (HsExpr GhcPs)) GhcPs]
lMods)
                              (XHsStandardArr GhcPs -> HsFunArr GhcPs
forall pass. XHsStandardArr pass -> HsFunArr pass
HsStandardArr (TokRarrow -> EpArrowOrColon
EpArrow TokRarrow
tok))
  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
  mkHsModifiedPV :: SrcSpan
-> [LHsModifier GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> PV (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mkHsModifiedPV SrcSpan
l [LHsModifier GhcPs]
_ GenLocated SrcSpanAnnA (HsExpr 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 SrcSpan
l (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SuggestModifiers -> PsMessage
PsErrModifierSyntax SuggestModifiers
DontSuggestModifiers
    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
parseError
  rejectPragmaPV :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
rejectPragmaPV (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
e)) =
    -- assuming left-associative parsing of operators
    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 ()

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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> LocatedA (PatBuilder GhcPs)
-> Bool
-> Maybe (EpToken "=")
-> PV (LHsRecProj GhcPs (LocatedA (PatBuilder GhcPs)))
mkHsProjUpdatePV SrcSpan
l Located (NonEmpty (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 :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedA (PatBuilder GhcPs))
mkHsVarPV v :: GenLocated SrcSpanAnnN RdrName
v@(GenLocated SrcSpanAnnN 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) (GenLocated SrcSpanAnnN RdrName -> PatBuilder GhcPs
forall p. GenLocated SrcSpanAnnN RdrName -> PatBuilder p
PatBuilderVar GenLocated SrcSpanAnnN 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) = GenLocated (EpAnn a) (PatBuilder GhcPs)
-> PV (GenLocated (EpAnn a) (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (EpAnn a) (PatBuilder GhcPs)
 -> PV (GenLocated (EpAnn a) (PatBuilder GhcPs)))
-> GenLocated (EpAnn a) (PatBuilder GhcPs)
-> PV (GenLocated (EpAnn a) (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a
-> PatBuilder GhcPs -> GenLocated (EpAnn 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)
  mkHsQualLitPV :: forall a.
LocatedAn a (HsQualLit GhcPs)
-> PV (LocatedAn a (PatBuilder GhcPs))
mkHsQualLitPV (L EpAnn a
l HsQualLit 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)))
-> (Pat GhcPs -> LocatedAn a (PatBuilder GhcPs))
-> Pat GhcPs
-> PV (LocatedAn a (PatBuilder GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn a -> PatBuilder GhcPs -> LocatedAn a (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L EpAnn a
l (PatBuilder GhcPs -> LocatedAn a (PatBuilder GhcPs))
-> (Pat GhcPs -> PatBuilder GhcPs)
-> Pat GhcPs
-> LocatedAn a (PatBuilder GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat GhcPs -> PatBuilder GhcPs
Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (Pat GhcPs -> PV (LocatedAn a (PatBuilder GhcPs)))
-> Pat GhcPs -> PV (LocatedAn a (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ XQualLitPat GhcPs -> HsQualLit GhcPs -> Pat GhcPs
forall p. XQualLitPat p -> HsQualLit p -> Pat p
QualLitPat XQualLitPat GhcPs
NoExtField
noExtField HsQualLit GhcPs
a
  mkHsWildCardPV :: forall a. NoAnn a => SrcSpan -> PV (LocatedAn a (PatBuilder GhcPs))
mkHsWildCardPV SrcSpan
l = GenLocated (EpAnn a) (PatBuilder GhcPs)
-> PV (GenLocated (EpAnn a) (PatBuilder GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (EpAnn a) (PatBuilder GhcPs)
 -> PV (GenLocated (EpAnn a) (PatBuilder GhcPs)))
-> GenLocated (EpAnn a) (PatBuilder GhcPs)
-> PV (GenLocated (EpAnn a) (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn a
-> PatBuilder GhcPs -> GenLocated (EpAnn 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
-> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (PatBuilder GhcPs)
ArrowIsViewPat LocatedA lhs
a HsModifiedFunArrOf (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 HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr of
        HsModifiedFunArr XHsModifiedFunArr (LocatedA (PatBuilder GhcPs)) GhcPs
_ [] (HsStandardArr (EpArrow TokRarrow
x)) -> TokRarrow
x
        HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
_ -> -- unreachable case because in Parser.y the reduction rules for
             -- (a %m -> b) and (a ->. b) use ArrowIsFunType
             String -> TokRarrow
forall a. HasCallStack => String -> a
panic String
"mkHsArrowPV ArrowIsViewPat: expected HsModifiedFunArr _ [] (HsStandardArr _)"
  mkHsArrowPV SrcSpan
l ArrowParsingMode lhs (PatBuilder GhcPs)
ArrowIsFunType LocatedA lhs
a HsModifiedFunArrOf (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)
-> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> LocatedA (PatBuilder GhcPs)
-> PsErrTypeSyntaxDetails
PETS_FunctionArrow LocatedA lhs
LocatedA (PatBuilder GhcPs)
a HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
arr LocatedA (PatBuilder GhcPs)
b))
  mkHsMultPV :: Located [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
-> TokRarrow
-> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
mkHsMultPV Located [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
lMods TokRarrow
tok = case GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
forall l e. GenLocated l e -> e
unLoc Located [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
lMods of
    [] -> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
forall a. a -> PV a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
 -> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs))
-> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
-> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsModifiedFunArr (LocatedA (PatBuilder GhcPs)) GhcPs
-> [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
-> HsFunArr GhcPs
-> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
forall mult pass.
XHsModifiedFunArr mult pass
-> [LHsModifierOf mult pass]
-> HsFunArr pass
-> HsModifiedFunArrOf mult pass
HsModifiedFunArr NoExtField
XHsModifiedFunArr (LocatedA (PatBuilder GhcPs)) GhcPs
noExtField [] (HsFunArr GhcPs
 -> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
-> HsFunArr GhcPs
-> HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs
forall a b. (a -> b) -> a -> b
$ XHsStandardArr GhcPs -> HsFunArr GhcPs
forall pass. XHsStandardArr pass -> HsFunArr pass
HsStandardArr (TokRarrow -> EpArrowOrColon
EpArrow TokRarrow
tok)
    [GenLocated
   SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
mods -> SrcSpan
-> PsMessage
-> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
forall a. SrcSpan -> PsMessage -> PV a
patFail (GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
-> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
GenLocated
  SrcSpan
  [GenLocated
     SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
lMods) (PsMessage
 -> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs))
-> PsMessage
-> PV (HsModifiedFunArrOf (LocatedA (PatBuilder GhcPs)) GhcPs)
forall a b. (a -> b) -> a -> b
$ PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxDetails -> PsMessage
PsErrTypeSyntaxInPat (PsErrTypeSyntaxDetails -> PsMessage)
-> PsErrTypeSyntaxDetails -> PsMessage
forall a b. (a -> b) -> a -> b
$ [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
-> PsErrTypeSyntaxDetails
PETS_Multiplicity [LHsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs]
[GenLocated
   SrcSpanAnnA (HsModifierOf (LocatedA (PatBuilder GhcPs)) GhcPs)]
mods
  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)
_ =  -- unreachable because mkQualPV is only called on the result
                    -- of checkContextPV, which fails in patterns
                  String -> PV (LocatedA (PatBuilder GhcPs))
forall a. HasCallStack => String -> a
panic String
"mkQualPV in a pattern"
  mkHsAsPatPV :: SrcSpan
-> GenLocated SrcSpanAnnN RdrName
-> EpToken "@"
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsAsPatPV SrcSpan
l GenLocated SrcSpanAnnN 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))
  mkHsModifiedPV :: SrcSpan
-> [LHsModifier GhcPs]
-> LocatedA (PatBuilder GhcPs)
-> PV (LocatedA (PatBuilder GhcPs))
mkHsModifiedPV SrcSpan
l [LHsModifier GhcPs]
mods LocatedA (PatBuilder GhcPs)
p = do
    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) ([LHsModifier GhcPs]
-> LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p.
[LHsModifier p] -> LocatedA (PatBuilder p) -> PatBuilder p
PatBuilderModifiers [LHsModifier GhcPs]
mods LocatedA (PatBuilder GhcPs)
p)
  rejectPragmaPV :: LocatedA (PatBuilder GhcPs) -> PV ()
rejectPragmaPV LocatedA (PatBuilder GhcPs)
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- For reasons of backwards compatibility, we can't simply add the pattern
-- signature if the inner pattern is a view pattern. Consider:
--      (f -> p :: t)
-- There are two ways to parse it
--      (f -> (p :: t))   -- legacy parse
--      ((f -> p) :: t)   -- future parse
-- The grammar in Parser.y is structured in such a way that we get the
-- future parse by default. Until we're ready to make the breaking change,
-- we need to do some extra work here to push the signature under the view
-- pattern (and emit a warning).
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 =
  -- Test case: T24159_viewpat
  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)

    -- Test case for comments and locations preservation: Test24159
    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 = GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> PV a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat 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
  GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat 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)

{- Note [Arrow parsing mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example:
  f (K (a -> b)) = ()

A pattern of the form (a -> b) could be parsed in one of two ways:
  * a view pattern `viewfn -> pat` (with ViewPatterns)
  * a function type `t1 -> t2`     (with RequiredTypeArguments)

This depends on the enabled extensions:
  NoViewPatterns, RequiredTypeArguments     =>  function type
  NoViewPatterns, NoRequiredTypeArguments   =>  error (suggest ViewPatterns)
  ViewPatterns,   RequiredTypeArguments     =>  view pattern
  ViewPatterns,   NoRequiredTypeArguments   =>  view pattern

The decision how to parse arrow patterns (p1 -> p2) is captured by the
`ArrowParsingMode` data type, produced in `withArrowParsingMode` and
consumed in `mkHsArrowPV`.

Naively, one might expect to see the following definition:

  -- a simple (but insufficient) definition
  data ArrowParsingMode = ArrowIsViewPat | ArrowIsFunType

However, there is a slight complication that leads us to parameterize these
constructor with GADT type indices. In a pattern (p1 -> p2), what is the AST
type to represent the LHS `p1`? It depends:
  * if (p1 -> p2) is a view pattern,  `p1` is an HsExpr
  * if (p1 -> p2) is a function type, `p1` is a  Pat (PatBuilder)

And since the decision how to parse `p1` depends on the arrow parsing mode, we
could try to encode the LHS type as a GADT index:

  -- a less simple (but still insufficient) definition
  data ArrowParsingMode lhs where
    ArrowIsViewPat :: ArrowParsingMode (PatBuilder GhcPs)
    ArrowIsFunType :: ArrowParsingMode (HsExpr GhcPs)

This definition would suffice for parsing patterns, but remember that
expressions, commands, and patterns are all parsed using a unified framework
`DisambECP`, as described in Note [Ambiguous syntactic categories].

In an expression (e1 -> e2), the LHS is always represented by an HsExpr.
We can account for this with a further refinement of the definition:

  -- actual definition
  data ArrowParsingMode lhs rhs where
    ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b
    ArrowIsFunType :: ArrowParsingMode b b

So when parsing a view pattern, the LHS is an HsExpr; and when parsing a
function type, the type of the LHS is assumed to match the type of the RHS,
which works out just right both for expressions and patterns.
-}

-- The arrow parsing mode is selected depending on the enabled extensions and
-- determines how we parse patterns of the form (p1 -> p2). See Note [Arrow parsing mode]
data ArrowParsingMode lhs rhs where
  ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b   -- the LHS is always of type HsExpr
  ArrowIsFunType :: ArrowParsingMode b b                -- the LHS is of the same type as RHS

-- When parsing an expression (e1 -> e2), the LHS `e1` is an HsExpr regardless of
-- the arrow parsing mode. `exprArrowParsingMode` proves this to the type checker.
-- See Note [Arrow parsing mode]
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

-- Check the enabled extensions and select the appropriate ArrowParsingMode,
-- then pass it to a continuation. See Note [Arrow parsing mode]
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 -- Error message should suggest ViewPatterns in patterns

-- Type-restricted variant of `withArrowParsingMode` to aid type inference (#25103)
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 (LocatedA b))
-> PV (LocatedA b)
forall b r.
DisambECP b =>
(forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r)
-> PV r
withArrowParsingMode

mkStarPV :: DisambECP b => TokStar -> PV (LocatedA b)
mkStarPV :: forall b. DisambECP b => EpUniToken "*" "\9733" -> PV (LocatedA b)
mkStarPV EpUniToken "*" "\9733"
tok = do
  SrcSpan -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> m ()
warnStarIsType (EpUniToken "*" "\9733" -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpUniToken "*" "\9733"
tok)
  ECP -> forall b. DisambECP b => PV (LocatedA b)
unECP (ECP -> forall b. DisambECP b => PV (LocatedA b))
-> ECP -> forall b. DisambECP b => PV (LocatedA b)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> ECP
ecpFromExp (LHsExpr GhcPs -> ECP) -> LHsExpr GhcPs -> ECP
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (EpUniToken "*" "\9733" -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l EpUniToken "*" "\9733"
tok) (XStar GhcPs -> HsExpr GhcPs
forall p. XStar p -> HsExpr p
HsStar XStar GhcPs
EpUniToken "*" "\9733"
tok)

-- When a forall-type occurs in term syntax, forall-bound variables should
-- inhabit the term namespace `varName` rather than the usual `tvName`.
-- See Note [Types in terms].
--
-- Since type variable binders in a `HsForAllTelescope` produced by the
-- `forall_telescope` nonterminal have their namespaces set to `tvName`,
-- we use `setTelescopeBndrsNameSpace` to fix them up.
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 -> GenLocated SrcSpanAnnN 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

-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.
checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedLitPat (L SrcSpan
loc HsLit GhcPs
lit) =
  case HsLit GhcPs
lit of
    -- Don't allow primitive string literal patterns.
    -- See #13260.
    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)

   -- Don't allow Float#/Double# literal patterns.
   -- See #9238 and Note [Rules for floating-point comparisons]
   -- in GHC.Core.Opt.ConstantFold.
    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 GenLocated SrcSpanAnnN 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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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))

-- | Disambiguate constructs that may appear when we do not know
-- ahead of time whether we are parsing a type or a newtype/data constructor.
--
-- See Note [Ambiguous syntactic categories] for the general idea.
--
-- See Note [Parsing data constructors is hard] for the specific issue this
-- particular class is solving.
--
class DisambTD b where
  -- | Process the head of a type-level function/constructor application,
  -- i.e. the @H@ in @H a b c@.
  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate @f x@ (function application or prefix data constructor).
  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate @f \@t@ (visible kind application)
  mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate @f \# x@ (infix operator)
  mkHsOpTyPV :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> PV (LocatedA b)
  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
  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 :: LHsType GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> PV (GenLocated SrcSpanAnnA (HsType GhcPs))
mkHsOpTyPV LHsType GhcPs
t1 LHsType GhcPs
tyop LHsType GhcPs
t2 = do
    let (L SrcSpanAnnA
l HsType GhcPs
ty) = LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
t1 LHsType GhcPs
tyop 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 -> GenLocated SrcSpanAnnN RdrName
dataConBuilderCon (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
_ GenLocated SrcSpanAnnN RdrName
dc)) = GenLocated SrcSpanAnnN RdrName
dc
dataConBuilderCon (L SrcSpanAnnA
_ (InfixDataConBuilder LHsType GhcPs
_ GenLocated SrcSpanAnnN RdrName
dc LHsType GhcPs
_)) = GenLocated SrcSpanAnnN RdrName
dc

dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs

-- Detect when the record syntax is used:
--   data T = MkT { ... }
dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
dataConBuilderDetails (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds GenLocated SrcSpanAnnN RdrName
_))
  | [L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
cs) (XHsType (HsRecTy AnnList ()
an [LHsConDeclRecField 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 (HsConDeclRecField GhcPs)]
-> HsConDetails
     (HsConDeclField GhcPs)
     (GenLocated
        (EpAnn (AnnList ()))
        [GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)])
forall arg rec. rec -> HsConDetails arg rec
RecCon (EpAnn (AnnList ())
-> [GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)]
-> GenLocated
     (EpAnn (AnnList ()))
     [GenLocated SrcSpanAnnA (HsConDeclRecField 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 AnnList ()
an EpAnnComments
cs) [LHsConDeclRecField GhcPs]
[GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)]
fields)

-- Normal prefix constructor, e.g.  data T = MkT A B C
dataConBuilderDetails (L SrcSpanAnnA
_ (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds GenLocated SrcSpanAnnN RdrName
_))
  = [HsConDeclField GhcPs]
-> HsConDetails
     (HsConDeclField GhcPs)
     (GenLocated
        (EpAnn (AnnList ()))
        [GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((GenLocated SrcSpanAnnA (HsType GhcPs) -> HsConDeclField GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsConDeclField GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsConDeclField GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsConDeclField GhcPs
hsPlainTypeField (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))

-- Infix constructor, e.g. data T = Int :! Bool
dataConBuilderDetails (L (EpAnn EpaLocation
_ AnnListItem
_ EpAnnComments
csl) (InfixDataConBuilder (L (EpAnn EpaLocation
anc AnnListItem
ann EpAnnComments
csll) HsType GhcPs
lhs) GenLocated SrcSpanAnnN RdrName
_ LHsType GhcPs
rhs))
  = HsConDeclField GhcPs
-> HsConDeclField GhcPs
-> HsConDetails
     (HsConDeclField GhcPs)
     (GenLocated
        (EpAnn (AnnList ()))
        [GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)])
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (LHsType GhcPs -> HsConDeclField GhcPs
hsPlainTypeField (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)) (LHsType GhcPs -> HsConDeclField GhcPs
hsPlainTypeField LHsType 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 GenLocated SrcSpanAnnN 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)
-> GenLocated SrcSpanAnnN 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) GenLocated SrcSpanAnnN RdrName
fn)
  mkHsAppTyPV (L SrcSpanAnnA
_ InfixDataConBuilder{}) LHsType GhcPs
_ =
    -- This case is impossible because of the way
    -- the grammar in Parser.y is written (see infixtype/ftype).
    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 :: LHsType GhcPs
-> LHsType GhcPs -> LHsType GhcPs -> PV (LocatedA DataConBuilder)
mkHsOpTyPV LHsType GhcPs
lhs op :: LHsType GhcPs
op@(L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
prom LIdOccP GhcPs
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)  -- check the RHS because parsing type operators is right-associative
      data_con <- Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
-> PV (GenLocated SrcSpanAnnN RdrName)
forall (m :: * -> *) a.
MonadP m =>
Either (MsgEnvelope PsMessage) a -> m a
eitherToP (Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
 -> PV (GenLocated SrcSpanAnnN RdrName))
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
tyConToDataCon LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
tc
      !cs <- getCommentsFor (locA l)
      checkNotPromotedDataCon (getLocA op) 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 (XHsType (HsBangTy (EpaLocation, EpToken "#-}", EpaLocation)
_ HsSrcBang
_ 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) (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdOccP GhcPs
GenLocated SrcSpanAnnN 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 ()
  mkHsOpTyPV LHsType GhcPs
_ (L SrcSpanAnnA
l (HsWildCardTy XWildCardTy GhcPs
_)) LHsType GhcPs
_ =
    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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
PsErrInvalidInfixHole
  mkHsOpTyPV LHsType GhcPs
_ LHsType GhcPs
op LHsType GhcPs
_ = String -> SDoc -> PV (LocatedA DataConBuilder)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkHsOpTyPV: impossible type operator" (GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
op)

  mkUnpackednessPV :: Located UnpackednessPragma
-> LocatedA DataConBuilder -> PV (LocatedA DataConBuilder)
mkUnpackednessPV Located UnpackednessPragma
unpk LocatedA DataConBuilder
constr_stuff
    | L SrcSpanAnnA
_ (InfixDataConBuilder LHsType GhcPs
lhs GenLocated SrcSpanAnnN RdrName
data_con LHsType GhcPs
rhs) <- LocatedA DataConBuilder
constr_stuff
    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool
      --   we apply {-# UNPACK #-} to the LHS
      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 LIdOccP GhcPs
v)) = do
  data_con <- Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
-> PV (GenLocated SrcSpanAnnN RdrName)
forall (m :: * -> *) a.
MonadP m =>
Either (MsgEnvelope PsMessage) a -> m a
eitherToP (Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
 -> PV (GenLocated SrcSpanAnnN RdrName))
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
-> PV (GenLocated SrcSpanAnnN RdrName)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)
tyConToDataCon LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
v
  checkNotPromotedDataCon (locA l) 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 :: GenLocated SrcSpanAnnN RdrName
data_con = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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)
-> GenLocated SrcSpanAnnN 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) GenLocated SrcSpanAnnN RdrName
data_con)
tyToDataConBuilder (L SrcSpanAnnA
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsUnboxedTuple [LHsType GhcPs]
ts)) = do
  let data_con :: GenLocated SrcSpanAnnN RdrName
data_con = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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)
-> GenLocated SrcSpanAnnN 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) GenLocated SrcSpanAnnN 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))

-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).
checkNotPromotedDataCon
  :: SrcSpan          -- ^ The enclosing SrcSpan containing the tick
  -> PromotionFlag
  -> LocatedN RdrName
  -> PV ()
checkNotPromotedDataCon :: SrcSpan -> PromotionFlag -> GenLocated SrcSpanAnnN RdrName -> PV ()
checkNotPromotedDataCon SrcSpan
_   PromotionFlag
NotPromoted GenLocated SrcSpanAnnN RdrName
_ = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNotPromotedDataCon SrcSpan
loc PromotionFlag
IsPromoted (L SrcSpanAnnN
_ 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 SrcSpan
loc (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
-> (GenLocated SrcSpanAnnN RdrName, HsConDeclH98Details GhcPs)
mkUnboxedSumCon LHsType GhcPs
t Int
tag Int
arity =
  (RdrName -> GenLocated SrcSpanAnnN 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)), [HsConDeclField GhcPs]
-> HsConDetails
     (HsConDeclField GhcPs)
     (GenLocated
        (EpAnn (AnnList ()))
        [GenLocated SrcSpanAnnA (HsConDeclRecField GhcPs)])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcPs -> HsConDeclField GhcPs
hsPlainTypeField LHsType GhcPs
t])

{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are places in the grammar where we do not know whether we are parsing an
expression or a pattern without unlimited lookahead (which we do not have in
'happy'):

View patterns:

    f (Con a b     ) = ...  -- 'Con a b' is a pattern
    f (Con a b -> x) = ...  -- 'Con a b' is an expression

do-notation:

    do { Con a b <- x } -- 'Con a b' is a pattern
    do { Con a b }      -- 'Con a b' is an expression

Guards:

    x | True <- p && q = ...  -- 'True' is a pattern
    x | True           = ...  -- 'True' is an expression

Top-level value/function declarations (FunBind/PatBind):

    f ! a         -- TH splice
    f ! a = ...   -- function declaration

    Until we encounter the = sign, we don't know if it's a top-level
    TemplateHaskell splice where ! is used, or if it's a function declaration
    where ! is bound.

There are also places in the grammar where we do not know whether we are
parsing an expression or a command:

    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression
    proc x -> do { (stuff) }        -- 'stuff' is a command

    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'
    as an expression or a command.

In fact, do-notation is subject to both ambiguities:

    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression
    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern
    proc x -> do { (stuff) }             -- 'stuff' is a command

There are many possible solutions to this problem. For an overview of the ones
we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]

The solution that keeps basic definitions (such as HsExpr) clean, keeps the
concerns local to the parser, and does not require duplication of hsSyn types,
or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):

    class DisambECP b where ...
    instance DisambECP (HsCmd GhcPs) where ...
    instance DisambECP (HsExp GhcPs) where ...
    instance DisambECP (PatBuilder GhcPs) where ...

The 'DisambECP' class contains functions to build and validate 'b'. For example,
to add parentheses we have:

  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for
expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,
see Note [PatBuilder]).

Consider the 'alts' production used to parse case-of alternatives:

  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

We abstract over LHsExpr GhcPs, and it becomes:

  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }
    : alts1     { $1 >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { $2 >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Compared to the initial definition, the added bits are:

    forall b. DisambECP b => PV ( ... ) -- in the type signature
    $1 >>= \ $1 -> return $             -- in one reduction rule
    $2 >>= \ $2 -> return $             -- in another reduction rule

The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions.

Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding
position and shadows the previous $1. We can do this because internally
'happy' desugars $n to happy_var_n, and the rationale behind this idiom
is to be able to write (sLL $1 $>) later on. The alternative would be to
write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
to the last fresh name as $>.

Finally, we instantiate the polymorphic type to a concrete one, and run the
parser-validator, for example:

    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
            : stmt {% runPV $1 }

In e_stmt, three things happen:

  1. we instantiate: b ~ HsExpr GhcPs
  2. we embed the PV computation into P by using runPV
  3. we run validation by using a monadic production, {% ... }

At this point the ambiguity is resolved.
-}


{- Note [Resolving parsing ambiguities: non-taken alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Alternative I, extra constructors in GHC.Hs.Expr
------------------------------------------------
We could add extra constructors to HsExpr to represent command-specific and
pattern-specific syntactic constructs. Under this scheme, we parse patterns
and commands as expressions and rejig later.  This is what GHC used to do, and
it polluted 'HsExpr' with irrelevant constructors:

  * for commands: 'HsArrForm', 'HsArrApp'
  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'

(As of now, we still do that for patterns, but we plan to fix it).

There are several issues with this:

  * The implementation details of parsing are leaking into hsSyn definitions.

  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.

  * HsExpr is arbitrarily selected as the extension basis. Why not extend
    HsCmd or HsPat with extra constructors instead?

Alternative II, extra constructors in GHC.Hs.Expr for GhcPs
-----------------------------------------------------------
We could address some of the problems with Alternative I by using Trees That
Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to
the output of parsing, not to its intermediate results, so we wouldn't want
them there either.

Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs
---------------------------------------------------------------
We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.
Unfortunately, creating a new pass would significantly bloat conversion code
and slow down the compiler by adding another linear-time pass over the entire
AST. For example, in order to build HsExpr GhcPrePs, we would need to build
HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds
GhcPrePs.


Alternative IV, sum type and bottom-up data flow
------------------------------------------------
Expressions and commands are disjoint. There are no user inputs that could be
interpreted as either an expression or a command depending on outer context:

  5        -- definitely an expression
  x -< y   -- definitely a command

Even though we have both 'HsLam' and 'HsCmdLam', we can look at
the body to disambiguate:

  \p -> 5        -- definitely an expression
  \p -> x -< y   -- definitely a command

This means we could use a bottom-up flow of information to determine
whether we are parsing an expression or a command, using a sum type
for intermediate results:

  Either (LHsExpr GhcPs) (LHsCmd GhcPs)

There are two problems with this:

  * We cannot handle the ambiguity between expressions and
    patterns, which are not disjoint.

  * Bottom-up flow of information leads to poor error messages. Consider

        if ... then 5 else (x -< y)

    Do we report that '5' is not a valid command or that (x -< y) is not a
    valid expression?  It depends on whether we want the entire node to be
    'HsIf' or 'HsCmdIf', and this information flows top-down, from the
    surrounding parsing context (are we in 'proc'?)

Alternative V, backtracking with parser combinators
---------------------------------------------------
One might think we could sidestep the issue entirely by using a backtracking
parser and doing something along the lines of (try pExpr <|> pPat).

Turns out, this wouldn't work very well, as there can be patterns inside
expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns
(e.g. view patterns). To handle this, we would need to backtrack while
backtracking, and unbound levels of backtracking lead to very fragile
performance.

Alternative VI, an intermediate data type
-----------------------------------------
There are common syntactic elements of expressions, commands, and patterns
(e.g. all of them must have balanced parentheses), and we can capture this
common structure in an intermediate data type, Frame:

data Frame
  = FrameVar RdrName
    -- ^ Identifier: Just, map, BS.length
  | FrameTuple [LTupArgFrame] Boxity
    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)
  | FrameTySig LFrame (LHsSigWcType GhcPs)
    -- ^ Type signature: x :: ty
  | FramePar (SrcSpan, SrcSpan) LFrame
    -- ^ Parentheses
  | FrameIf LFrame LFrame LFrame
    -- ^ If-expression: if p then x else y
  | FrameCase LFrame [LFrameMatch]
    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
  | FrameDo HsStmtContextRn [LFrameStmt]
    -- ^ Do-expression: do { s1; a <- s2; s3 }
  ...
  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression
  | FramePat (HsPat GhcPs)     -- unambiguously a pattern
  | FrameCommand (HsCmd GhcPs) -- unambiguously a command

To determine which constructors 'Frame' needs to have, we take the union of
intersections between HsExpr, HsCmd, and HsPat.

The intersection between HsPat and HsExpr:

  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...
  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...
  -------------------------------------------------------------------
  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...

The intersection between HsCmd and HsExpr:

  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar
  HsExpr = HsIf    | HsCase    | HsDo    | HsPar
  ------------------------------------------------
  Frame = FrameIf  | FrameCase | FrameDo | FramePar

The intersection between HsCmd and HsPat:

  HsPat  = ParPat   | ...
  HsCmd  = HsCmdPar | ...
  -----------------------
  Frame  = FramePar | ...

Take the union of each intersection and this yields the final 'Frame' data
type. The problem with this approach is that we end up duplicating a good
portion of hsSyn:

    Frame         for  HsExpr, HsPat, HsCmd
    TupArgFrame   for  HsTupArg
    FrameMatch    for  Match
    FrameStmt     for  StmtLR
    FrameGRHS     for  GRHS
    FrameGRHSs    for  GRHSs
    ...

Alternative VII, a product type
-------------------------------
We could avoid the intermediate representation of Alternative VI by parsing
into a product of interpretations directly:

    type ExpCmdPat = ( PV (LHsExpr GhcPs)
                     , PV (LHsCmd GhcPs)
                     , PV (LHsPat GhcPs) )

This means that in positions where we do not know whether to produce
expression, a pattern, or a command, we instead produce a parser-validator for
each possible option.

Then, as soon as we have parsed far enough to resolve the ambiguity, we pick
the appropriate component of the product, discarding the rest:

    checkExpOf3 (e, _, _) = e  -- interpret as an expression
    checkCmdOf3 (_, c, _) = c  -- interpret as a command
    checkPatOf3 (_, _, p) = p  -- interpret as a pattern

We can easily define ambiguities between arbitrary subsets of interpretations.
For example, when we know ahead of time that only an expression or a command is
possible, but not a pattern, we can use a smaller type:

    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))

    checkExpOf2 (e, _) = e  -- interpret as an expression
    checkCmdOf2 (_, c) = c  -- interpret as a command

However, there is a slight problem with this approach, namely code duplication
in parser productions. Consider the 'alts' production used to parse case-of
alternatives:

  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Under the new scheme, we have to completely duplicate its type signature and
each reduction rule:

  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression
            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command
            ) }
    : alts1
        { ( checkExpOf2 $1 >>= \ $1 ->
            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
          , checkCmdOf2 $1 >>= \ $1 ->
            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
          ) }
    | ';' alts
        { ( checkExpOf2 $2 >>= \ $2 ->
            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
          , checkCmdOf2 $2 >>= \ $2 ->
            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
          ) }

And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!

Alternative VIII, a function from a GADT
----------------------------------------
We could avoid code duplication of the Alternative VII by representing the product
as a function from a GADT:

    data ExpCmdG b where
      ExpG :: ExpCmdG HsExpr
      CmdG :: ExpCmdG HsCmd

    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))

    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
    checkExp f = f ExpG  -- interpret as an expression
    checkCmd f = f CmdG  -- interpret as a command

Consider the 'alts' production used to parse case-of alternatives:

  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

We abstract over LHsExpr, and it becomes:

  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }
    : alts1
        { \tag -> $1 tag >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts
        { \tag -> $2 tag >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Note that 'ExpCmdG' is a singleton type, the value is completely
determined by the type:

  when (b~HsExpr),  tag = ExpG
  when (b~HsCmd),   tag = CmdG

This is a clear indication that we can use a class to pass this value behind
the scenes:

  class    ExpCmdI b      where expCmdG :: ExpCmdG b
  instance ExpCmdI HsExpr where expCmdG = ExpG
  instance ExpCmdI HsCmd  where expCmdG = CmdG

And now the 'alts' production is simplified, as we no longer need to
thread 'tag' explicitly:

  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }
    : alts1     { $1 >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { $2 >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

This encoding works well enough, but introduces an extra GADT unlike the
tagless final encoding, and there's no need for this complexity.

-}

{- Note [PatBuilder]
~~~~~~~~~~~~~~~~~~~~
Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,
so we introduce the notion of a PatBuilder.

Consider a pattern like this:

  Con a b c

We parse arguments to "Con" one at a time in the  fexp aexp  parser production,
building the result with mkHsAppPV, so the intermediate forms are:

  1. Con
  2. Con a
  3. Con a b
  4. Con a b c

In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like
this (pseudocode):

  1. "Con"
  2. HsApp "Con" "a"
  3. HsApp (HsApp "Con" "a") "b"
  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"

Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have
instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for
the intermediate forms.

We also need an intermediate representation to postpone disambiguation between
FunBind and PatBind. Consider:

  a `Con` b = ...
  a `fun` b = ...

How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We
learn this by inspecting an intermediate representation in 'isFunLhs' and
seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate
representation capable of representing both a FunBind and a PatBind, so Pat is
insufficient.

PatBuilder is an extension of Pat that is capable of representing intermediate
parsing results for patterns and function bindings:

  data PatBuilder p
    = PatBuilderPat (Pat p)
    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))
    ...

It can represent any pattern via 'PatBuilderPat', but it also has a variety of
other constructors which were added by following a simple principle: we never
pattern match on the pattern stored inside 'PatBuilderPat'.
-}

---------------------------------------------------------------------------
-- Miscellaneous utilities

-- | Check if a fixity is valid. We support bypassing the usual bound checks
-- for some special operators.
checkPrecP
        :: Located (SourceText,Int)              -- ^ precedence
        -> Located (OrdList (LocatedN RdrName))  -- ^ operators
        -> P ()
checkPrecP :: Located (SourceText, Int)
-> Located (OrdList (GenLocated SrcSpanAnnN RdrName)) -> P ()
checkPrecP (L SrcSpan
l (SourceText
_,Int
i)) (L SrcSpan
_ OrdList (GenLocated SrcSpanAnnN 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 ()
 | (GenLocated SrcSpanAnnN RdrName -> Bool)
-> OrdList (GenLocated SrcSpanAnnN RdrName) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnN RdrName -> Bool
forall {l}. GenLocated l RdrName -> Bool
specialOp OrdList (GenLocated SrcSpanAnnN 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
    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
    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 (GenLocated SrcSpanAnnN RdrName
-> HsRecordBinds GhcPs
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> HsExpr GhcPs
mkRdrRecordCon (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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
  -- We do not need to know if OverloadedRecordDot is in effect. We do
  -- however need to know if OverloadedRecordUpdate (passed in
  -- overloaded_on) is in effect because it affects the Left/Right nature
  -- of the RecordUpd value we calculate.
  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 ->
      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.
      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 ->
      -- This is just a regular record update.
      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' } }
    -- This is a RecordDotSyntax update.
    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 })

    -- Convert a top-level field update like {foo=2} or {bar} (punned)
    -- to a projection update.
    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)) =
        -- The idea here is to convert the label to a singleton [FastString].
        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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> LHsExpr GhcPs
-> Bool
-> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate SrcSpanAnnA
l (SrcSpan
-> NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
-> Located (NonEmpty (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 LocatedAn NoEpAnns (DotFieldOcc GhcPs)
-> [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [])) (FastString -> LHsExpr GhcPs
punnedVar FastString
f) Bool
pun Maybe (EpToken "=")
XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
anns
        where
          -- If punning, compute HsVar "f" otherwise just arg. This
          -- has the effect that sentinel HsVar "pun-rhs" is replaced
          -- by HsVar "f" here, before the update is written to a
          -- setField expressions.
          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 -> LIdOccP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdOccP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (GenLocated SrcSpanAnnN RdrName -> HsExpr GhcPs)
-> (FastString -> GenLocated SrcSpanAnnN RdrName)
-> FastString
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> (FastString -> RdrName)
-> FastString
-> GenLocated SrcSpanAnnN 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 :: GenLocated SrcSpanAnnN RdrName
-> HsRecordBinds GhcPs
-> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-> HsExpr GhcPs
mkRdrRecordCon GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN 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
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 ActivationGhc
               -> InlinePragma GhcPs
-- The (Maybe ActivationGhc) is because the user can omit
-- the activation spec (and usually does)
mkInlinePragma :: SourceText
-> (InlineSpec, RuleMatchInfo)
-> Maybe ActivationGhc
-> InlinePragma GhcPs
mkInlinePragma SourceText
src (InlineSpec
inl, RuleMatchInfo
match_info) Maybe ActivationGhc
mb_act
  = InlinePragma { inl_ext :: XInlinePragma GhcPs
inl_ext = XInlinePragma GhcPs
SourceText
src -- See Note [Pragma source text] in "GHC.Types.SourceText"
                 , inl_inline :: InlineSpec
inl_inline = InlineSpec
inl
                 , inl_act :: Activation GhcPs
inl_act    = Activation GhcPs
ActivationGhc
act
                 , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
match_info }
  where
    act :: ActivationGhc
act = case Maybe ActivationGhc
mb_act of
            Just ActivationGhc
act -> ActivationGhc
act
            Maybe ActivationGhc
Nothing  -> -- No phase specified
                        case InlineSpec
inl of
                          InlineSpec
NoInline -> ActivationGhc
forall e. ActivationX e
NeverActive
                          InlineSpec
Opaque   -> ActivationGhc
forall e. ActivationX e
NeverActive
                          InlineSpec
_other   -> ActivationGhc
forall e. ActivationX e
AlwaysActive

mkOpaquePragma :: SourceText -> InlinePragma GhcPs
mkOpaquePragma :: SourceText -> InlinePragma GhcPs
mkOpaquePragma SourceText
src
  = InlinePragma { inl_ext :: XInlinePragma GhcPs
inl_ext    = XInlinePragma GhcPs
SourceText
src
                 , inl_inline :: InlineSpec
inl_inline = InlineSpec
Opaque
                 -- By marking the OPAQUE pragma NeverActive we stop
                 -- (constructor) specialisation on OPAQUE things.
                 --
                 -- See Note [OPAQUE pragma]
                 , inl_act :: Activation GhcPs
inl_act    = Activation GhcPs
ActivationGhc
forall e. ActivationX e
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
    -- In a "type data" declaration, the constructors are in the type/class
    -- namespace rather than the data constructor namespace.
    -- See Note [Type data declarations] in GHC.Rename.Module.
    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)

-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- construct a foreign import declaration
--
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, GenLocated SrcSpanAnnN 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
_), GenLocated SrcSpanAnnN 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
    -- Parse a C-like entity string of the following form:
    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
    -- If 'cid' is missing, the function name 'v' is used instead as symbol
    -- name (cf section 8.5.1 in Haskell 2010 report).
    mkCImport :: P (ForeignImport GhcPs)
mkCImport = do
      let e :: String
e = FastString -> String
unpackFS FastString
entity
      case GenLocated EpaLocation CCallConv
-> GenLocated EpaLocation Safety
-> FastString
-> String
-> GenLocated SrcSpan SourceText
-> Maybe (ForeignImport GhcPs)
parseCImport (GenLocated SrcSpan CCallConv -> GenLocated EpaLocation 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 -> GenLocated EpaLocation 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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
v)) String
e (SrcSpan -> SourceText -> GenLocated SrcSpan 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 pass)
_ CImportSpec pass
CWrapper) = Bool
True
    isCWrapperImport ForeignImport pass
_ = Bool
False

    -- currently, all the other import conventions only support a symbol name in
    -- the entity string. If it is missing, we use the function name instead.
    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 (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
v)
                        else FastString
entity
        funcTarget :: CImportSpec GhcPs
funcTarget = CCallTarget GhcPs -> CImportSpec GhcPs
forall pass. CCallTarget pass -> CImportSpec pass
CFunction (XStaticTarget GhcPs
-> FastString -> ForeignKind -> CCallTarget GhcPs
forall pass.
XStaticTarget pass -> FastString -> ForeignKind -> CCallTarget pass
StaticTarget XStaticTarget GhcPs
SourceText
esrc FastString
entity' ForeignKind
ForeignFunction)
        importSpec :: ForeignImport GhcPs
importSpec = XCImport GhcPs
-> XRec GhcPs CCallConv
-> XRec GhcPs Safety
-> Maybe (Header GhcPs)
-> CImportSpec GhcPs
-> ForeignImport GhcPs
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe (Header pass)
-> CImportSpec pass
-> 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 -> GenLocated EpaLocation 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 -> GenLocated EpaLocation Safety
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan Safety
safety) Maybe (Header GhcPs)
forall a. Maybe a
Nothing CImportSpec GhcPs
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)
GenLocated SrcSpanAnnN RdrName
v
          , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsSigType GhcPs
ty
          , fd_fi :: ForeignImport GhcPs
fd_fi     = ForeignImport GhcPs
spec
          , fd_modifiers :: [LHsModifier GhcPs]
fd_modifiers = []
          }



-- the string "foo" is ambiguous: either a header or a C identifier.  The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
             -> Located SourceText
             -> Maybe (ForeignImport GhcPs)
parseCImport :: GenLocated EpaLocation CCallConv
-> GenLocated EpaLocation Safety
-> FastString
-> String
-> GenLocated SrcSpan SourceText
-> Maybe (ForeignImport GhcPs)
parseCImport GenLocated EpaLocation CCallConv
cconv GenLocated EpaLocation Safety
safety FastString
nm String
str GenLocated SrcSpan SourceText
sourceText =
 [ForeignImport GhcPs] -> Maybe (ForeignImport GhcPs)
forall a. [a] -> Maybe a
listToMaybe ([ForeignImport GhcPs] -> Maybe (ForeignImport GhcPs))
-> [ForeignImport GhcPs] -> Maybe (ForeignImport GhcPs)
forall a b. (a -> b) -> a -> b
$ ((ForeignImport GhcPs, String) -> ForeignImport GhcPs)
-> [(ForeignImport GhcPs, String)] -> [ForeignImport GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignImport GhcPs, String) -> ForeignImport GhcPs
forall a b. (a, b) -> a
fst ([(ForeignImport GhcPs, String)] -> [ForeignImport GhcPs])
-> [(ForeignImport GhcPs, String)] -> [ForeignImport GhcPs]
forall a b. (a -> b) -> a -> b
$ ((ForeignImport GhcPs, String) -> Bool)
-> [(ForeignImport GhcPs, String)]
-> [(ForeignImport GhcPs, 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 GhcPs, String) -> String)
-> (ForeignImport GhcPs, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ForeignImport GhcPs, String) -> String
forall a b. (a, b) -> b
snd) ([(ForeignImport GhcPs, String)]
 -> [(ForeignImport GhcPs, String)])
-> [(ForeignImport GhcPs, String)]
-> [(ForeignImport GhcPs, String)]
forall a b. (a -> b) -> a -> b
$
     ReadP (ForeignImport GhcPs) -> ReadS (ForeignImport GhcPs)
forall a. ReadP a -> ReadS a
readP_to_S ReadP (ForeignImport GhcPs)
parse String
str
 where
   parse :: ReadP (ForeignImport GhcPs)
parse = do
       skipSpaces
       r <- [ReadP (ForeignImport GhcPs)] -> ReadP (ForeignImport GhcPs)
forall a. [ReadP a] -> ReadP a
choice [
          String -> ReadP String
string String
"dynamic" ReadP String
-> ReadP (ForeignImport GhcPs) -> ReadP (ForeignImport GhcPs)
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport GhcPs -> ReadP (ForeignImport GhcPs)
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Header GhcPs) -> CImportSpec GhcPs -> ForeignImport GhcPs
mk Maybe (Header GhcPs)
forall a. Maybe a
Nothing (CCallTarget GhcPs -> CImportSpec GhcPs
forall pass. CCallTarget pass -> CImportSpec pass
CFunction (XDynamicTarget GhcPs -> CCallTarget GhcPs
forall pass. XDynamicTarget pass -> CCallTarget pass
DynamicTarget XDynamicTarget GhcPs
NoExtField
NoExtField))),
          String -> ReadP String
string String
"wrapper" ReadP String
-> ReadP (ForeignImport GhcPs) -> ReadP (ForeignImport GhcPs)
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport GhcPs -> ReadP (ForeignImport GhcPs)
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Header GhcPs) -> CImportSpec GhcPs -> ForeignImport GhcPs
mk Maybe (Header GhcPs)
forall a. Maybe a
Nothing CImportSpec GhcPs
forall pass. CImportSpec pass
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 GhcPs) -> CImportSpec GhcPs -> ForeignImport GhcPs
mk Maybe (Header GhcPs)
forall a. Maybe a
Nothing (CImportSpec GhcPs -> ForeignImport GhcPs)
-> ReadP (CImportSpec GhcPs) -> ReadP (ForeignImport GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP (CImportSpec GhcPs)
cimp FastString
nm) ReadP (ForeignImport GhcPs)
-> ReadP (ForeignImport GhcPs) -> ReadP (ForeignImport GhcPs)
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 GhcPs) -> CImportSpec GhcPs -> ForeignImport GhcPs
mk Maybe (Header GhcPs)
h CImportSpec GhcPs
n = XCImport GhcPs
-> XRec GhcPs CCallConv
-> XRec GhcPs Safety
-> Maybe (Header GhcPs)
-> CImportSpec GhcPs
-> ForeignImport GhcPs
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe (Header pass)
-> CImportSpec pass
-> ForeignImport pass
CImport (GenLocated SrcSpan SourceText -> GenLocated EpaLocation SourceText
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpan SourceText
sourceText) (GenLocated EpaLocation CCallConv
-> GenLocated EpaLocation CCallConv
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated EpaLocation CCallConv
cconv) (GenLocated EpaLocation Safety -> GenLocated EpaLocation Safety
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated EpaLocation Safety
safety) Maybe (Header GhcPs)
h CImportSpec GhcPs
n

   hdr_char :: Char -> Bool
hdr_char Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
   -- header files are filenames, which can contain
   -- pretty much any char (depending on the platform),
   -- so just accept any non-space character
   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 GhcPs)
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 GhcPs) -> ReadP (CImportSpec GhcPs)
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FastString -> CImportSpec GhcPs
FastString -> CImportSpec GhcPs
forall pass. FastString -> CImportSpec pass
CLabel (FastString -> CImportSpec GhcPs)
-> ReadP FastString -> ReadP (CImportSpec GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP FastString
cid)
             ReadP (CImportSpec GhcPs)
-> ReadP (CImportSpec GhcPs) -> ReadP (CImportSpec GhcPs)
forall a. ReadP a -> ReadP a -> ReadP a
+++ (do targetKind <- case GenLocated EpaLocation CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc GenLocated EpaLocation CCallConv
cconv of
                               CCallConv
CApiConv ->
                                  ForeignKind -> ReadP ForeignKind -> ReadP ForeignKind
forall a. a -> ReadP a -> ReadP a
option ForeignKind
ForeignFunction
                                         (do String -> ReadP ()
token String
"value"
                                             skipSpaces
                                             ForeignKind -> ReadP ForeignKind
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignKind
ForeignValue)
                               CCallConv
_ -> ForeignKind -> ReadP ForeignKind
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignKind
ForeignFunction
                     cid' <- cid
                     return (CFunction (StaticTarget NoSourceText cid' targetKind)))
          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)))


-- construct a foreign export declaration
--
mkExport :: Located CCallConv
         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
         -> ( EpToken "export", TokDcolon)
         -> P (EpToken "foreign" -> HsDecl GhcPs)
mkExport :: GenLocated SrcSpan CCallConv
-> (Located StringLiteral, GenLocated SrcSpanAnnN 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
_), GenLocated SrcSpanAnnN 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)
GenLocated SrcSpanAnnN 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) (FastString -> CCallConv -> CExportSpec
CExportStatic FastString
entity' CCallConv
cconv))
                 , fd_modifiers :: [LHsModifier GhcPs]
fd_modifiers = [] }
  where
    entity' :: FastString
entity' | FastString -> Bool
nullFS FastString
entity = RdrName -> FastString
mkExtName (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
v)
            | Bool
otherwise     = FastString
entity

-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--
mkExtName :: RdrName -> CLabelString
mkExtName :: RdrName -> FastString
mkExtName RdrName
rdrNm = OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
rdrNm)

--------------------------------------------------------------------------------
-- Help with module system imports/exports

-- Context for whether we are parsing an import or export list.
data InExportOrImportList
  = InExportList
  | InImportList

data ImpExpSubSpec = ImpExpAbs
                   | ImpExpAll (Maybe ExplicitNamespaceKeyword) (EpToken "..")
                   | ImpExpList    [LocatedA ImpExpQcSpec]   -- no wildcards
                   | ImpExpAllWith [LocatedA ImpExpQcSpec]   -- at least one wildcard

data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName)
                  | ImpExpQcWildcard (Maybe ExplicitNamespaceKeyword) (EpToken "..") (EpToken ",")

mkModuleImp, mkModuleExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec
                         -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImp :: Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleImp = InExportOrImportList
-> Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleImpExp InExportOrImportList
InImportList
mkModuleExp :: Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleExp = InExportOrImportList
-> Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleImpExp InExportOrImportList
InExportList

mkModuleImpExp :: InExportOrImportList -> Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec
               -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp :: InExportOrImportList
-> Maybe (LWarningTxt GhcPs)
-> (EpToken "(", EpToken ")")
-> LocatedA ImpExpQcSpec
-> ImpExpSubSpec
-> P (IE GhcPs)
mkModuleImpExp InExportOrImportList
ctx 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 Maybe ExplicitNamespaceKeyword
m_kw EpToken ".."
tok -> do
      newName <- P (IEWrappedName GhcPs)
nameT
      let ns_spec = Maybe ExplicitNamespaceKeyword -> NamespaceSpecifier
namespaceSpecifierFromKw Maybe ExplicitNamespaceKeyword
m_kw
          x = Maybe (LWarningTxt GhcPs)
-> NamespaceSpecifier
-> EpToken "("
-> EpToken ".."
-> EpToken ")"
-> IEThingAllExt GhcPs
forall pass.
Maybe (LWarningTxt pass)
-> NamespaceSpecifier
-> EpToken "("
-> EpToken ".."
-> EpToken ")"
-> IEThingAllExt pass
IEThingAllExt Maybe (LWarningTxt GhcPs)
warning NamespaceSpecifier
ns_spec EpToken "("
top EpToken ".."
tok EpToken ")"
tcp
      return $ IEThingAll x (L l newName) noExportDoc
    ImpExpList [LocatedA ImpExpQcSpec]
xs -> do
      -- `xs` contains no wildcards (checked by mkImpExpSubSpec)
      newName <- P (IEWrappedName GhcPs)
nameT
      return $ IEThingWith (warning, (top,NoEpTok,NoEpTok,tcp))
                           (L l newName)
                           NoIEWildcard
                           (wrapped xs)
                           noExportDoc
    ImpExpAllWith [LocatedA ImpExpQcSpec]
xs -> do
      -- `xs` contains at least one wildcard (checked by mkImpExpSubSpec)
      let withs :: [ImpExpQcSpec]
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 :: Int
pos   = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
panic String
"ImpExpAllWith with no wildcard") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$  -- should've been ImpExpList
                  (ImpExpQcSpec -> Bool) -> [ImpExpQcSpec] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ImpExpQcSpec -> Bool
isImpExpQcWildcard [ImpExpQcSpec]
withs
          (Maybe ExplicitNamespaceKeyword
m_kw,EpToken ".."
td,EpToken ","
tc) = case [ImpExpQcSpec]
withs [ImpExpQcSpec] -> Int -> ImpExpQcSpec
forall a. HasCallStack => [a] -> Int -> a
!! Int
pos of
            ImpExpQcWildcard Maybe ExplicitNamespaceKeyword
m_kw EpToken ".."
td EpToken ","
tc -> (Maybe ExplicitNamespaceKeyword
m_kw,EpToken ".."
td,EpToken ","
tc)
            ImpExpQcSpec
_ -> String
-> (Maybe ExplicitNamespaceKeyword, EpToken "..", EpToken ",")
forall a. HasCallStack => String -> a
panic String
"mkModuleImpExp: item is not a wildcard"  -- shouldn't have matched isImpExpQcWildcard
          ies :: [LocatedA (IEWrappedName GhcPs)]
          ies :: [GenLocated SrcSpanAnnA (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
      newName <- P (IEWrappedName GhcPs)
nameT
      patSyns <- getBit PatternSynonymsBit
      if | Just kw <- m_kw ->
             unsupportedExplicitNamespaceKeyword kw UnsupportedNameSpaceInIEThingWith
         | InImportList <- ctx ->
             addFatalError $ mkPlainErrorMsgEnvelope (locA l) PsErrIllegalImportBundleForm
         | not patSyns ->
             addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrIllegalPatSynExport
         | otherwise -> return ()
      return $ IEThingWith (warning, (top,td,tc,tcp))
                           (L l newName)
                           (IEWildcard pos)
                           ies
                           noExportDoc
  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 Maybe ExplicitNamespaceKeyword
_ GenLocated SrcSpanAnnN RdrName
ln) = GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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 Maybe ExplicitNamespaceKeyword
m_kw GenLocated SrcSpanAnnN RdrName
name) = case Maybe ExplicitNamespaceKeyword
m_kw of
        Maybe ExplicitNamespaceKeyword
Nothing                          -> XIEName GhcPs -> XRec GhcPs (IdP GhcPs) -> IEWrappedName GhcPs
forall p. XIEName p -> LIdP p -> IEWrappedName p
IEName XIEName GhcPs
NoExtField
noExtField XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN RdrName
name
        Just (ExplicitTypeNamespace EpToken "type"
tok) -> XIEType GhcPs -> XRec GhcPs (IdP GhcPs) -> IEWrappedName GhcPs
forall p. XIEType p -> LIdP p -> IEWrappedName p
IEType XIEType GhcPs
EpToken "type"
tok XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN RdrName
name
        Just (ExplicitDataNamespace EpToken "data"
tok) -> XIEData GhcPs -> XRec GhcPs (IdP GhcPs) -> IEWrappedName GhcPs
forall p. XIEData p -> LIdP p -> IEWrappedName p
IEData XIEData GhcPs
EpToken "data"
tok XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN RdrName
name
    ieNameFromSpec ImpExpQcWildcard{} = String -> IEWrappedName GhcPs
forall a. HasCallStack => String -> a
panic String
"ieNameFromSpec got wildcard"

    namespaceSpecifierFromKw :: Maybe ExplicitNamespaceKeyword -> NamespaceSpecifier
    namespaceSpecifierFromKw :: Maybe ExplicitNamespaceKeyword -> NamespaceSpecifier
namespaceSpecifierFromKw Maybe ExplicitNamespaceKeyword
Nothing = NamespaceSpecifier
NoNamespaceSpecifier
    namespaceSpecifierFromKw (Just (ExplicitTypeNamespace EpToken "type"
tok)) = EpToken "type" -> NamespaceSpecifier
TypeNamespaceSpecifier EpToken "type"
tok
    namespaceSpecifierFromKw (Just (ExplicitDataNamespace EpToken "data"
tok)) = EpToken "data" -> NamespaceSpecifier
DataNamespaceSpecifier EpToken "data"
tok

    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)

mkPlainImpExp :: LocatedN RdrName -> ImpExpQcSpec
mkPlainImpExp :: GenLocated SrcSpanAnnN RdrName -> ImpExpQcSpec
mkPlainImpExp GenLocated SrcSpanAnnN RdrName
name = Maybe ExplicitNamespaceKeyword
-> GenLocated SrcSpanAnnN RdrName -> ImpExpQcSpec
ImpExpQcName Maybe ExplicitNamespaceKeyword
forall a. Maybe a
Nothing GenLocated SrcSpanAnnN RdrName
name

mkTypeImpExp :: EpToken "type"
             -> LocatedN RdrName   -- TcCls or Var name space
             -> P ImpExpQcSpec
mkTypeImpExp :: EpToken "type" -> GenLocated SrcSpanAnnN RdrName -> P ImpExpQcSpec
mkTypeImpExp EpToken "type"
tok GenLocated SrcSpanAnnN RdrName
name = do
  let name' :: GenLocated SrcSpanAnnN RdrName
name' = (RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN 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) GenLocated SrcSpanAnnN RdrName
name
      ns_kw :: ExplicitNamespaceKeyword
ns_kw = EpToken "type" -> ExplicitNamespaceKeyword
ExplicitTypeNamespace EpToken "type"
tok
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces ExplicitNamespaceKeyword
ns_kw
  ImpExpQcSpec -> P ImpExpQcSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExplicitNamespaceKeyword
-> GenLocated SrcSpanAnnN RdrName -> ImpExpQcSpec
ImpExpQcName (ExplicitNamespaceKeyword -> Maybe ExplicitNamespaceKeyword
forall a. a -> Maybe a
Just ExplicitNamespaceKeyword
ns_kw) GenLocated SrcSpanAnnN RdrName
name')

mkDataImpExp :: EpToken "data"
             -> LocatedN RdrName
             -> P ImpExpQcSpec
mkDataImpExp :: EpToken "data" -> GenLocated SrcSpanAnnN RdrName -> P ImpExpQcSpec
mkDataImpExp EpToken "data"
tok GenLocated SrcSpanAnnN RdrName
name = do
  let ns_kw :: ExplicitNamespaceKeyword
ns_kw = EpToken "data" -> ExplicitNamespaceKeyword
ExplicitDataNamespace EpToken "data"
tok
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces ExplicitNamespaceKeyword
ns_kw
  ImpExpQcSpec -> P ImpExpQcSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExplicitNamespaceKeyword
-> GenLocated SrcSpanAnnN RdrName -> ImpExpQcSpec
ImpExpQcName (ExplicitNamespaceKeyword -> Maybe ExplicitNamespaceKeyword
forall a. a -> Maybe a
Just ExplicitNamespaceKeyword
ns_kw) GenLocated SrcSpanAnnN RdrName
name)

mkTypeWcImpExp :: SrcSpan
               -> EpToken "type"
               -> EpToken ".."
               -> P (LocatedA ImpExpQcSpec)
mkTypeWcImpExp :: SrcSpan
-> EpToken "type" -> EpToken ".." -> P (LocatedA ImpExpQcSpec)
mkTypeWcImpExp SrcSpan
loc EpToken "type"
tk_ns EpToken ".."
tk_wc = do
  let ns_kw :: ExplicitNamespaceKeyword
ns_kw = EpToken "type" -> ExplicitNamespaceKeyword
ExplicitTypeNamespace EpToken "type"
tk_ns
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces ExplicitNamespaceKeyword
ns_kw
  let ie_spec :: ImpExpQcSpec
ie_spec = Maybe ExplicitNamespaceKeyword
-> EpToken ".." -> EpToken "," -> ImpExpQcSpec
ImpExpQcWildcard (ExplicitNamespaceKeyword -> Maybe ExplicitNamespaceKeyword
forall a. a -> Maybe a
Just ExplicitNamespaceKeyword
ns_kw) EpToken ".."
tk_wc EpToken ","
forall (tok :: Symbol). EpToken tok
NoEpTok
  LocatedA ImpExpQcSpec -> P (LocatedA ImpExpQcSpec)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> ImpExpQcSpec -> LocatedA ImpExpQcSpec
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) ImpExpQcSpec
ie_spec)

mkDataWcImpExp :: SrcSpan
               -> EpToken "data"
               -> EpToken ".."
               -> P (LocatedA ImpExpQcSpec)
mkDataWcImpExp :: SrcSpan
-> EpToken "data" -> EpToken ".." -> P (LocatedA ImpExpQcSpec)
mkDataWcImpExp SrcSpan
loc EpToken "data"
tk_ns EpToken ".."
tk_wc = do
  let ns_kw :: ExplicitNamespaceKeyword
ns_kw = EpToken "data" -> ExplicitNamespaceKeyword
ExplicitDataNamespace EpToken "data"
tk_ns
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces ExplicitNamespaceKeyword
ns_kw
  let ie_spec :: ImpExpQcSpec
ie_spec = Maybe ExplicitNamespaceKeyword
-> EpToken ".." -> EpToken "," -> ImpExpQcSpec
ImpExpQcWildcard (ExplicitNamespaceKeyword -> Maybe ExplicitNamespaceKeyword
forall a. a -> Maybe a
Just ExplicitNamespaceKeyword
ns_kw) EpToken ".."
tk_wc EpToken ","
forall (tok :: Symbol). EpToken tok
NoEpTok
  LocatedA ImpExpQcSpec -> P (LocatedA ImpExpQcSpec)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> ImpExpQcSpec -> LocatedA ImpExpQcSpec
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) ImpExpQcSpec
ie_spec)

mkIEWholeNamespacePs :: Maybe (LWarningTxt GhcPs)
                     -> NamespaceSpecifier
                     -> EpToken ".."
                     -> IE GhcPs
mkIEWholeNamespacePs :: Maybe (LWarningTxt GhcPs)
-> NamespaceSpecifier -> EpToken ".." -> IE GhcPs
mkIEWholeNamespacePs Maybe (LWarningTxt GhcPs)
warning NamespaceSpecifier
ns_spec EpToken ".."
tk_wc =
  XIEWholeNamespace GhcPs -> IE GhcPs
forall pass. XIEWholeNamespace pass -> IE pass
IEWholeNamespace IEWholeNamespaceExt {
    iewn_warning :: Maybe (LWarningTxt GhcPs)
iewn_warning  = Maybe (LWarningTxt GhcPs)
warning,
    iewn_ns_spec :: NamespaceSpecifier
iewn_ns_spec  = NamespaceSpecifier
ns_spec,
    iewn_tok_wc :: EpToken ".."
iewn_tok_wc   = EpToken ".."
tk_wc,
    iewn_names :: [IdP GhcPs]
iewn_names    = [] }

mkWholeTypeWcImpExp :: SrcSpan
                    -> Maybe (LWarningTxt GhcPs)
                    -> EpToken "type"
                    -> EpToken ".."
                    -> P (LIE GhcPs)
mkWholeTypeWcImpExp :: SrcSpan
-> Maybe (LWarningTxt GhcPs)
-> EpToken "type"
-> EpToken ".."
-> P (LIE GhcPs)
mkWholeTypeWcImpExp SrcSpan
loc Maybe (LWarningTxt GhcPs)
warning EpToken "type"
tk_ns EpToken ".."
tk_wc = do
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces (EpToken "type" -> ExplicitNamespaceKeyword
ExplicitTypeNamespace EpToken "type"
tk_ns)
  let ie_spec :: IE GhcPs
ie_spec = Maybe (LWarningTxt GhcPs)
-> NamespaceSpecifier -> EpToken ".." -> IE GhcPs
mkIEWholeNamespacePs Maybe (LWarningTxt GhcPs)
warning (EpToken "type" -> NamespaceSpecifier
TypeNamespaceSpecifier EpToken "type"
tk_ns) EpToken ".."
tk_wc
  GenLocated SrcSpanAnnA (IE GhcPs)
-> P (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) IE GhcPs
ie_spec)

mkWholeDataWcImpExp :: SrcSpan
                    -> Maybe (LWarningTxt GhcPs)
                    -> EpToken "data"
                    -> EpToken ".."
                    -> P (LIE GhcPs)
mkWholeDataWcImpExp :: SrcSpan
-> Maybe (LWarningTxt GhcPs)
-> EpToken "data"
-> EpToken ".."
-> P (LIE GhcPs)
mkWholeDataWcImpExp SrcSpan
loc Maybe (LWarningTxt GhcPs)
warning EpToken "data"
tk_ns EpToken ".."
tk_wc = do
  ExplicitNamespaceKeyword -> P ()
forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces (EpToken "data" -> ExplicitNamespaceKeyword
ExplicitDataNamespace EpToken "data"
tk_ns)
  let ie_spec :: IE GhcPs
ie_spec = Maybe (LWarningTxt GhcPs)
-> NamespaceSpecifier -> EpToken ".." -> IE GhcPs
mkIEWholeNamespacePs Maybe (LWarningTxt GhcPs)
warning (EpToken "data" -> NamespaceSpecifier
DataNamespaceSpecifier EpToken "data"
tk_ns) EpToken ".."
tk_wc
  GenLocated SrcSpanAnnA (IE GhcPs)
-> P (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) IE GhcPs
ie_spec)

mkPlainWcImpExp :: Maybe (LWarningTxt GhcPs)
                -> EpToken ".."
                -> P (LIE GhcPs)
mkPlainWcImpExp :: Maybe (LWarningTxt GhcPs) -> EpToken ".." -> P (LIE GhcPs)
mkPlainWcImpExp Maybe (LWarningTxt GhcPs)
warning EpToken ".."
tk_wc = do
  let ie_spec :: IE GhcPs
ie_spec = Maybe (LWarningTxt GhcPs)
-> NamespaceSpecifier -> EpToken ".." -> IE GhcPs
mkIEWholeNamespacePs Maybe (LWarningTxt GhcPs)
warning NamespaceSpecifier
NoNamespaceSpecifier EpToken ".."
tk_wc
  GenLocated SrcSpanAnnA (IE GhcPs)
-> P (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L (EpToken ".." -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l EpToken ".."
tk_wc) IE GhcPs
ie_spec)

-- In the correct order
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 Maybe ExplicitNamespaceKeyword
m_kw EpToken ".."
td EpToken ","
_tc)] =
  ImpExpSubSpec -> P ImpExpSubSpec
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExplicitNamespaceKeyword -> EpToken ".." -> ImpExpSubSpec
ImpExpAll Maybe ExplicitNamespaceKeyword
m_kw 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{} = Bool
True
isImpExpQcWildcard ImpExpQcSpec
_                  = Bool
False

-----------------------------------------------------------------------------
-- Warnings and failures

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

failSpliceOrQuoteTwice :: EpAnnLevel -> P ()
failSpliceOrQuoteTwice :: EpAnnLevel -> P ()
failSpliceOrQuoteTwice EpAnnLevel
lvl =
  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
PsErrSpliceOrQuoteTwice
  where
    loc :: SrcSpan
loc = case EpAnnLevel
lvl of
      EpAnnLevelSplice EpToken "splice"
tok -> EpToken "splice" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "splice"
tok
      EpAnnLevelQuote EpToken "quote"
tok -> EpToken "quote" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "quote"
tok

warnStarIsType :: MonadP m => SrcSpan -> m ()
warnStarIsType :: forall (m :: * -> *). MonadP m => SrcSpan -> m ()
warnStarIsType SrcSpan
span = SrcSpan -> PsMessage -> m ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage SrcSpan
span PsMessage
PsWarnStarIsType

failOpFewArgs :: MonadP m => LHsType GhcPs -> m a
failOpFewArgs :: forall (m :: * -> *) a. MonadP m => LHsType GhcPs -> m a
failOpFewArgs (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (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) }
failOpFewArgs (L SrcSpanAnnA
l (HsWildCardTy XWildCardTy GhcPs
_)) =
  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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc SrcSpanAnnA
l) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ PsMessage
PsErrInvalidInfixHole
failOpFewArgs LHsType GhcPs
op = String -> SDoc -> m a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"failOpFewArgs: impossible type operator" (GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
op)

requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces :: forall (m :: * -> *). MonadP m => ExplicitNamespaceKeyword -> m ()
requireExplicitNamespaces ExplicitNamespaceKeyword
kw = do
  allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ExplicitNamespacesBit
  unless allowed $
    addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalExplicitNamespace kw
  where
    loc :: SrcSpan
loc = case ExplicitNamespaceKeyword
kw of
      ExplicitTypeNamespace EpToken "type"
tok -> EpToken "type" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "type"
tok
      ExplicitDataNamespace EpToken "data"
tok -> EpToken "data" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "data"
tok

unsupportedExplicitNamespaceKeyword :: MonadP m => ExplicitNamespaceKeyword -> UnsupportedNamespacePosition -> m ()
unsupportedExplicitNamespaceKeyword :: forall (m :: * -> *).
MonadP m =>
ExplicitNamespaceKeyword -> UnsupportedNamespacePosition -> m ()
unsupportedExplicitNamespaceKeyword ExplicitNamespaceKeyword
kw UnsupportedNamespacePosition
pos =
  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 SrcSpan
loc (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
    ExplicitNamespaceKeyword
-> UnsupportedNamespacePosition -> PsMessage
PsErrUnsupportedExplicitNamespace ExplicitNamespaceKeyword
kw UnsupportedNamespacePosition
pos
  where
    loc :: SrcSpan
loc = case ExplicitNamespaceKeyword
kw of
      ExplicitTypeNamespace EpToken "type"
tok -> EpToken "type" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "type"
tok
      ExplicitDataNamespace EpToken "data"
tok -> EpToken "data" -> SrcSpan
forall {tok :: Symbol}. EpToken tok -> SrcSpan
getEpTokenSrcSpan EpToken "data"
tok

warnPatternNamespaceSpecifier :: MonadP m => SrcSpan -> m ()
warnPatternNamespaceSpecifier :: forall (m :: * -> *). MonadP m => SrcSpan -> m ()
warnPatternNamespaceSpecifier SrcSpan
l = do
  explicit_namespaces <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ExplicitNamespacesBit
  addPsMessage l (PsWarnPatternNamespaceSpecifier explicit_namespaces)

-----------------------------------------------------------------------------
-- Misc utils

data PV_Context =
  PV_Context
    { PV_Context -> ParserOpts
pv_options :: ParserOpts
    , PV_Context -> ParseContext
pv_details :: ParseContext -- See Note [Parser-Validator Details]
    }

data PV_Accum =
  PV_Accum
    { PV_Accum -> Messages PsMessage
pv_warnings        :: Messages PsMessage
    , PV_Accum -> Messages PsMessage
pv_errors          :: Messages PsMessage
    , PV_Accum -> Maybe [LEpaComment]
pv_header_comments :: Strict.Maybe [LEpaComment]
    , PV_Accum -> [LEpaComment]
pv_comment_q       :: [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)

-- During parsing, we make use of several monadic effects: reporting parse errors,
-- accumulating warnings, adding API annotations, and checking for extensions. These
-- effects are captured by the 'MonadP' type class.
--
-- Sometimes we need to postpone some of these effects to a later stage due to
-- ambiguities described in Note [Ambiguous syntactic categories].
-- We could use two layers of the P monad, one for each stage:
--
--   abParser :: forall x. DisambAB x => P (P x)
--
-- The outer layer of P consumes the input and builds the inner layer, which
-- validates the input. But this type is not particularly helpful, as it obscures
-- the fact that the inner layer of P never consumes any input.
--
-- For clarity, we introduce the notion of a parser-validator: a parser that does
-- not consume any input, but may fail or use other effects. Thus we have:
--
--   abParser :: forall x. DisambAB x => P (PV x)
--
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
(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
(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
(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 ()
(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 ()
(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 ->
      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed
      -- diagnostics.
      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
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
(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
(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  -- fast path
    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
(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
(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)

{- Note [Parser-Validator Details]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set
depending on validation context. We use this in checkPattern to fix #984.

Consider this example, where the user has forgotten a 'do':

  f _ = do
    x <- computation
    case () of
      _ ->
        result <- computation
        case () of () -> undefined

GHC parses it as follows:

  f _ = do
    x <- computation
    (case () of
      _ ->
        result) <- computation
        case () of () -> undefined

Note that this fragment is parsed as a pattern:

  case () of
    _ ->
      result

We attempt to detect such cases and add a hint to the diagnostic messages:

  T984.hs:6:9:
    Parse error in pattern: case () of { _ -> result }
    Possibly caused by a missing 'do'?

The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed
out of the 'ParseContext', which are read by functions like 'patFail' when
constructing the 'PsParseErrorInPatDetails' data structure. When validating in a
context other than 'bindpat' (a pattern to the left of <-), we set the
details to 'noParseContext' and it has no effect on the diagnostic messages.

-}

-- | Hint about bang patterns, assuming @BangPatterns@ is off.
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)

-- Tuple
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

-- Sum
-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
--     return $ L l (ExplicitSum noExtField alt arity e)
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))

-- Tuple
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)
    -- Ignore the element location so that the error message refers to the
    -- entire tuple. See #19504 (and the discussion) for details.
    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'

-- Sum
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 :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
x LHsType GhcPs
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` GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
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) (XOpTy GhcPs
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XOpTy pass
-> LHsType pass -> LHsType pass -> LHsType pass -> HsType pass
HsOpTy XOpTy GhcPs
NoExtField
noExtField LHsType GhcPs
x LHsType GhcPs
op LHsType GhcPs
y)

mkMultField :: [LHsModifier GhcPs] -> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs
mkMultField :: [LHsModifier GhcPs]
-> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs
mkMultField [LHsModifier GhcPs]
mods TokDcolon
col LHsType GhcPs
t = HsModifiedFunArr GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs
mkConDeclField (XHsModifiedFunArr (LHsType (NoGhcTc GhcPs)) GhcPs
-> [LHsModifier GhcPs] -> HsFunArr GhcPs -> HsModifiedFunArr GhcPs
forall mult pass.
XHsModifiedFunArr mult pass
-> [LHsModifierOf mult pass]
-> HsFunArr pass
-> HsModifiedFunArrOf mult pass
HsModifiedFunArr NoExtField
XHsModifiedFunArr (LHsType (NoGhcTc GhcPs)) GhcPs
noExtField [LHsModifier GhcPs]
mods (HsFunArr GhcPs -> HsModifiedFunArr GhcPs)
-> HsFunArr GhcPs -> HsModifiedFunArr GhcPs
forall a b. (a -> b) -> a -> b
$ XHsStandardArr GhcPs -> HsFunArr GhcPs
forall pass. XHsStandardArr pass -> HsFunArr pass
HsStandardArr (TokDcolon -> EpArrowOrColon
EpColon TokDcolon
col)) LHsType GhcPs
t

-----------------------------------------------------------------------------
-- Token symbols

starSym :: IsUnicodeSyntax -> FastString
starSym :: IsUnicodeSyntax -> FastString
starSym IsUnicodeSyntax
UnicodeSyntax = String -> FastString
fsLit String
"★"
starSym IsUnicodeSyntax
NormalSyntax  = String -> FastString
fsLit String
"*"

-----------------------------------------
-- Bits and pieces for RecordDotSyntax.

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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
                -> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=")
                -> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate :: SrcSpanAnnA
-> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> LHsExpr GhcPs
-> Bool
-> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate SrcSpanAnnA
loc (L SrcSpan
l NonEmpty (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) (NonEmpty (XRec GhcPs (DotFieldOcc GhcPs))
-> FieldLabelStrings GhcPs
forall p. NonEmpty (XRec p (DotFieldOcc p)) -> FieldLabelStrings p
FieldLabelStrings NonEmpty (XRec GhcPs (DotFieldOcc GhcPs))
NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))
flds)
    , hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
hfbRHS = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
    , hfbPun :: Bool
hfbPun = Bool
isPun
  }

-----------------------------------------------------------------------------
-- Tuple and list punning

punsAllowed :: P Bool
punsAllowed :: P Bool
punsAllowed = ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ListTuplePunsBit

-- | Check whether @ListTuplePuns@ is enabled and return the first arg if it is,
-- the second arg otherwise.
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)

-- | Emit an error of type 'PsErrInvalidPun' with a location from @start@ to
-- @end@ if the extension @ListTuplePuns@ is disabled.
--
-- This is used in Parser.y to guard rules that require punning.
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))

-- | Call a parser with a span and its comments given by a start and end token.
withCombinedComments ::
  HasLoc l1 =>
  HasLoc l2 =>
  l1 ->
  l2 ->
  (SrcSpan -> P a) ->
  P (LocatedA a)
withCombinedComments :: forall l1 l2 a.
(HasLoc l1, HasLoc l2) =>
l1 -> l2 -> (SrcSpan -> P a) -> P (LocatedA a)
withCombinedComments 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)

-- | Decide whether to parse tuple syntax @(Int, Double)@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns@.
-- The case with an explicit promotion quote, @'(Int, Double)@, is handled
-- by 'mkExplicitTupleTy'.
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
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitTupleTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitTupleTy (EpToken "'", EpToken "(", EpToken ")")
XExplicitTupleTy GhcPs
annsKeyword PromotionFlag
NotPromoted [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)

-- | Decide whether to parse tuple con syntax @(,)@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns@.
-- The case with an explicit promotion quote, @'(,)@, is handled
-- by the rule @SIMPLEQUOTE sysdcon_nolist@ in @atype@.
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))

-- | Decide whether to parse list tycon syntax @[]@ in a type as a type or data
-- constructor, based on the extension @ListTuplePuns@.
-- The case with an explicit promotion quote, @'[]@, is handled by
-- 'mkExplicitListTy'.
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 -> LIdOccP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdOccP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpToken "'"
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted LIdOccP GhcPs
GenLocated SrcSpanAnnN RdrName
rn

    -- attach the comments only to the RdrName since it's the innermost AST node
    rn :: GenLocated SrcSpanAnnN RdrName
rn = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN 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

-- | Decide whether to parse list type syntax @[Int]@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns@.
-- The case with an explicit promotion quote, @'[Int]@, is handled
-- by 'mkExplicitListTy'.
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

parseError :: HsExpr GhcPs
parseError :: HsExpr GhcPs
parseError = XHole GhcPs -> HsExpr GhcPs
forall p. XHole p -> HsExpr p
HsHole XHole GhcPs
HoleKind
HoleError

addModifiersToDecl :: Located [LHsModifier GhcPs]
                   -> [TrailingAnn]
                   -> LHsDecl GhcPs
                   -> P (LHsDecl GhcPs)
addModifiersToDecl :: Located [LHsModifier GhcPs]
-> [TrailingAnn] -> LHsDecl GhcPs -> P (LHsDecl GhcPs)
addModifiersToDecl (L SrcSpan
lMods [LHsModifier GhcPs]
mods') [TrailingAnn]
semis (L (EpAnn EpaLocation
lDecl AnnListItem
anns1 EpAnnComments
cs1) HsDecl GhcPs
topDecl) = do
  let mods :: [GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
mods = case [LHsModifier GhcPs]
mods' of
               L SrcSpanAnnA
l HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
h:[LHsModifier GhcPs]
t -> [GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
forall a. [a] -> [a]
reverse ([GenLocated
    SrcSpanAnnA
    (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
 -> [GenLocated
       SrcSpanAnnA
       (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)])
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> GenLocated
     SrcSpanAnnA
     (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA
addAnnsA SrcSpanAnnA
l [TrailingAnn]
semis EpAnnComments
emptyComments) HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
h GenLocated
  SrcSpanAnnA
  (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
forall a. a -> [a] -> [a]
: [LHsModifier GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
t
               [] -> []
  cs <- SrcSpan -> P EpAnnComments
forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
srcSpan
  let newLoc = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
srcSpan) AnnListItem
anns1 (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs1)
  fmap (L newLoc) $ case topDecl of
    TyClD XTyClD GhcPs
x TyClDecl GhcPs
decl -> XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
x (TyClDecl GhcPs -> HsDecl GhcPs)
-> P (TyClDecl GhcPs) -> P (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TyClDecl GhcPs
decl of
      FamDecl{} -> TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a. a -> P a
forbidden TyClDecl GhcPs
decl
      SynDecl{} -> TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a. a -> P a
forbidden TyClDecl GhcPs
decl
      DataDecl{tcdModifiers :: forall pass. TyClDecl pass -> [LHsModifier pass]
tcdModifiers = [LHsModifier GhcPs]
mods'} ->
        TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyClDecl GhcPs -> P (TyClDecl GhcPs))
-> TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ TyClDecl GhcPs
decl { tcdModifiers = mods ++ mods' }
      ClassDecl{tcdModifiers :: forall pass. TyClDecl pass -> [LHsModifier pass]
tcdModifiers = [LHsModifier GhcPs]
mods'} ->
        TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyClDecl GhcPs -> P (TyClDecl GhcPs))
-> TyClDecl GhcPs -> P (TyClDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ TyClDecl GhcPs
decl { tcdModifiers = mods ++ mods'}
    InstD XInstD GhcPs
x InstDecl GhcPs
decl -> XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
x (InstDecl GhcPs -> HsDecl GhcPs)
-> P (InstDecl GhcPs) -> P (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case InstDecl GhcPs
decl of
      ClsInstD XClsInstD GhcPs
x' d :: ClsInstDecl GhcPs
d@(ClsInstDecl { cid_modifiers :: forall pass. ClsInstDecl pass -> [LHsModifier pass]
cid_modifiers = [LHsModifier GhcPs]
mods' }) ->
        InstDecl GhcPs -> P (InstDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstDecl GhcPs -> P (InstDecl GhcPs))
-> InstDecl GhcPs -> P (InstDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD XClsInstD GhcPs
x' (ClsInstDecl GhcPs
d { cid_modifiers = mods ++ mods' })
      DataFamInstD{} -> InstDecl GhcPs -> P (InstDecl GhcPs)
forall a. a -> P a
forbidden InstDecl GhcPs
decl
      TyFamInstD{} -> InstDecl GhcPs -> P (InstDecl GhcPs)
forall a. a -> P a
forbidden InstDecl GhcPs
decl
    SigD XSigD GhcPs
x Sig GhcPs
decl -> XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
x (Sig GhcPs -> HsDecl GhcPs) -> P (Sig GhcPs) -> P (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Sig GhcPs
decl of
      TypeSig XTypeSig GhcPs
x' [LHsModifier GhcPs]
mods' [XRec GhcPs (IdP GhcPs)]
a LHsSigWcType GhcPs
b -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcPs -> P (Sig GhcPs)) -> Sig GhcPs -> P (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$ XTypeSig GhcPs
-> [LHsModifier GhcPs]
-> [XRec GhcPs (IdP GhcPs)]
-> LHsSigWcType GhcPs
-> Sig GhcPs
forall pass.
XTypeSig pass
-> [LHsModifier pass]
-> [LIdP pass]
-> LHsSigWcType pass
-> Sig pass
TypeSig XTypeSig GhcPs
x' ([GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
mods [GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
-> [GenLocated
      SrcSpanAnnA
      (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LHsModifier GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsModifierOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs)]
mods') [XRec GhcPs (IdP GhcPs)]
a LHsSigWcType GhcPs
b
      PatSynSig{}        -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      ClassOpSig{}       -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      FixSig{}           -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      InlineSig{}        -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      SpecSig{}          -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      SpecSigE{}         -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      SpecInstSig{}      -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      MinimalSig{}       -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      SCCFunSig{}        -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
      CompleteMatchSig{} -> Sig GhcPs -> P (Sig GhcPs)
forall a. a -> P a
forbidden Sig GhcPs
decl
    DefD XDefD GhcPs
x d :: DefaultDecl GhcPs
d@(DefaultDecl{defd_modifiers :: forall pass. DefaultDecl pass -> [LHsModifier pass]
defd_modifiers = [LHsModifier GhcPs]
mods'}) ->
      HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl GhcPs -> P (HsDecl GhcPs))
-> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XDefD GhcPs -> DefaultDecl GhcPs -> HsDecl GhcPs
forall p. XDefD p -> DefaultDecl p -> HsDecl p
DefD XDefD GhcPs
x (DefaultDecl GhcPs
d { defd_modifiers = mods ++ mods' })
    ForD XForD GhcPs
x ForeignDecl GhcPs
decl -> XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD XForD GhcPs
x (ForeignDecl GhcPs -> HsDecl GhcPs)
-> P (ForeignDecl GhcPs) -> P (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ForeignDecl GhcPs
decl of
      ForeignImport{fd_modifiers :: forall pass. ForeignDecl pass -> [LHsModifier pass]
fd_modifiers = [LHsModifier GhcPs]
mods'} ->
        ForeignDecl GhcPs -> P (ForeignDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignDecl GhcPs -> P (ForeignDecl GhcPs))
-> ForeignDecl GhcPs -> P (ForeignDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ForeignDecl GhcPs
decl { fd_modifiers = mods ++ mods'}
      ForeignExport{fd_modifiers :: forall pass. ForeignDecl pass -> [LHsModifier pass]
fd_modifiers = [LHsModifier GhcPs]
mods'} ->
        ForeignDecl GhcPs -> P (ForeignDecl GhcPs)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignDecl GhcPs -> P (ForeignDecl GhcPs))
-> ForeignDecl GhcPs -> P (ForeignDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ForeignDecl GhcPs
decl { fd_modifiers = mods ++ mods'}
    DerivD{}     -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    ValD{}       -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    KindSigD{}   -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    WarningD{}   -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    AnnD{}       -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    RuleD{}      -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    SpliceD{}    -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    DocD{}       -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
    RoleAnnotD{} -> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a. a -> P a
forbidden HsDecl GhcPs
topDecl
 where
  srcSpan :: SrcSpan
srcSpan = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (SrcSpan -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc SrcSpan
lMods) (EpaLocation -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc EpaLocation
lDecl)

  forbidden :: a -> P a
  forbidden :: forall a. a -> P a
forbidden a
decl = 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 SrcSpan
srcSpan (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ SuggestModifiers -> PsMessage
PsErrModifierSyntax SuggestModifiers
DontSuggestModifiers
    a -> P a
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
decl