{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# 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, mkSpliceDecl,
        mkRoleAnnotDecl,
        mkClassDecl,
        mkTyData, mkDataFamInst,
        mkTySynonym, mkTyFamInstEqn,
        mkStandaloneKindSig,
        mkTyFamInst,
        mkFamDecl,
        mkInlinePragma,
        mkOpaquePragma,
        mkPatSynMatchGroup,
        mkRecConstrOrUpdate,
        mkTyClD, mkInstD,
        mkRdrRecordCon, mkRdrRecordUpd,
        setRdrNameSpace,
        fromSpecTyVarBndr, fromSpecTyVarBndrs,
        annBinds,
        fixValbindsAnn,
        stmtsAnchor, stmtsLoc,

        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, mkRuleTyVarBndrs,
        checkRuleTyVarBndrNames,
        checkRecordSyntax,
        checkEmptyGADTs,
        addFatalError, hintBangPat,
        mkBangTy,
        UnpackednessPragma(..),
        mkMultTy,
        mkMultAnn,

        -- Token location
        mkTokenLocation,

        -- Help with processing exports
        ImpExpSubSpec(..),
        ImpExpQcSpec(..),
        mkModuleImpExp,
        mkTypeImpExp,
        mkImpExpSubSpec,
        checkImportSpec,

        -- Token symbols
        starSym,

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

        SumOrTuple (..),

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

        -- 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 ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Fixity
import GHC.Types.Hint
import GHC.Types.SourceText
import GHC.Parser.Types
import GHC.Parser.Lexer
import GHC.Parser.Errors.Types
import GHC.Utils.Lexeme ( okConOcc )
import GHC.Types.TyThing
import GHC.Core.Type    ( Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
                          listTyConName, listTyConKey, sumDataCon,
                          unrestrictedFunTyCon , listTyCon_RDR, unitDataCon )
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Monad (unlessM)
import Data.Either
import Data.List        ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
import GHC.Unit.Module.Warnings
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
import Data.Kind       ( Type )
import Data.List.NonEmpty (NonEmpty)

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

  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
            -> [AddEpAnn]
            -> P (LTyClDecl GhcPs)

mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> EpLayout
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc' (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls EpLayout
layout [AddEpAnn]
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, ann, cs) <- checkTyClHdr True tycl_hdr
       ; tyvars <- checkTyVars (text "class") whereDots cls tparams
       ; let anns' = [AddEpAnn]
annsIn [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. Semigroup a => a -> a -> a
Semi.<> [AddEpAnn]
ann
       ; let loc = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc') AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
cs
       ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
                                  , tcdCtxt = mcxt
                                  , tcdLName = cls, tcdTyVars = tyvars
                                  , tcdFixity = fixity
                                  , tcdFDs = snd (unLoc fds)
                                  , tcdSigs = mkClassOpSigs sigs
                                  , tcdMeths = binds
                                  , tcdATs = ats, tcdATDefs = at_defs
                                  , tcdDocs  = docs })) }

mkTyData :: SrcSpan
         -> Bool
         -> NewOrData
         -> Maybe (LocatedP CType)
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> Located (HsDeriving GhcPs)
         -> [AddEpAnn]
         -> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> Bool
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc' Bool
is_type_data NewOrData
new_or_data Maybe (LocatedP CType)
cType (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr))
         Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
annsIn
  = do { (tc, tparams, fixity, ann, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
       ; let anns' = [AddEpAnn]
annsIn [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. Semigroup a => a -> a -> a
Semi.<> [AddEpAnn]
ann
       ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
       ; !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 = anns',
                                   tcdLName = tc, tcdTyVars = tyvars,
                                   tcdFixity = fixity,
                                   tcdDataDefn = defn })) }

mkDataDefn :: Maybe (LocatedP CType)
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> DataDefnCons (LConDecl GhcPs)
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
mkDataDefn :: Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> DataDefnCons (LConDecl GhcPs)
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig DataDefnCons (LConDecl GhcPs)
data_cons HsDeriving GhcPs
maybe_deriv
  = do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
       ; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExtField
noExtField
                            , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (LocatedP CType)
cType
                            , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = Maybe (LHsContext GhcPs)
mcxt
                            , dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (LConDecl GhcPs)
data_cons
                            , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
                            , dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }

mkTySynonym :: SrcSpan
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> [AddEpAnn]
            -> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
annsIn
  = do { (tc, tparams, fixity, ann, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams
       ; let anns' = [AddEpAnn]
annsIn [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. Semigroup a => a -> a -> a
Semi.<> [AddEpAnn]
ann
       ; 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
  -> [AddEpAnn]
  -> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [LocatedN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [LocatedN RdrName]
lhs LHsSigType GhcPs
rhs [AddEpAnn]
anns =
  do { vs <- (LocatedN RdrName -> P (LocatedN RdrName))
-> [LocatedN RdrName] -> P [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedN RdrName -> P (LocatedN RdrName)
forall {m :: * -> *} {l}.
(MonadP m, HasLoc l) =>
GenLocated l RdrName -> m (GenLocated l RdrName)
check_lhs_name (Located [LocatedN RdrName] -> [LocatedN RdrName]
forall l e. GenLocated l e -> e
unLoc Located [LocatedN RdrName]
lhs)
     ; v <- check_singular_lhs (reverse vs)
     ; return $ L (noAnnSrcSpan loc)
       $ StandaloneKindSig anns v rhs }
  where
    check_lhs_name :: GenLocated l RdrName -> m (GenLocated l RdrName)
check_lhs_name v :: GenLocated l RdrName
v@(GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc->RdrName
name) =
      if RdrName -> Bool
isUnqual RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc RdrName
name)
      then GenLocated l RdrName -> m (GenLocated l RdrName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated l RdrName
v
      else MsgEnvelope PsMessage -> m (GenLocated l RdrName)
forall a. MsgEnvelope PsMessage -> m a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> m (GenLocated l RdrName))
-> MsgEnvelope PsMessage -> m (GenLocated l RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated l RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated l RdrName
v) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
             (RdrName -> PsMessage
PsErrUnexpectedQualifiedConstructor (GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated l RdrName
v))
    check_singular_lhs :: [LocatedN RdrName] -> P (LocatedN RdrName)
check_singular_lhs [LocatedN RdrName]
vs =
      case [LocatedN RdrName]
vs of
        [] -> String -> P (LocatedN RdrName)
forall a. HasCallStack => String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
        [LocatedN RdrName
v] -> LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return LocatedN RdrName
v
        [LocatedN RdrName]
_ -> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LocatedN RdrName))
-> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (Located [LocatedN RdrName] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [LocatedN RdrName]
lhs) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
               ([XRec GhcPs (IdP GhcPs)] -> PsMessage
PsErrMultipleNamesInStandaloneKindSignature [XRec GhcPs (IdP GhcPs)]
[LocatedN RdrName]
vs)

mkTyFamInstEqn :: SrcSpan
               -> HsOuterFamEqnTyVarBndrs GhcPs
               -> LHsType GhcPs
               -> LHsType GhcPs
               -> [AddEpAnn]
               -> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn SrcSpan
loc HsOuterFamEqnTyVarBndrs GhcPs
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
anns
  = do { (tc, tparams, fixity, ann, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], 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    = anns `mappend` ann
                        , feqn_tycon  = tc
                        , feqn_bndrs  = bndrs
                        , feqn_pats   = tparams
                        , feqn_fixity = fixity
                        , feqn_rhs    = rhs })}

mkDataFamInst :: SrcSpan
              -> NewOrData
              -> Maybe (LocatedP CType)
              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
                        , LHsType GhcPs)
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> Located (HsDeriving GhcPs)
              -> [AddEpAnn]
              -> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs,
    LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (LocatedP CType)
cType (Maybe (LHsContext GhcPs)
mcxt, HsOuterFamEqnTyVarBndrs GhcPs
bndrs, LHsType GhcPs
tycl_hdr)
              Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
anns
  = do { (tc, tparams, fixity, ann, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], EpAnnComments)
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
       ; 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    = ann Semi.<> anns
                          , feqn_tycon  = tc
                          , feqn_bndrs  = bndrs
                          , feqn_pats   = tparams
                          , feqn_fixity = fixity
                          , feqn_rhs    = defn })))) }

-- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
--               ksig data_cons (L _ maybe_deriv) anns
--   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
--        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
--        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
--        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
--        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
--                   (FamEqn { feqn_ext    = anns'
--                           , feqn_tycon  = tc
--                           , feqn_bndrs  = bndrs
--                           , feqn_pats   = tparams
--                           , feqn_fixity = fixity
--                           , feqn_rhs    = defn })))) }



mkTyFamInst :: SrcSpan
            -> TyFamInstEqn GhcPs
            -> [AddEpAnn]
            -> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> [AddEpAnn] -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn [AddEpAnn]
anns = do
  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 [AddEpAnn]
XCTyFamInstDecl GhcPs
anns TyFamInstEqn GhcPs
eqn)))

mkFamDecl :: SrcSpan
          -> FamilyInfo GhcPs
          -> TopLevelFlag
          -> LHsType GhcPs                   -- LHS
          -> LFamilyResultSig GhcPs          -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> [AddEpAnn]
          -> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info TopLevelFlag
topLevel LHsType GhcPs
lhs LFamilyResultSig GhcPs
ksig Maybe (LInjectivityAnn GhcPs)
injAnn [AddEpAnn]
annsIn
  = do { (tc, tparams, fixity, ann, cs) <- Bool
-> LHsType GhcPs
-> P (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], 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
       ; return (L loc' (FamDecl noExtField (FamilyDecl
                                           { fdExt       = annsIn Semi.<> ann
                                           , 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
                -> [AddEpAnn]
                -> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName
-> [Located (Maybe FastString)]
-> [AddEpAnn]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc LocatedN RdrName
tycon [Located (Maybe FastString)]
roles [AddEpAnn]
anns
  = do { roles' <- (Located (Maybe FastString) -> P (GenLocated EpAnnCO (Maybe Role)))
-> [Located (Maybe FastString)]
-> P [GenLocated EpAnnCO (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Located (Maybe FastString) -> P (GenLocated EpAnnCO (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
       ; !cs <- getCommentsFor loc
       ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs)
         $ RoleAnnotDecl anns tycon roles' }
  where
    role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
    all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
    possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]

    parse_role :: Located (Maybe FastString) -> P (GenLocated EpAnnCO (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated EpAnnCO (Maybe Role)
 -> P (GenLocated EpAnnCO (Maybe Role)))
-> GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a b. (a -> b) -> a -> b
$ EpAnnCO -> Maybe Role -> GenLocated EpAnnCO (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc_role) Maybe Role
forall a. Maybe a
Nothing
    parse_role (L SrcSpan
loc_role (Just FastString
role))
      = case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
          Just Role
found_role -> GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated EpAnnCO (Maybe Role)
 -> P (GenLocated EpAnnCO (Maybe Role)))
-> GenLocated EpAnnCO (Maybe Role)
-> P (GenLocated EpAnnCO (Maybe Role))
forall a b. (a -> b) -> a -> b
$ EpAnnCO -> Maybe Role -> GenLocated EpAnnCO (Maybe Role)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc_role) (Maybe Role -> GenLocated EpAnnCO (Maybe Role))
-> Maybe Role -> GenLocated EpAnnCO (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
          Maybe Role
Nothing         ->
            let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
                  ((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
            in
            MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (Maybe Role))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (Maybe Role)))
-> MsgEnvelope PsMessage -> P (GenLocated EpAnnCO (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc_role (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
              (FastString -> [Role] -> PsMessage
PsErrIllegalRoleName FastString
role [Role]
nearby)

-- | 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 LHsTyVarBndr Specificity GhcPs
bndr = case LHsTyVarBndr Specificity GhcPs
bndr of
  (L SrcSpanAnnA
loc (UserTyVar XUserTyVar GhcPs
xtv Specificity
flag XRec GhcPs (IdP GhcPs)
idp))     -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
                                          P ()
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsTyVarBndr () GhcPs
 -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs
-> () -> XRec GhcPs (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
xtv () XRec GhcPs (IdP GhcPs)
idp)
  (L SrcSpanAnnA
loc (KindedTyVar XKindedTyVar GhcPs
xtv Specificity
flag XRec GhcPs (IdP GhcPs)
idp LHsType GhcPs
k)) -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
                                          P ()
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsTyVarBndr () GhcPs
 -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> HsTyVarBndr () GhcPs
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> ()
-> XRec GhcPs (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
xtv () XRec GhcPs (IdP GhcPs)
idp LHsType GhcPs
k)
  where
    check_spec :: Specificity -> SrcSpanAnnA -> P ()
    check_spec :: Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
SpecifiedSpec SrcSpanAnnA
_   = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    check_spec Specificity
InferredSpec  SrcSpanAnnA
loc = MsgEnvelope PsMessage -> P ()
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
                                     PsMessage
PsErrInferredTypeVarNotAllowed

-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@
annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs
  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds :: AddEpAnn
-> EpAnnComments
-> HsLocalBinds GhcPs
-> (HsLocalBinds GhcPs, Maybe EpAnnComments)
annBinds AddEpAnn
a EpAnnComments
cs (HsValBinds XHsValBinds GhcPs GhcPs
an HsValBindsLR GhcPs GhcPs
bs)  = (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds (AddEpAnn -> SrcSpanAnnL -> EpAnnComments -> SrcSpanAnnL
add_where AddEpAnn
a XHsValBinds GhcPs GhcPs
SrcSpanAnnL
an EpAnnComments
cs) HsValBindsLR GhcPs GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds AddEpAnn
a EpAnnComments
cs (HsIPBinds XHsIPBinds GhcPs GhcPs
an HsIPBinds GhcPs
bs)   = (XHsIPBinds GhcPs GhcPs -> HsIPBinds GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds (AddEpAnn -> SrcSpanAnnL -> EpAnnComments -> SrcSpanAnnL
add_where AddEpAnn
a XHsIPBinds GhcPs GhcPs
SrcSpanAnnL
an EpAnnComments
cs) HsIPBinds GhcPs
bs, Maybe EpAnnComments
forall a. Maybe a
Nothing)
annBinds AddEpAnn
_ EpAnnComments
cs  (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x) = (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
x, EpAnnComments -> Maybe EpAnnComments
forall a. a -> Maybe a
Just EpAnnComments
cs)

add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where :: AddEpAnn -> SrcSpanAnnL -> EpAnnComments -> SrcSpanAnnL
add_where an :: AddEpAnn
an@(AddEpAnn AnnKeywordId
_ (EpaSpan (RealSrcSpan RealSrcSpan
rs Maybe BufSpan
_))) (EpAnn EpaLocation
a (AnnList Maybe EpaLocation
anc Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs) EpAnnComments
cs2
  | EpaLocation -> Bool
valid_anchor EpaLocation
a
  = EpaLocation -> AnnList -> EpAnnComments -> SrcSpanAnnL
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpaLocation -> [AddEpAnn] -> EpaLocation
widenAnchor EpaLocation
a [AddEpAnn
an]) (Maybe EpaLocation
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList Maybe EpaLocation
anc Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
  | Bool
otherwise
  = EpaLocation -> AnnList -> EpAnnComments -> SrcSpanAnnL
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor RealSrcSpan
rs EpaLocation
a)
          (Maybe EpaLocation
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList ((EpaLocation -> EpaLocation)
-> Maybe EpaLocation -> Maybe EpaLocation
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor RealSrcSpan
rs) Maybe EpaLocation
anc) Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
add_where (AddEpAnn AnnKeywordId
_ EpaLocation
_) SrcSpanAnnL
_ EpAnnComments
_ = String -> SrcSpanAnnL
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

fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn :: SrcSpanAnnL -> SrcSpanAnnL
fixValbindsAnn (EpAnn EpaLocation
anchor (AnnList Maybe EpaLocation
ma Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs)
  = (EpaLocation -> AnnList -> EpAnnComments -> SrcSpanAnnL
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpaLocation -> [AddEpAnn] -> EpaLocation
widenAnchor EpaLocation
anchor ([AddEpAnn]
r [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ (TrailingAnn -> AddEpAnn) -> [TrailingAnn] -> [AddEpAnn]
forall a b. (a -> b) -> [a] -> [b]
map TrailingAnn -> AddEpAnn
trailingAnnToAddEpAnn [TrailingAnn]
t)) (Maybe EpaLocation
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList Maybe EpaLocation
ma Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs)

-- | The anchor for a stmtlist is based on either the location or
-- the first semicolon annotion.
stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe EpaLocation
stmtsAnchor :: forall a. Located (OrdList AddEpAnn, a) -> Maybe EpaLocation
stmtsAnchor (L (RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb) ((ConsOL (AddEpAnn AnnKeywordId
_ (EpaSpan (RealSrcSpan RealSrcSpan
r Maybe BufSpan
rb))) OrdList AddEpAnn
_), a
_))
  = EpaLocation -> Maybe EpaLocation
forall a. a -> Maybe a
Just (EpaLocation -> Maybe EpaLocation)
-> EpaLocation -> Maybe EpaLocation
forall a b. (a -> b) -> a -> b
$ EpaLocation -> SrcSpan -> EpaLocation
widenAnchorS (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb)) (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
rb)
stmtsAnchor (L (RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb) (OrdList AddEpAnn, a)
_) = EpaLocation -> Maybe EpaLocation
forall a. a -> Maybe a
Just (EpaLocation -> Maybe EpaLocation)
-> EpaLocation -> Maybe EpaLocation
forall a b. (a -> b) -> a -> b
$ SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
EpaSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb)
stmtsAnchor GenLocated SrcSpan (OrdList AddEpAnn, a)
_ = Maybe EpaLocation
forall a. Maybe a
Nothing

stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan
stmtsLoc :: forall a. Located (OrdList AddEpAnn, a) -> SrcSpan
stmtsLoc (L SrcSpan
l ((ConsOL AddEpAnn
aa OrdList AddEpAnn
_), a
_))
  = SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan SrcSpan
l [AddEpAnn
aa]
stmtsLoc (L SrcSpan
l (OrdList AddEpAnn, 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 SrcSpanAnnL
_ m1 :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1@[L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1]) } }))
            [LHsDecl GhcPs]
binds
  | [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1
  = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
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 SrcSpanAnnL
_ [L SrcSpanAnnA
lm2 Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2]) } })))
         : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
        | RdrName
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
f2 =
          let (SrcSpanAnnA
loc2', SrcSpanAnnA
lm2') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsA SrcSpanAnnA
loc2 SrcSpanAnnA
lm2
          in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go (SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lm2' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2 GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> [a] -> [a]
: [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mtchs)
                        (SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => 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'' (LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
LocatedN RdrName
fun_id1 ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [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
      SrcSpanAnnL
      [GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ (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 :: LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
tyConToDataCon (L SrcSpanAnnN
loc RdrName
tc)
  | String -> Bool
okConOcc (OccName -> String
occNameString OccName
occ)
  = LocatedN RdrName
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a. a -> Either (MsgEnvelope PsMessage) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))

  | Bool
otherwise
  = MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a b. a -> Either a b
Left (MsgEnvelope PsMessage
 -> Either (MsgEnvelope PsMessage) (LocatedN RdrName))
-> MsgEnvelope PsMessage
-> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$ (RdrName -> PsMessage
PsErrNotADataCon RdrName
tc)
  where
    occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc

mkPatSynMatchGroup :: LocatedN RdrName
                   -> LocatedL (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: LocatedN RdrName
-> LocatedL (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpanAnnN
loc RdrName
patsyn_name) (L SrcSpanAnnL
ld OrdList (LHsDecl GhcPs)
decls) =
    do { 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
_
                                 -- AZ: where should these anns come from?
                         pat :: LPat GhcPs
pat@(L SrcSpanAnnA
_ (ConPat XConPat GhcPs
noAnn ln :: XRec GhcPs (ConLikeP GhcPs)
ln@(L SrcSpanAnnN
_ RdrName
name) HsConPatDetails GhcPs
details))
                               HsMultAnn GhcPs
_ GRHSs GhcPs (LHsExpr GhcPs)
rhs))) =
        do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
               SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl
           ; match <- case HsConPatDetails GhcPs
details of
               PrefixCon [HsConPatTyArg (NoGhcTc GhcPs)]
_ [LPat GhcPs]
pats -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XConPat GhcPs
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noAnn
                                                  , m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcPs))
HsMatchContext (LocatedN RdrName)
ctxt, m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = EpaLocation
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
                                                  , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
                   where
                     l :: EpaLocation
l = [GenLocated SrcSpanAnnA (Pat GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
                     ctxt :: HsMatchContext (LocatedN RdrName)
ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
ln
                                   , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                   , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }

               InfixCon LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XConPat GhcPs
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noAnn
                                                , m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = HsMatchContext (LIdP (NoGhcTc GhcPs))
HsMatchContext (LocatedN RdrName)
ctxt
                                                , m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = EpaLocation
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2]
                                                , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs }
                   where
                     l :: EpaLocation
l = [GenLocated SrcSpanAnnA (Pat GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p1, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p2]
                     ctxt :: HsMatchContext (LocatedN RdrName)
ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun = XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
ln
                                   , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
                                   , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }

               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 :: [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
                -> ConDecl GhcPs

mkConDeclH98 :: [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 [AddEpAnn]
ann LocatedN RdrName
name Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDeclH98Details GhcPs
args
  = ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext    = [AddEpAnn]
XConDeclH98 GhcPs
ann
               , con_name :: XRec GhcPs (IdP GhcPs)
con_name   = XRec GhcPs (IdP GhcPs)
LocatedN RdrName
name
               , con_forall :: Bool
con_forall = Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
mb_forall
               , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
mb_forall Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall a. Maybe a -> a -> a
`orElse` []
               , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
               , con_args :: HsConDeclH98Details GhcPs
con_args   = HsConDeclH98Details GhcPs
args
               , con_doc :: Maybe (LHsDoc GhcPs)
con_doc    = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing }

-- | 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
           -> NonEmpty (LocatedN RdrName)
           -> EpUniToken "::" "∷"
           -> LHsSigType GhcPs
           -> P (LConDecl GhcPs)
mkGadtDecl :: SrcSpan
-> NonEmpty (LocatedN RdrName)
-> EpUniToken "::" "\8759"
-> LHsSigType GhcPs
-> P (LConDecl GhcPs)
mkGadtDecl SrcSpan
loc NonEmpty (LocatedN RdrName)
names EpUniToken "::" "\8759"
dcol LHsSigType GhcPs
ty = do

  (args, res_ty, annsa, csa) <-
    case LHsType GhcPs
body_ty of
     L SrcSpanAnnA
ll (HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
hsArr (L (EpAnn EpaLocation
anc AnnListItem
_ EpAnnComments
cs) (HsRecTy XRecTy GhcPs
an [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) -> do
       arr <- case HsArrow GhcPs
hsArr of
         HsUnrestrictedArrow XUnrestrictedArrow (LHsType GhcPs) GhcPs
arr -> EpUniToken "->" "\8594" -> P (EpUniToken "->" "\8594")
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return EpUniToken "->" "\8594"
XUnrestrictedArrow (LHsType GhcPs) GhcPs
arr
         HsArrow GhcPs
_ -> do MsgEnvelope PsMessage -> P ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body_ty) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
                                 (HsArrow GhcPs -> PsMessage
PsErrIllegalGadtRecordMultiplicity HsArrow GhcPs
hsArr)
                 EpUniToken "->" "\8594" -> P (EpUniToken "->" "\8594")
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return EpUniToken "->" "\8594"
forall a. NoAnn a => a
noAnn

       return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty
              , [], epAnnComments ll)
     LHsType GhcPs
_ -> do
       let ([AddEpAnn]
anns, EpAnnComments
cs, [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type) = LHsType GhcPs
-> ([AddEpAnn], EpAnnComments, [HsScaled GhcPs (LHsType GhcPs)],
    LHsType GhcPs)
forall (p :: Pass).
LHsType (GhcPass p)
-> ([AddEpAnn], EpAnnComments,
    [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
splitHsFunType LHsType GhcPs
body_ty
       (HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs),
 [AddEpAnn], EpAnnComments)
-> P (HsConDeclGADTDetails GhcPs,
      GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPrefixConGADT GhcPs
-> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall pass.
XPrefixConGADT pass
-> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT NoExtField
XPrefixConGADT GhcPs
noExtField [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
res_type, [AddEpAnn]
anns, EpAnnComments
cs)

  let bndrs_loc = case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
        HsOuterImplicit{} -> GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
        HsOuterExplicit XHsOuterExplicit GhcPs Specificity
an [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
_ -> EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (EpAnn (AddEpAnn, AddEpAnn) -> EpaLocation
forall ann. EpAnn ann -> EpaLocation
entry XHsOuterExplicit GhcPs Specificity
EpAnn (AddEpAnn, AddEpAnn)
an) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
emptyComments

  let l = EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> EpaLocation
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
loc) AnnListItem
forall a. NoAnn a => a
noAnn EpAnnComments
csa

  pure $ L l ConDeclGADT
                     { con_g_ext  = (dcol, annsa)
                     , con_names  = names
                     , con_bndrs  = L bndrs_loc outer_bndrs
                     , con_mb_cxt = mcxt
                     , con_g_args = args
                     , con_res_ty = res_ty
                     , con_doc    = Nothing }
  where
    (HsOuterSigTyVarBndrs GhcPs
outer_bndrs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsSigType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs),
    LHsType GhcPs)
splitLHsGadtTy LHsSigType GhcPs
ty

setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ 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
-> LocatedN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars SDoc
pp_what SDoc
equals_or_where LocatedN RdrName
tc [LHsTypeArg GhcPs]
tparms
  = do { tvs <- (HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> P (GenLocated
         SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)))
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> P [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
check [LHsTypeArg GhcPs]
[HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparms
       ; return (mkHsQTvs tvs) }
  where
    check :: HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
check (HsTypeArg XTypeArg GhcPs
at GenLocated SrcSpanAnnA (HsType GhcPs)
ki) = [AddEpAnn]
-> [AddEpAnn]
-> 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) = [AddEpAnn]
-> [AddEpAnn]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens [] [] (XBndrRequired GhcPs -> HsBndrVis GhcPs
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired GhcPs
noExtField) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
    check (HsArgPar XArgPar GhcPs
sp) = MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
 -> P (GenLocated
         SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)))
-> MsgEnvelope PsMessage
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
XArgPar GhcPs
sp (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
                            (SDoc -> RdrName -> PsMessage
PsErrMalformedDecl SDoc
pp_what (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc))
        -- Keep around an action for adjusting the annotations of extra parens
    chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs
              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
    chkParens :: [AddEpAnn]
-> [AddEpAnn]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens [AddEpAnn]
ops [AddEpAnn]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l (HsParTy XParTy GhcPs
_ (L SrcSpanAnnA
lt HsType GhcPs
ty)))
      = let
          (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. 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
          [AddEpAnn]
-> [AddEpAnn]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chkParens (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
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 [AddEpAnn]
ops [AddEpAnn]
cps HsBndrVis GhcPs
bvis LHsType GhcPs
ty = [AddEpAnn]
-> [AddEpAnn]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps HsBndrVis GhcPs
bvis LHsType GhcPs
ty

        -- Check that the name space is correct!
    chk :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
    chk :: [AddEpAnn]
-> [AddEpAnn]
-> HsBndrVis GhcPs
-> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l (HsKindSig XKindSig GhcPs
annk (L SrcSpanAnnA
annt (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
lv RdrName
tv))) LHsType GhcPs
k))
        | RdrName -> Bool
isRdrTyVar RdrName
tv
            = let
                an :: [AddEpAnn]
an = ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
              in
                GenLocated SrcSpanAnnA (HsTyVarBndr (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 -> [AddEpAnn] -> SrcSpanAnnA
forall an. EpAnn an -> [AddEpAnn] -> EpAnn an
widenLocatedAn (SrcSpanAnnA
l SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA
annt) (HsBndrVis GhcPs -> AddEpAnn
for_widening HsBndrVis GhcPs
bvisAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
an))
                       (XKindedTyVar GhcPs
-> HsBndrVis GhcPs
-> XRec GhcPs (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar ([AddEpAnn]
an [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
XKindSig GhcPs
annk [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
XTyVar GhcPs
ann) HsBndrVis GhcPs
bvis (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
lv RdrName
tv) LHsType GhcPs
k))
    chk [AddEpAnn]
ops [AddEpAnn]
cps HsBndrVis GhcPs
bvis (L SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
ltv RdrName
tv)))
        | RdrName -> Bool
isRdrTyVar RdrName
tv
            = let
                an :: [AddEpAnn]
an = ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
              in
                GenLocated SrcSpanAnnA (HsTyVarBndr (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 -> [AddEpAnn] -> SrcSpanAnnA
forall an. EpAnn an -> [AddEpAnn] -> EpAnn an
widenLocatedAn SrcSpanAnnA
l (HsBndrVis GhcPs -> AddEpAnn
for_widening HsBndrVis GhcPs
bvisAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
an))
                                     (XUserTyVar GhcPs
-> HsBndrVis GhcPs
-> XRec GhcPs (IdP GhcPs)
-> HsTyVarBndr (HsBndrVis GhcPs) GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar ([AddEpAnn]
an [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
XTyVar GhcPs
ann) HsBndrVis GhcPs
bvis (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ltv RdrName
tv)))
    chk [AddEpAnn]
_ [AddEpAnn]
_ HsBndrVis GhcPs
_ t :: LHsType GhcPs
t@(L SrcSpanAnnA
loc HsType GhcPs
_)
        = MsgEnvelope PsMessage -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs))
-> MsgEnvelope PsMessage
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
            (LHsType GhcPs
-> SDoc -> RdrName -> [LHsTypeArg GhcPs] -> SDoc -> PsMessage
PsErrUnexpectedTypeInDecl LHsType GhcPs
t SDoc
pp_what (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
tc) [LHsTypeArg GhcPs]
tparms SDoc
equals_or_where)

    -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
    for_widening :: HsBndrVis GhcPs -> AddEpAnn
    for_widening :: HsBndrVis GhcPs -> AddEpAnn
for_widening (HsBndrInvisible (EpTok EpaLocation
loc)) = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnAnyclass EpaLocation
loc
    for_widening  HsBndrVis GhcPs
_                            = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnAnyclass 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 [AddEpAnn] (LocatedN RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@

-- turns RuleTyTmVars into RuleBnrs - this is straightforward
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> GenLocated EpAnnCO (RuleBndr GhcPs))
-> [LRuleTyTmVar] -> [GenLocated EpAnnCO (RuleBndr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs)
-> LRuleTyTmVar -> GenLocated EpAnnCO (RuleBndr GhcPs)
forall a b.
(a -> b) -> GenLocated EpAnnCO a -> GenLocated EpAnnCO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
  where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar [AddEpAnn]
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> XRec GhcPs (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr [AddEpAnn]
XCRuleBndr GhcPs
ann XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v
        cvt_one (RuleTyTmVar [AddEpAnn]
ann LocatedN RdrName
v (Just LHsType GhcPs
sig)) =
          XRuleBndrSig GhcPs
-> XRec GhcPs (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig [AddEpAnn]
XRuleBndrSig GhcPs
ann XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v (EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnnCO
forall a. NoAnn a => a
noAnn LHsType GhcPs
sig)

-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
-> [LRuleTyTmVar]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LRuleTyTmVar -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
forall {a} {l}.
(HasLoc a, HasAnnotation l) =>
GenLocated a RuleTyTmVar -> GenLocated l (HsTyVarBndr () GhcPs)
cvt_one
  where cvt_one :: GenLocated a RuleTyTmVar -> GenLocated l (HsTyVarBndr () GhcPs)
cvt_one (L a
l (RuleTyTmVar [AddEpAnn]
ann LocatedN RdrName
v Maybe (LHsType GhcPs)
Nothing))
          = 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) (XUserTyVar GhcPs
-> () -> XRec GhcPs (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar [AddEpAnn]
XUserTyVar GhcPs
ann () ((RdrName -> RdrName) -> LocatedN RdrName -> LocatedN RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty LocatedN RdrName
v))
        cvt_one (L a
l (RuleTyTmVar [AddEpAnn]
ann LocatedN RdrName
v (Just LHsType GhcPs
sig)))
          = 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) (XKindedTyVar GhcPs
-> ()
-> XRec GhcPs (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar [AddEpAnn]
XKindedTyVar GhcPs
ann () ((RdrName -> RdrName) -> LocatedN RdrName -> LocatedN RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty LocatedN RdrName
v) LHsType GhcPs
sig)
    -- takes something in namespace 'varName' to something in namespace 'tvName'
        tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
        tm_to_ty RdrName
_ = String -> RdrName
forall a. HasCallStack => String -> a
panic String
"mkRuleTyVarBndrs"

-- See Note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> P ())
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GenLocated SrcSpanAnnA RdrName -> P ()
forall {f :: * -> *} {a}.
(MonadP f, HasLoc a) =>
GenLocated a RdrName -> f ()
check (GenLocated SrcSpanAnnA RdrName -> P ())
-> (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
    -> GenLocated SrcSpanAnnA RdrName)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr flag GhcPs -> RdrName)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)
-> GenLocated SrcSpanAnnA RdrName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr flag GhcPs -> IdP GhcPs
HsTyVarBndr flag GhcPs -> RdrName
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
  where check :: GenLocated a RdrName -> f ()
check (L a
loc (Unqual OccName
occ)) =
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OccName -> FastString
occNameFS OccName
occ FastString -> [FastString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String -> FastString
fsLit String
"family",String -> FastString
fsLit String
"role"])
            (MsgEnvelope PsMessage -> f ()
forall a. MsgEnvelope PsMessage -> f a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> f ()) -> MsgEnvelope PsMessage -> f ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA a
loc) (PsMessage -> MsgEnvelope PsMessage)
-> PsMessage -> MsgEnvelope PsMessage
forall a b. (a -> b) -> a -> b
$
               (OccName -> PsMessage
PsErrParseErrorOnInput OccName
occ))
        check GenLocated a RdrName
_ = String -> f ()
forall a. HasCallStack => String -> a
panic String
"checkRuleTyVarBndrNames"

checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax :: forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
LocatedA a -> m (LocatedA a)
checkRecordSyntax lr :: LocatedA a
lr@(L SrcSpanAnnA
loc a
r)
    = do allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $
                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))
         return lr

-- | 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 ([AddEpAnn], [LConDecl GhcPs])
                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
-> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddEpAnn], [LConDecl GhcPs])
gadts@(L SrcSpan
span ([AddEpAnn]
_, []))           -- 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 ([AddEpAnn], [LConDecl GhcPs])
gadts = Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
-> P (Located
        ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddEpAnn], [LConDecl GhcPs])
Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])
gadts              -- 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
                   [AddEpAnn],           -- API Annotation for HsParTy
                                         -- 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 (LocatedN RdrName, [LHsTypeArg GhcPs], LexicalFixity,
      [AddEpAnn], EpAnnComments)
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
  = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], 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))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
goL EpAnnComments
cs (L SrcSpanAnnA
l HsType GhcPs
ty) [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = EpAnnComments
-> SrcSpanAnnA
-> HsType GhcPs
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
go EpAnnComments
cs SrcSpanAnnA
l HsType GhcPs
ty [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix

    -- workaround to define '*' despite StarIsType
    go :: EpAnnComments
-> SrcSpanAnnA
-> HsType GhcPs
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
go EpAnnComments
cs SrcSpanAnnA
ll (HsParTy XParTy GhcPs
an (L SrcSpanAnnA
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops' [AddEpAnn]
cps' LexicalFixity
fix
      = do { SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) PsMessage
PsWarnStarBinder
           ; let name :: OccName
name = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
tcClsName (Bool -> FastString
starSym Bool
isUni)
           ; let a' :: SrcSpanAnnN
a' = SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
newAnns SrcSpanAnnA
ll SrcSpanAnnA
l XParTy GhcPs
AnnParen
an
           ; (LocatedN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [AddEpAnn], EpAnnComments)
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
a' (OccName -> RdrName
Unqual OccName
name), [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix
                    , ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops') [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps', EpAnnComments
cs) }

    go EpAnnComments
cs SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: XRec GhcPs (IdP GhcPs)
ltc@(L SrcSpanAnnN
_ RdrName
tc)) [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
      | RdrName -> Bool
isRdrTc RdrName
tc               = (LocatedN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [AddEpAnn], EpAnnComments)
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs)
LocatedN RdrName
ltc, [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
fix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps, EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l)
    go EpAnnComments
cs SrcSpanAnnA
l (HsOpTy XOpTy GhcPs
_ PromotionFlag
_ LHsType GhcPs
t1 ltc :: XRec GhcPs (IdP GhcPs)
ltc@(L SrcSpanAnnN
_ RdrName
tc) LHsType GhcPs
t2) [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
_fix
      | RdrName -> Bool
isRdrTc RdrName
tc               = (LocatedN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [AddEpAnn], EpAnnComments)
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs)
LocatedN RdrName
ltc, HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
lhsHsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
rhsHsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc, LexicalFixity
Infix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps, EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l)
      where lhs :: HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
lhs = XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
     GhcPs
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t1
            rhs :: HsArg
  GhcPs
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
rhs = XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
     GhcPs
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t2
    go EpAnnComments
cs SrcSpanAnnA
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)    [HsArg
   GhcPs
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], 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 (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
cps) LexicalFixity
fix
      where
        (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l))
    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 [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], 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) [AddEpAnn]
ops [AddEpAnn]
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 [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = EpAnnComments
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], 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) [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
    go EpAnnComments
cs SrcSpanAnnA
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
      = (LocatedN RdrName,
 [HsArg
    GhcPs
    (GenLocated SrcSpanAnnA (HsType GhcPs))
    (GenLocated SrcSpanAnnA (HsType GhcPs))],
 LexicalFixity, [AddEpAnn], EpAnnComments)
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
l) (Name -> RdrName
nameRdrName Name
tup_name)
               , (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsArg
      GhcPs
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (XValArg GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArg
     GhcPs
     (GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsType GhcPs))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcPs
noExtField) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts, LexicalFixity
fix, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops)[AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++[AddEpAnn]
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))]
_ [AddEpAnn]
_ [AddEpAnn]
_ LexicalFixity
_
      = MsgEnvelope PsMessage
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], EpAnnComments)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage
 -> P (LocatedN RdrName,
       [HsArg
          GhcPs
          (GenLocated SrcSpanAnnA (HsType GhcPs))
          (GenLocated SrcSpanAnnA (HsType GhcPs))],
       LexicalFixity, [AddEpAnn], EpAnnComments))
-> MsgEnvelope PsMessage
-> P (LocatedN RdrName,
      [HsArg
         GhcPs
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))],
      LexicalFixity, [AddEpAnn], 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 -> AnnParen -> SrcSpanAnnN
    newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
newAnns l :: SrcSpanAnnA
l@(EpAnn EpaLocation
_ (AnnListItem [TrailingAnn]
_) EpAnnComments
csp0) l1 :: SrcSpanAnnA
l1@(EpAnn EpaLocation
ap (AnnListItem [TrailingAnn]
ta) EpAnnComments
csp) (AnnParen ParenType
_ EpaLocation
o EpaLocation
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
-> EpaLocation
-> EpaLocation
-> [TrailingAnn]
-> NameAnn
NameAnn NameAdornment
NameParens EpaLocation
o EpaLocation
ap EpaLocation
c [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) =
  ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([],[],EpAnnComments
cs) LHsType GhcPs
orig_t
 where
  check :: ([EpaLocation],[EpaLocation],EpAnnComments)
        -> LHsType GhcPs -> P (LHsContext GhcPs)
  check :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsTupleTy XTupleTy GhcPs
ann' HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
    -- be used as context constraints.
    -- Ditto ()
    = ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
        SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpaLocation]
oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [AnnParen -> EpaLocation
ap_open XTupleTy GhcPs
AnnParen
ann'], AnnParen -> EpaLocation
ap_close XTupleTy GhcPs
AnnParen
ann' EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
: [EpaLocation]
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 ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsExplicitTupleTy XExplicitTupleTy GhcPs
anns [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
          ([AddEpAnn]
op, [AddEpAnn]
cp) = case XExplicitTupleTy GhcPs
anns of
            [AddEpAnn
o, AddEpAnn
c] -> ([AddEpAnn
o], [AddEpAnn
c])
            [AddEpAnn
q, AddEpAnn
_, AddEpAnn
c] -> ([AddEpAnn
q], [AddEpAnn
c])
            XExplicitTupleTy GhcPs
_ -> ([], [])
        ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
        SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpaLocation]
oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ (AddEpAnn -> EpaLocation
addLoc (AddEpAnn -> EpaLocation) -> [AddEpAnn] -> [EpaLocation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AddEpAnn]
op), (AddEpAnn -> EpaLocation
addLoc (AddEpAnn -> EpaLocation) -> [AddEpAnn] -> [EpaLocation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AddEpAnn]
cp) [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation]
cparens, EpAnnComments
cs) [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ts
  check ([EpaLocation]
opi,[EpaLocation]
cpi,EpAnnComments
csi) (L SrcSpanAnnA
_lp1 (HsParTy XParTy GhcPs
ann' LHsType GhcPs
ty))
                                  -- to be sure HsParTy doesn't get into the way
    = ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check (AnnParen -> EpaLocation
ap_open XParTy GhcPs
AnnParen
ann'EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
opi, AnnParen -> EpaLocation
ap_close XParTy GhcPs
AnnParen
ann'EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
:[EpaLocation]
cpi, EpAnnComments
csi) LHsType GhcPs
ty

  -- No need for anns, returning original
  check ([EpaLocation]
_opi,[EpaLocation]
_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 (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
orig_t])

  addLoc :: AddEpAnn -> EpaLocation
addLoc (AddEpAnn AnnKeywordId
_ EpaLocation
l) = EpaLocation
l

  mkCTuple :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> P (GenLocated
        SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
mkCTuple ([EpaLocation]
oparens, [EpaLocation]
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 (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing [EpaLocation]
oparens [EpaLocation]
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
_) =
  ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([],[], EpAnnComments
cs) LHsExpr GhcPs
orig_expr
  where
    check :: ([EpaLocation],[EpaLocation],EpAnnComments)
        -> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
    check :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_ (ExplicitTuple [AddEpAnn AnnKeywordId
_ EpaLocation
ap_open, AddEpAnn AnnKeywordId
_ 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
      = ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpaLocation]
oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation
ap_open], EpaLocation
ap_close EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
: [EpaLocation]
cparens, EpAnnComments
cs) [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es
    check ([EpaLocation]
opi, [EpaLocation]
cpi, EpAnnComments
csi) (L SrcSpanAnnA
_ (HsPar (EpTok EpaLocation
open_tok, EpTok EpaLocation
close_tok) LHsExpr GhcPs
expr))
      = ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
check ([EpaLocation]
opi [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation
open_tok], EpaLocation
close_tok EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
: [EpaLocation]
cpi, EpAnnComments
csi) LHsExpr GhcPs
expr
    check ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L (EpAnn EpaLocation
_ (NameAnnOnly NameAdornment
NameParens EpaLocation
open EpaLocation
closed []) EpAnnComments
_) RdrName
name)))
      | RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName (DataCon -> Name
dataConName DataCon
unitDataCon)
      = ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpaLocation]
oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation]
forall a. [a] -> [a] -> [a]
++ [EpaLocation
open], EpaLocation
closed EpaLocation -> [EpaLocation] -> [EpaLocation]
forall a. a -> [a] -> [a]
: [EpaLocation]
cparens, EpAnnComments
cs) []
    check ([EpaLocation], [EpaLocation], 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 (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) [LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
orig_expr])

    mkCTuple :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> PV
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
mkCTuple ([EpaLocation]
oparens, [EpaLocation]
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 (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext Maybe (IsUnicodeSyntax, EpaLocation)
forall a. Maybe a
Nothing [EpaLocation]
oparens [EpaLocation]
cparens) EpAnnComments
cs) [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ts)

checkImportDecl :: Maybe EpaLocation
                -> Maybe EpaLocation
                -> P ()
checkImportDecl :: Maybe EpaLocation -> Maybe EpaLocation -> P ()
checkImportDecl Maybe EpaLocation
mPre Maybe EpaLocation
mPost = do
  let whenJust :: Maybe a -> (a -> f ()) -> f ()
whenJust Maybe a
mg a -> f ()
f = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> f ()
f Maybe a
mg

  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 $ \EpaLocation
post ->
    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> P ()
failNotEnabledImportQualifiedPost (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
post) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)

  -- Error if 'qualified' occurs in both pre and postpositive
  -- positions.
  whenJust mPost $ \EpaLocation
post ->
    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe EpaLocation -> Bool
forall a. Maybe a -> Bool
isJust Maybe EpaLocation
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> P ()
failImportQualifiedTwice (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
post) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)

  -- Warn if 'qualified' found in prepositive position and
  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
  whenJust mPre $ \EpaLocation
pre ->
    SrcSpan -> P ()
warnPrepositiveQualifiedModule (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
pre) Maybe BufSpan
forall a. Maybe a
Strict.Nothing)

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

checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
checkLArgPat (L SrcSpanAnnA
l (ArgPatBuilderVisPat PatBuilder GhcPs
p)) = LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l PatBuilder GhcPs
p)
checkLArgPat (L SrcSpanAnnA
l (ArgPatBuilderArgPat Pat GhcPs
p)) = GenLocated SrcSpanAnnA (Pat GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcPs
p)

checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (L l :: SrcSpanAnnA
l@(EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
_) PatBuilder GhcPs
p) = do
  (L l' p', cs) <- SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat (EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
emptyComments) EpAnnComments
emptyComments (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l PatBuilder GhcPs
p) [] []
  return (L (addCommentsToEpAnn l' cs) p')

checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
         -> PV (LPat GhcPs, EpAnnComments)
-- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat`
-- productions
checkPat :: SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpanAnnN
ln RdrName
c))) [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
args
  | RdrName -> Bool
isRdrDataCon RdrName
c Bool -> Bool -> Bool
|| RdrName -> Bool
isRdrTc RdrName
c
  = (GenLocated SrcSpanAnnA (Pat GhcPs), EpAnnComments)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs), EpAnnComments)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat
      { pat_con_ext :: XConPat GhcPs
pat_con_ext = [AddEpAnn]
XConPat GhcPs
forall a. NoAnn a => a
noAnn -- AZ: where should this come from?
      , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ln RdrName
c
      , pat_args :: HsConPatDetails GhcPs
pat_args = [HsConPatTyArg GhcPs]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args
      }, SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
l EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs)
  | (Bool -> Bool
not ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec RdrName
c) = do
      ctx <- PV ParseContext
askParseContext
      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
la (PatBuilderAppType LocatedA (PatBuilder GhcPs)
f EpToken "@"
at HsTyPat GhcPs
t)) [HsConPatTyArg GhcPs]
tyargs [LPat GhcPs]
args =
  SrcSpanAnnA
-> EpAnnComments
-> LocatedA (PatBuilder GhcPs)
-> [HsConPatTyArg GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs, EpAnnComments)
checkPat SrcSpanAnnA
loc (EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
comments SrcSpanAnnA
la) LocatedA (PatBuilder GhcPs)
f (XConPatTyArg GhcPs -> HsTyPat GhcPs -> HsConPatTyArg GhcPs
forall p. XConPatTyArg p -> HsTyPat p -> HsConPatTyArg p
HsConPatTyArg EpToken "@"
XConPatTyArg GhcPs
at HsTyPat GhcPs
t HsConPatTyArg GhcPs
-> [HsConPatTyArg GhcPs] -> [HsConPatTyArg GhcPs]
forall a. a -> [a] -> [a]
: [HsConPatTyArg GhcPs]
tyargs) [LPat GhcPs]
args
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
la (PatBuilderApp LocatedA (PatBuilder GhcPs)
f LocatedA (PatBuilder GhcPs)
e)) [] [LPat GhcPs]
args = do
  p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
  checkPat loc (cs Semi.<> comments la) f [] (p : args)
checkPat SrcSpanAnnA
loc EpAnnComments
cs (L SrcSpanAnnA
l PatBuilder GhcPs
e) [] [] = do
  p <- SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e
  return (L l p, cs)
checkPat SrcSpanAnnA
loc EpAnnComments
_ LocatedA (PatBuilder GhcPs)
e [HsConPatTyArg GhcPs]
_ [LPat GhcPs]
_ = do
  details <- ParseContext -> PsErrInPatDetails
fromParseContext (ParseContext -> PsErrInPatDetails)
-> PV ParseContext -> PV PsErrInPatDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PV ParseContext
askParseContext
  patFail (locA loc) (PsErrInPat (unLoc e) details)

checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e0 = do
 nPlusKPatterns <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
NPlusKPatternsBit
 case e0 of
   PatBuilderPat Pat GhcPs
p -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat GhcPs
p
   PatBuilderVar LocatedN RdrName
x -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> XRec GhcPs (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField XRec GhcPs (IdP GhcPs)
LocatedN RdrName
x)

   -- 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) -> [AddEpAnn] -> 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 [AddEpAnn]
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 {}})))
           [AddEpAnn]
_
                     | Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
                     -> Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpaLocation -> Pat GhcPs
mkNPlusKPat (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc RdrName
n) (EpAnnCO -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnnCO
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
lloc) HsOverLit GhcPs
lit)
                                (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)
_ LocatedN RdrName
op LocatedA (PatBuilder GhcPs)
_ [AddEpAnn]
_ | RdrName -> Bool
opIsAt (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
op) -> do
     MsgEnvelope PsMessage -> PV ()
forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m ()
addError (MsgEnvelope PsMessage -> PV ()) -> MsgEnvelope PsMessage -> PV ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LocatedN RdrName
op) PsMessage
PsErrAtInPatPos
     Pat GhcPs -> PV (Pat GhcPs)
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExtField
noExtField)

   PatBuilderOpApp LocatedA (PatBuilder GhcPs)
l (L SrcSpanAnnN
cl RdrName
c) LocatedA (PatBuilder GhcPs)
r [AddEpAnn]
anns
     | 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 = anns
           , pat_con = L cl c
           , pat_args = InfixCon l r
           }

   PatBuilderPar EpToken "("
lpar LocatedA (PatBuilder GhcPs)
e EpToken ")"
rpar -> do
     p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
     return (ParPat (lpar, rpar) p)

   PatBuilder GhcPs
_           -> do
     details <- ParseContext -> PsErrInPatDetails
fromParseContext (ParseContext -> PsErrInPatDetails)
-> PV ParseContext -> PV PsErrInPatDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PV ParseContext
askParseContext
     patFail (locA loc) (PsErrInPat e0 details)

placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
-- 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 = LocatedN RdrName -> PV (LocatedA b)
forall b. DisambECP b => LocatedN RdrName -> PV (LocatedA b)
mkHsVarPV (RdrName -> LocatedN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
pun_RDR)

plus_RDR, pun_RDR :: RdrName
plus_RDR :: RdrName
plus_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"+") -- 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

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

checkValDef :: SrcSpan
-> LocatedA (PatBuilder GhcPs)
-> (HsMultAnn GhcPs, Maybe (AddEpAnn, LHsType GhcPs))
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult, Just (AddEpAnn
sigAnn, LHsType GhcPs
sig)) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
        -- x :: ty = rhs  parses as a *pattern* binding
  = do lhs' <- PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs))
 -> P (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> LHsType GhcPs
-> [AddEpAnn]
-> PV (LocatedA (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpanAnnA
-> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)
mkHsTySigPV (LocatedA (PatBuilder GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (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 [AddEpAnn
sigAnn]
                        PV (LocatedA (PatBuilder GhcPs))
-> (LocatedA (PatBuilder GhcPs)
    -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. PV a -> (a -> PV b) -> PV b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (PatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLPat
       checkPatBind loc lhs' grhss mult

checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult_ann, Maybe (AddEpAnn, LHsType GhcPs)
Nothing) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
  | HsNoMultAnn{} <- HsMultAnn GhcPs
mult_ann
  = do  { mb_fun <- LocatedA (PatBuilder GhcPs)
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
lhs
        ; case mb_fun of
            Just (LocatedN RdrName
fun, LexicalFixity
is_infix, [LocatedA (ArgPatBuilder GhcPs)]
pats, [AddEpAnn]
ann) -> do
              let l :: EpaLocation
l = [LocatedA (ArgPatBuilder GhcPs)] -> EpaLocation
forall an a. [LocatedAn an a] -> EpaLocation
listLocation [LocatedA (ArgPatBuilder GhcPs)]
pats
              SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> LocatedN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
NoSrcStrict SrcSpan
loc [AddEpAnn]
ann
                           LocatedN RdrName
fun LexicalFixity
is_infix (EpaLocation
-> [LocatedA (ArgPatBuilder GhcPs)]
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpaLocation
l [LocatedA (ArgPatBuilder GhcPs)]
pats) Located (GRHSs GhcPs (LHsExpr GhcPs))
grhss
            Maybe
  (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
   [AddEpAnn])
Nothing -> do
              lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
              checkPatBind loc lhs' grhss mult_ann }

checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs (HsMultAnn GhcPs
mult_ann, Maybe (AddEpAnn, LHsType GhcPs)
Nothing) Located (GRHSs GhcPs (LHsExpr GhcPs))
ghrss
        -- %p x = rhs  parses as a *pattern* binding
  = do lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
       checkPatBind loc lhs' ghrss mult_ann

checkFunBind :: SrcStrictness
             -> SrcSpan
             -> [AddEpAnn]
             -> LocatedN RdrName
             -> LexicalFixity
             -> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P (HsBind GhcPs)
checkFunBind :: SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> LocatedN RdrName
-> LexicalFixity
-> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
strictness SrcSpan
locF [AddEpAnn]
ann (L SrcSpanAnnN
lf RdrName
fun) LexicalFixity
is_infix (L EpaLocation
lp [LocatedA (ArgPatBuilder GhcPs)]
pats) (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss)
  = do  ps <- ParseContext
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> P [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. ParseContext -> PV a -> P a
runPV_details ParseContext
extraDetails ((LocatedA (ArgPatBuilder GhcPs)
 -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> [LocatedA (ArgPatBuilder GhcPs)]
-> PV [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
LocatedA (ArgPatBuilder GhcPs)
-> PV (GenLocated SrcSpanAnnA (Pat GhcPs))
checkLArgPat [LocatedA (ArgPatBuilder GhcPs)]
pats)
        let match_span = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ SrcSpan
locF
        return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)
                 [L match_span (Match { m_ext = ann
                                      , m_ctxt = FunRhs
                                          { mc_fun    = L lf fun
                                          , mc_fixity = is_infix
                                          , mc_strictness = strictness }
                                      , 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 -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
            -> HsBind GhcPs
-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
makeFunBind :: LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LocatedN RdrName
fn LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
ms
  = FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
NoExtField
noExtField,
              fun_id :: XRec GhcPs (IdP GhcPs)
fun_id = XRec GhcPs (IdP GhcPs)
LocatedN RdrName
fn,
              fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms }

-- See Note [FunBind vs PatBind]
checkPatBind :: SrcSpan
             -> LPat GhcPs
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> HsMultAnn GhcPs
             -> P (HsBind GhcPs)
checkPatBind :: SrcSpan
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> HsMultAnn GhcPs
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc (L SrcSpanAnnA
_ (BangPat XBangPat GhcPs
ans (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ XRec GhcPs (IdP GhcPs)
v))))
                        (L SrcSpan
_match_span GRHSs GhcPs (LHsExpr GhcPs)
grhss) (HsNoMultAnn XNoMultAnn GhcPs
_)
      = HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v (SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnL
forall 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) ([AddEpAnn]
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m [AddEpAnn]
XBangPat GhcPs
ans XRec GhcPs (IdP GhcPs)
LocatedN RdrName
v)]))
  where
    m :: [AddEpAnn]
-> LocatedN RdrName
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m [AddEpAnn]
a LocatedN RdrName
v = Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = [AddEpAnn]
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
a
                  , m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt = FunRhs { mc_fun :: LocatedN RdrName
mc_fun    = LocatedN RdrName
v
                                    , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                    , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict }
                  , m_pats :: XRec GhcPs [LPat GhcPs]
m_pats = [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA []
                 , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss }

checkPatBind SrcSpan
_loc LPat GhcPs
lhs (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss) HsMultAnn GhcPs
mult = do
  HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPatBind GhcPs GhcPs
-> LPat GhcPs
-> HsMultAnn GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> HsMultAnn idL
-> GRHSs idR (LHsExpr idR)
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExtField
noExtField LPat GhcPs
lhs HsMultAnn GhcPs
mult GRHSs GhcPs (LHsExpr GhcPs)
grhss)


checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpanAnnA
l HsExpr GhcPs
lhs_expr) =
  case HsExpr GhcPs
lhs_expr of
    HsVar XVar GhcPs
_ lrdr :: XRec GhcPs (IdP GhcPs)
lrdr@(L SrcSpanAnnN
_ RdrName
v) -> RdrName -> LocatedN RdrName -> P (LocatedN RdrName)
check_var RdrName
v XRec GhcPs (IdP GhcPs)
LocatedN RdrName
lrdr
    HsExpr GhcPs
_                    -> PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Other
  where
    check_var :: RdrName -> LocatedN RdrName -> P (LocatedN RdrName)
check_var RdrName
v LocatedN RdrName
lrdr
      | Bool -> Bool
not (RdrName -> Bool
isUnqual RdrName
v) = PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_Qualified
      | OccName -> Bool
isDataOcc OccName
occ_n  = PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
PsErrInvalidTypeSig_DataCon
      | Bool
otherwise        = LocatedN RdrName -> P (LocatedN RdrName)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedN RdrName
lrdr
      where occ_n :: OccName
occ_n = RdrName -> OccName
rdrNameOcc RdrName
v
    make_err :: PsInvalidTypeSignature -> P (LocatedN RdrName)
make_err PsInvalidTypeSignature
reason = MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a. MsgEnvelope PsMessage -> P a
forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a
addFatalError (MsgEnvelope PsMessage -> P (LocatedN RdrName))
-> MsgEnvelope PsMessage -> P (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (PsInvalidTypeSignature -> LHsExpr GhcPs -> PsMessage
PsErrInvalidTypeSignature PsInvalidTypeSignature
reason LHsExpr GhcPs
lhs)


checkDoAndIfThenElse
  :: (Outputable a, Outputable b, Outputable c)
  => (a -> Bool -> b -> Bool -> c -> PsMessage)
  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
checkDoAndIfThenElse :: forall a b c.
(Outputable a, Outputable b, Outputable c) =>
(a -> Bool -> b -> Bool -> c -> PsMessage)
-> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
checkDoAndIfThenElse a -> Bool -> b -> Bool -> c -> PsMessage
err GenLocated SrcSpanAnnA a
guardExpr Bool
semiThen LocatedA b
thenExpr Bool
semiElse GenLocated SrcSpanAnnA c
elseExpr
 | Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse = do
      doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
      let e   = a -> Bool -> b -> Bool -> c -> PsMessage
err (GenLocated SrcSpanAnnA a -> a
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA a
guardExpr)
                    Bool
semiThen (LocatedA b -> b
forall l e. GenLocated l e -> e
unLoc LocatedA b
thenExpr)
                    Bool
semiElse (GenLocated SrcSpanAnnA c -> c
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA c
elseExpr)
          loc = Located a -> Located c -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs (GenLocated SrcSpanAnnA a -> Located a
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpanAnnA a
guardExpr) (GenLocated SrcSpanAnnA c -> Located c
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpanAnnA c
elseExpr)

      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)
  | Bool
otherwise = () -> PV ()
forall a. a -> PV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

isFunLhs :: LocatedA (PatBuilder GhcPs)
      -> P (Maybe (LocatedN RdrName, LexicalFixity,
                   [LocatedA (ArgPatBuilder GhcPs)],[AddEpAnn]))
-- 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
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
e = LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [AddEpAnn]
-> [AddEpAnn]
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
go LocatedA (PatBuilder GhcPs)
e [] [] []
 where
   mk :: GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk = (PatBuilder p -> ArgPatBuilder p)
-> GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatBuilder p -> ArgPatBuilder p
forall p. PatBuilder p -> ArgPatBuilder p
ArgPatBuilderVisPat

   go :: LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [AddEpAnn]
-> [AddEpAnn]
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
go (L SrcSpanAnnA
l (PatBuilderVar (L SrcSpanAnnN
loc RdrName
f))) [LocatedA (ArgPatBuilder GhcPs)]
es [AddEpAnn]
ops [AddEpAnn]
cps
       | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f)        = do
           let (SrcSpanAnnA
_l, SrcSpanAnnN
loc') = SrcSpanAnnA -> SrcSpanAnnN -> (SrcSpanAnnA, SrcSpanAnnN)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnN
loc
           Maybe
  (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
   [AddEpAnn])
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
 [AddEpAnn])
-> Maybe
     (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
      [AddEpAnn])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
f, LexicalFixity
Prefix, [LocatedA (ArgPatBuilder GhcPs)]
es, ([AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps))
   go (L SrcSpanAnnA
l (PatBuilderApp (L SrcSpanAnnA
lf PatBuilder GhcPs
f) LocatedA (PatBuilder GhcPs)
e))   [LocatedA (ArgPatBuilder GhcPs)]
es       [AddEpAnn]
ops [AddEpAnn]
cps = do
     let (SrcSpanAnnA
_l, SrcSpanAnnA
lf') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
forall a b. EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA SrcSpanAnnA
l SrcSpanAnnA
lf
     LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [AddEpAnn]
-> [AddEpAnn]
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lf' PatBuilder GhcPs
f) (LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk LocatedA (PatBuilder GhcPs)
eLocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[LocatedA (ArgPatBuilder GhcPs)]
es) [AddEpAnn]
ops [AddEpAnn]
cps
   go (L SrcSpanAnnA
l (PatBuilderPar EpToken "("
_ (L SrcSpanAnnA
le PatBuilder GhcPs
e) EpToken ")"
_)) es :: [LocatedA (ArgPatBuilder GhcPs)]
es@(LocatedA (ArgPatBuilder GhcPs)
_:[LocatedA (ArgPatBuilder GhcPs)]
_) [AddEpAnn]
ops [AddEpAnn]
cps = LocatedA (PatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [AddEpAnn]
-> [AddEpAnn]
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
go (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
le' PatBuilder GhcPs
e) [LocatedA (ArgPatBuilder GhcPs)]
es (AddEpAnn
oAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cAddEpAnn -> [AddEpAnn] -> [AddEpAnn]
forall a. a -> [a] -> [a]
:[AddEpAnn]
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
       (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
   go (L SrcSpanAnnA
loc (PatBuilderOpApp (L SrcSpanAnnA
ll PatBuilder GhcPs
l) (L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder GhcPs)
r [AddEpAnn]
anns)) [LocatedA (ArgPatBuilder GhcPs)]
es [AddEpAnn]
ops [AddEpAnn]
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
  (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
   [AddEpAnn])
-> P (Maybe
        (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
         [AddEpAnn]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
 [AddEpAnn])
-> Maybe
     (LocatedN RdrName, LexicalFixity, [LocatedA (ArgPatBuilder GhcPs)],
      [AddEpAnn])
forall a. a -> Maybe a
Just (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op, LexicalFixity
Infix, (LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk (SrcSpanAnnA -> PatBuilder GhcPs -> LocatedA (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ll' PatBuilder GhcPs
l)LocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:LocatedA (PatBuilder GhcPs) -> LocatedA (ArgPatBuilder GhcPs)
forall {p}.
GenLocated SrcSpanAnnA (PatBuilder p)
-> GenLocated SrcSpanAnnA (ArgPatBuilder p)
mk LocatedA (PatBuilder GhcPs)
rLocatedA (ArgPatBuilder GhcPs)
-> [LocatedA (ArgPatBuilder GhcPs)]
-> [LocatedA (ArgPatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[LocatedA (ArgPatBuilder GhcPs)]
es), ([AddEpAnn]
anns [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a]
reverse [AddEpAnn]
ops [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn]
forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps))) }
      | Bool
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