{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} -- -- (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, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, LRuleTyTmVar, RuleTyTmVar(..), mkRuleBndrs, mkRuleTyVarBndrs, checkRuleTyVarBndrNames, checkRecordSyntax, checkEmptyGADTs, addFatalError, hintBangPat, mkBangTy, UnpackednessPragma(..), mkMultTy, -- 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, PatBuilder, -- Type/datacon ambiguity resolution DisambTD(..), addUnpackednessP, dataConBuilderCon, dataConBuilderDetails, ) where import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import GHC.Core.DataCon ( DataCon, dataConTyCon ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.Hint import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing import GHC.Core.Type ( Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, unrestrictedFunTyCon ) import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) import GHC.Data.OrdList import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe import GHC.Utils.Error import GHC.Utils.Misc import Data.Either import Data.List ( findIndex ) import Data.Foldable import qualified Data.Semigroup as Semi import GHC.Utils.Panic import GHC.Utils.Panic.Plain import qualified GHC.Data.Strict as Strict import 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) -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs) mkClassDecl :: forall a. SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs) mkClassDecl SrcSpan loc' (L SrcSpan _ (Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs tycl_hdr)) Located (a, [LHsFunDep GhcPs]) fds OrdList (LHsDecl GhcPs) where_cls LayoutInfo GhcPs layoutInfo [AddEpAnn] annsIn = do { let loc :: SrcSpanAnnA loc = SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc' ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)) binds, [GenLocated SrcSpanAnnA (Sig GhcPs)] sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] ats, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] at_defs, [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] _, [GenLocated SrcSpanAnnA (DocDecl GhcPs)] docs) <- OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) cvBindsAndSigs OrdList (LHsDecl GhcPs) where_cls ; (GenLocated SrcSpanAnnN RdrName cls, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool True LHsType GhcPs tycl_hdr ; LHsQTyVars GhcPs tyvars <- SDoc -> SDoc -> GenLocated SrcSpanAnnN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) checkTyVars (String -> SDoc forall doc. IsLine doc => String -> doc text String "class") SDoc whereDots GenLocated SrcSpanAnnN RdrName cls [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) -- Get any remaining comments ; let anns' :: EpAnn [AddEpAnn] anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) [AddEpAnn] annsIn EpAnnComments emptyComments) [AddEpAnn] ann EpAnnComments cs ; GenLocated SrcSpanAnnA (TyClDecl GhcPs) -> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA loc (ClassDecl { tcdCExt :: XClassDecl GhcPs tcdCExt = (EpAnn [AddEpAnn] anns', AnnSortKey NoAnnSortKey) , tcdLayout :: LayoutInfo GhcPs tcdLayout = LayoutInfo GhcPs layoutInfo , tcdCtxt :: Maybe (LHsContext GhcPs) tcdCtxt = Maybe (LHsContext GhcPs) mcxt , tcdLName :: XRec GhcPs (IdP GhcPs) tcdLName = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName cls, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars , tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity , tcdFDs :: [LHsFunDep GhcPs] tcdFDs = (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)]) -> [GenLocated SrcSpanAnnA (FunDep GhcPs)] forall a b. (a, b) -> b snd (GenLocated SrcSpan (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)]) -> (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)]) forall l e. GenLocated l e -> e unLoc Located (a, [LHsFunDep GhcPs]) GenLocated SrcSpan (a, [GenLocated SrcSpanAnnA (FunDep GhcPs)]) fds) , tcdSigs :: [LSig GhcPs] tcdSigs = [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs [LSig GhcPs] [GenLocated SrcSpanAnnA (Sig GhcPs)] sigs , tcdMeths :: LHsBinds GhcPs tcdMeths = LHsBinds GhcPs Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)) binds , tcdATs :: [LFamilyDecl GhcPs] tcdATs = [LFamilyDecl GhcPs] [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] ats, tcdATDefs :: [LTyFamInstDecl GhcPs] tcdATDefs = [LTyFamInstDecl GhcPs] [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] at_defs , tcdDocs :: [LDocDecl GhcPs] tcdDocs = [LDocDecl GhcPs] [GenLocated SrcSpanAnnA (DocDecl GhcPs)] docs })) } mkTyData :: SrcSpan -> 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 { let loc :: SrcSpanAnnA loc = SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc' ; (GenLocated SrcSpanAnnN RdrName tc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool False LHsType GhcPs tycl_hdr ; LHsQTyVars GhcPs tyvars <- SDoc -> SDoc -> GenLocated SrcSpanAnnN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) checkTyVars (NewOrData -> SDoc forall a. Outputable a => a -> SDoc ppr NewOrData new_or_data) SDoc equalsDots GenLocated SrcSpanAnnN RdrName tc [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) -- Get any remaining comments ; let anns' :: EpAnn [AddEpAnn] anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) [AddEpAnn] annsIn EpAnnComments emptyComments) [AddEpAnn] ann EpAnnComments cs ; DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) data_cons <- SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] -> P (DataDefnCons (LConDecl GhcPs)) checkNewOrData (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName tc) Bool is_type_data NewOrData new_or_data [LConDecl GhcPs] data_cons ; HsDataDefn GhcPs defn <- 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) DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) data_cons HsDeriving GhcPs maybe_deriv ; GenLocated SrcSpanAnnA (TyClDecl GhcPs) -> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA loc (DataDecl { tcdDExt :: XDataDecl GhcPs tcdDExt = XDataDecl GhcPs EpAnn [AddEpAnn] anns', tcdLName :: XRec GhcPs (IdP GhcPs) tcdLName = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tc, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars, tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity, tcdDataDefn :: HsDataDefn GhcPs tcdDataDefn = HsDataDefn GhcPs 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 { (GenLocated SrcSpanAnnN RdrName tc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; EpAnnComments cs1 <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc -- Add any API Annotations to the top SrcSpan [temp] ; LHsQTyVars GhcPs tyvars <- SDoc -> SDoc -> GenLocated SrcSpanAnnN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) checkTyVars (String -> SDoc forall doc. IsLine doc => String -> doc text String "type") SDoc equalsDots GenLocated SrcSpanAnnN RdrName tc [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams ; EpAnnComments cs2 <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc -- Add any API Annotations to the top SrcSpan [temp] ; let anns' :: EpAnn [AddEpAnn] anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] annsIn EpAnnComments emptyComments) [AddEpAnn] ann (EpAnnComments cs1 EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs2) ; GenLocated SrcSpanAnnA (TyClDecl GhcPs) -> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (SynDecl { tcdSExt :: XSynDecl GhcPs tcdSExt = XSynDecl GhcPs EpAnn [AddEpAnn] anns' , tcdLName :: XRec GhcPs (IdP GhcPs) tcdLName = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tc, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars , tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity , tcdRhs :: LHsType GhcPs tcdRhs = LHsType GhcPs rhs })) } mkStandaloneKindSig :: SrcSpan -> Located [LocatedN RdrName] -- LHS -> LHsSigType GhcPs -- RHS -> [AddEpAnn] -> P (LStandaloneKindSig GhcPs) mkStandaloneKindSig :: SrcSpan -> Located [GenLocated SrcSpanAnnN RdrName] -> LHsSigType GhcPs -> [AddEpAnn] -> P (LStandaloneKindSig GhcPs) mkStandaloneKindSig SrcSpan loc Located [GenLocated SrcSpanAnnN RdrName] lhs LHsSigType GhcPs rhs [AddEpAnn] anns = do { [GenLocated SrcSpanAnnN RdrName] vs <- (GenLocated SrcSpanAnnN RdrName -> P (GenLocated SrcSpanAnnN RdrName)) -> [GenLocated SrcSpanAnnN RdrName] -> P [GenLocated SrcSpanAnnN RdrName] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM GenLocated SrcSpanAnnN RdrName -> P (GenLocated SrcSpanAnnN RdrName) forall {m :: * -> *} {a}. MonadP m => GenLocated (SrcSpanAnn' a) RdrName -> m (GenLocated (SrcSpanAnn' a) RdrName) check_lhs_name (Located [GenLocated SrcSpanAnnN RdrName] -> [GenLocated SrcSpanAnnN RdrName] forall l e. GenLocated l e -> e unLoc Located [GenLocated SrcSpanAnnN RdrName] lhs) ; GenLocated SrcSpanAnnN RdrName v <- [GenLocated SrcSpanAnnN RdrName] -> P (GenLocated SrcSpanAnnN RdrName) check_singular_lhs ([GenLocated SrcSpanAnnN RdrName] -> [GenLocated SrcSpanAnnN RdrName] forall a. [a] -> [a] reverse [GenLocated SrcSpanAnnN RdrName] vs) ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc ; GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))) -> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> P (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> StandaloneKindSig GhcPs -> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (StandaloneKindSig GhcPs -> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)) -> StandaloneKindSig GhcPs -> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) forall a b. (a -> b) -> a -> b $ XStandaloneKindSig GhcPs -> XRec GhcPs (IdP GhcPs) -> LHsSigType GhcPs -> StandaloneKindSig GhcPs forall pass. XStandaloneKindSig pass -> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass StandaloneKindSig (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] anns EpAnnComments cs) XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName v LHsSigType GhcPs rhs } where check_lhs_name :: GenLocated (SrcSpanAnn' a) RdrName -> m (GenLocated (SrcSpanAnn' a) RdrName) check_lhs_name v :: GenLocated (SrcSpanAnn' a) RdrName v@(GenLocated (SrcSpanAnn' a) RdrName -> RdrName forall l e. GenLocated l e -> e unLoc->RdrName name) = if RdrName -> Bool isUnqual RdrName name Bool -> Bool -> Bool && OccName -> Bool isTcOcc (RdrName -> OccName rdrNameOcc RdrName name) then GenLocated (SrcSpanAnn' a) RdrName -> m (GenLocated (SrcSpanAnn' a) RdrName) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return GenLocated (SrcSpanAnn' a) RdrName v else MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName) forall a. MsgEnvelope PsMessage -> m a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName)) -> MsgEnvelope PsMessage -> m (GenLocated (SrcSpanAnn' a) RdrName) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (GenLocated (SrcSpanAnn' a) RdrName -> SrcSpan forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA GenLocated (SrcSpanAnn' a) RdrName v) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (RdrName -> PsMessage PsErrUnexpectedQualifiedConstructor (GenLocated (SrcSpanAnn' a) RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated (SrcSpanAnn' a) RdrName v)) check_singular_lhs :: [GenLocated SrcSpanAnnN RdrName] -> P (GenLocated SrcSpanAnnN RdrName) check_singular_lhs [GenLocated SrcSpanAnnN RdrName] vs = case [GenLocated SrcSpanAnnN RdrName] vs of [] -> String -> P (GenLocated SrcSpanAnnN RdrName) forall a. HasCallStack => String -> a panic String "mkStandaloneKindSig: empty left-hand side" [GenLocated SrcSpanAnnN RdrName v] -> GenLocated SrcSpanAnnN RdrName -> P (GenLocated SrcSpanAnnN RdrName) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return GenLocated SrcSpanAnnN RdrName v [GenLocated SrcSpanAnnN RdrName] _ -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName)) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (Located [GenLocated SrcSpanAnnN RdrName] -> SrcSpan forall l e. GenLocated l e -> l getLoc Located [GenLocated SrcSpanAnnN RdrName] lhs) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ ([XRec GhcPs (IdP GhcPs)] -> PsMessage PsErrMultipleNamesInStandaloneKindSignature [XRec GhcPs (IdP GhcPs)] [GenLocated SrcSpanAnnN RdrName] vs) mkTyFamInstEqn :: SrcSpan -> HsOuterFamEqnTyVarBndrs GhcPs -> LHsType GhcPs -> LHsType GhcPs -> [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 { (GenLocated SrcSpanAnnN RdrName tc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc ; GenLocated SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) -> P (GenLocated SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> GenLocated SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> GenLocated SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))) -> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) -> GenLocated SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) forall a b. (a -> b) -> a -> b $ FamEqn { feqn_ext :: XCFamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) feqn_ext = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) ([AddEpAnn] anns [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. Monoid a => a -> a -> a `mappend` [AddEpAnn] ann) EpAnnComments cs , feqn_tycon :: XRec GhcPs (IdP GhcPs) feqn_tycon = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tc , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs bndrs , feqn_pats :: [LHsTypeArg GhcPs] feqn_pats = [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams , feqn_fixity :: LexicalFixity feqn_fixity = LexicalFixity fixity , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcPs) feqn_rhs = LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) rhs })} mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (LocatedP CType) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LInstDecl GhcPs) mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (LocatedP CType) -> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LInstDecl GhcPs) mkDataFamInst SrcSpan loc NewOrData new_or_data Maybe (LocatedP CType) cType (Maybe (LHsContext GhcPs) mcxt, HsOuterFamEqnTyVarBndrs GhcPs bndrs, LHsType GhcPs tycl_hdr) Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons (L SrcSpan _ HsDeriving GhcPs maybe_deriv) [AddEpAnn] anns = do { (GenLocated SrcSpanAnnN RdrName tc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool False LHsType GhcPs tycl_hdr ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc -- Add any API Annotations to the top SrcSpan ; let fam_eqn_ans :: EpAnn [AddEpAnn] fam_eqn_ans = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] ann EpAnnComments cs) [AddEpAnn] anns EpAnnComments emptyComments ; DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) data_cons <- SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] -> P (DataDefnCons (LConDecl GhcPs)) checkNewOrData SrcSpan loc (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName tc) Bool False NewOrData new_or_data [LConDecl GhcPs] data_cons ; HsDataDefn GhcPs defn <- 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) DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) data_cons HsDeriving GhcPs maybe_deriv ; GenLocated SrcSpanAnnA (InstDecl GhcPs) -> P (GenLocated SrcSpanAnnA (InstDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> InstDecl GhcPs -> GenLocated SrcSpanAnnA (InstDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass DataFamInstD XDataFamInstD GhcPs NoExtField noExtField (FamEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs forall pass. FamEqn pass (HsDataDefn pass) -> DataFamInstDecl pass DataFamInstDecl (FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs) feqn_ext = XCFamEqn GhcPs (HsDataDefn GhcPs) EpAnn [AddEpAnn] fam_eqn_ans , feqn_tycon :: XRec GhcPs (IdP GhcPs) feqn_tycon = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tc , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs bndrs , feqn_pats :: [LHsTypeArg GhcPs] feqn_pats = [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams , feqn_fixity :: LexicalFixity feqn_fixity = LexicalFixity fixity , feqn_rhs :: HsDataDefn GhcPs feqn_rhs = HsDataDefn GhcPs defn })))) } -- 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 EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc GenLocated SrcSpanAnnA (InstDecl GhcPs) -> P (GenLocated SrcSpanAnnA (InstDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> InstDecl GhcPs -> GenLocated SrcSpanAnnA (InstDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass TyFamInstD XTyFamInstD GhcPs NoExtField noExtField (XCTyFamInstDecl GhcPs -> TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs forall pass. XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass TyFamInstDecl (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] anns EpAnnComments cs) TyFamInstEqn GhcPs eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> TopLevelFlag -> LHsType GhcPs -- 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 { (GenLocated SrcSpanAnnN RdrName tc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams, LexicalFixity fixity, [AddEpAnn] ann) <- Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; EpAnnComments cs1 <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc -- Add any API Annotations to the top SrcSpan [temp] ; LHsQTyVars GhcPs tyvars <- SDoc -> SDoc -> GenLocated SrcSpanAnnN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) checkTyVars (FamilyInfo GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr FamilyInfo GhcPs info) SDoc equals_or_where GenLocated SrcSpanAnnN RdrName tc [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparams ; EpAnnComments cs2 <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc -- Add any API Annotations to the top SrcSpan [temp] ; let anns' :: EpAnn [AddEpAnn] anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] annsIn EpAnnComments emptyComments) [AddEpAnn] ann (EpAnnComments cs1 EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs2) ; GenLocated SrcSpanAnnA (TyClDecl GhcPs) -> P (GenLocated SrcSpanAnnA (TyClDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> TyClDecl GhcPs -> GenLocated SrcSpanAnnA (TyClDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass FamDecl XFamDecl GhcPs NoExtField noExtField (FamilyDecl { fdExt :: XCFamilyDecl GhcPs fdExt = XCFamilyDecl GhcPs EpAnn [AddEpAnn] anns' , fdTopLevel :: TopLevelFlag fdTopLevel = TopLevelFlag topLevel , fdInfo :: FamilyInfo GhcPs fdInfo = FamilyInfo GhcPs info, fdLName :: XRec GhcPs (IdP GhcPs) fdLName = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tc , fdTyVars :: LHsQTyVars GhcPs fdTyVars = LHsQTyVars GhcPs tyvars , fdFixity :: LexicalFixity fdFixity = LexicalFixity fixity , fdResultSig :: LFamilyResultSig GhcPs fdResultSig = LFamilyResultSig GhcPs ksig , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs) fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs) injAnn }))) } where equals_or_where :: SDoc equals_or_where = case FamilyInfo GhcPs info of FamilyInfo GhcPs DataFamily -> SDoc forall doc. IsOutput doc => doc empty FamilyInfo GhcPs OpenTypeFamily -> SDoc forall doc. IsOutput doc => doc empty ClosedTypeFamily {} -> SDoc whereDots mkSpliceDecl :: LHsExpr GhcPs -> P (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 -> P (LHsDecl GhcPs) mkSpliceDecl lexpr :: LHsExpr GhcPs lexpr@(L SrcSpanAnnA loc HsExpr GhcPs expr) | HsUntypedSplice XUntypedSplice GhcPs _ splice :: HsUntypedSplice GhcPs splice@(HsUntypedSpliceExpr {}) <- HsExpr GhcPs expr = do EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))) -> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann addCommentsToSrcAnn SrcSpanAnnA loc EpAnnComments cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)) -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall a b. (a -> b) -> a -> b $ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> XRec GhcPs (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 loc HsUntypedSplice GhcPs splice) SpliceDecoration DollarSplice) | HsUntypedSplice XUntypedSplice GhcPs _ splice :: HsUntypedSplice GhcPs splice@(HsQuasiQuote {}) <- HsExpr GhcPs expr = do EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))) -> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann addCommentsToSrcAnn SrcSpanAnnA loc EpAnnComments cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)) -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall a b. (a -> b) -> a -> b $ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> XRec GhcPs (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 loc HsUntypedSplice GhcPs splice) SpliceDecoration DollarSplice) | Bool otherwise = do EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))) -> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (HsDecl GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann addCommentsToSrcAnn SrcSpanAnnA loc EpAnnComments cs) (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)) -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs) forall a b. (a -> b) -> a -> b $ XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> XRec GhcPs (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 loc (XUntypedSpliceExpr GhcPs -> LHsExpr GhcPs -> HsUntypedSplice GhcPs forall id. XUntypedSpliceExpr id -> LHsExpr id -> HsUntypedSplice id HsUntypedSpliceExpr XUntypedSpliceExpr GhcPs EpAnn [AddEpAnn] forall a. EpAnn a noAnn LHsExpr GhcPs lexpr)) SpliceDecoration BareSplice) mkRoleAnnotDecl :: SrcSpan -> LocatedN RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles -> [AddEpAnn] -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl :: SrcSpan -> GenLocated SrcSpanAnnN RdrName -> [Located (Maybe FastString)] -> [AddEpAnn] -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl SrcSpan loc GenLocated SrcSpanAnnN RdrName tycon [Located (Maybe FastString)] roles [AddEpAnn] anns = do { [GenLocated (SrcAnn NoEpAnns) (Maybe Role)] roles' <- (Located (Maybe FastString) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))) -> [Located (Maybe FastString)] -> P [GenLocated (SrcAnn NoEpAnns) (Maybe Role)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM Located (Maybe FastString) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) parse_role [Located (Maybe FastString)] roles ; EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc ; GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))) -> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> P (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> RoleAnnotDecl GhcPs -> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (RoleAnnotDecl GhcPs -> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)) -> RoleAnnotDecl GhcPs -> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) forall a b. (a -> b) -> a -> b $ XCRoleAnnotDecl GhcPs -> XRec GhcPs (IdP GhcPs) -> [XRec GhcPs (Maybe Role)] -> RoleAnnotDecl GhcPs forall pass. XCRoleAnnotDecl pass -> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass RoleAnnotDecl (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] anns EpAnnComments cs) XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName tycon [XRec GhcPs (Maybe Role)] [GenLocated (SrcAnn NoEpAnns) (Maybe Role)] roles' } where role_data_type :: DataType role_data_type = Role -> DataType forall a. Data a => a -> DataType dataTypeOf (Role forall a. HasCallStack => a undefined :: Role) all_roles :: [Role] all_roles = (Constr -> Role) -> [Constr] -> [Role] forall a b. (a -> b) -> [a] -> [b] map Constr -> Role forall a. Data a => Constr -> a fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role] forall a b. (a -> b) -> a -> b $ DataType -> [Constr] dataTypeConstrs DataType role_data_type possible_roles :: [(FastString, Role)] possible_roles = [(Role -> FastString fsFromRole Role role, Role role) | Role role <- [Role] all_roles] parse_role :: Located (Maybe FastString) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) parse_role (L SrcSpan loc_role Maybe FastString Nothing) = GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))) -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcAnn NoEpAnns -> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcAnn NoEpAnns forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc_role) Maybe Role forall a. Maybe a Nothing parse_role (L SrcSpan loc_role (Just FastString role)) = case FastString -> [(FastString, Role)] -> Maybe Role forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup FastString role [(FastString, Role)] possible_roles of Just Role found_role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))) -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcAnn NoEpAnns -> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcAnn NoEpAnns forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc_role) (Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role)) -> Maybe Role -> GenLocated (SrcAnn NoEpAnns) (Maybe Role) forall a b. (a -> b) -> a -> b $ Role -> Maybe Role forall a. a -> Maybe a Just Role found_role Maybe Role Nothing -> let nearby :: [Role] nearby = String -> [(String, Role)] -> [Role] forall a. String -> [(String, a)] -> [a] fuzzyLookup (FastString -> String unpackFS FastString role) ((FastString -> String) -> [(FastString, Role)] -> [(String, Role)] forall (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 (SrcAnn NoEpAnns) (Maybe Role)) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role))) -> MsgEnvelope PsMessage -> P (GenLocated (SrcAnn NoEpAnns) (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc_role (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (FastString -> [Role] -> PsMessage PsErrIllegalRoleName FastString role [Role] nearby) -- | 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. SrcSpanAnn' 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 -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList add_where AddEpAnn a XHsValBinds GhcPs GhcPs EpAnn AnnList an EpAnnComments cs) HsValBindsLR GhcPs GhcPs bs, Maybe EpAnnComments forall a. Maybe a Nothing) annBinds AddEpAnn a EpAnnComments cs (HsIPBinds XHsIPBinds GhcPs GhcPs an HsIPBinds GhcPs bs) = (XHsIPBinds GhcPs GhcPs -> HsIPBinds GhcPs -> HsLocalBinds GhcPs forall idL idR. XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR HsIPBinds (AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList add_where AddEpAnn a XHsIPBinds GhcPs GhcPs EpAnn AnnList an EpAnnComments cs) HsIPBinds GhcPs bs, Maybe EpAnnComments forall a. Maybe a Nothing) annBinds AddEpAnn _ EpAnnComments cs (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs x) = (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs x, EpAnnComments -> Maybe EpAnnComments forall a. a -> Maybe a Just EpAnnComments cs) add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList add_where an :: AddEpAnn an@(AddEpAnn AnnKeywordId _ (EpaSpan RealSrcSpan rs Maybe BufSpan _)) (EpAnn Anchor a (AnnList Maybe Anchor anc Maybe AddEpAnn o Maybe AddEpAnn c [AddEpAnn] r [TrailingAnn] t) EpAnnComments cs) EpAnnComments cs2 | RealSrcSpan -> Bool valid_anchor (Anchor -> RealSrcSpan anchor Anchor a) = Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (Anchor -> [AddEpAnn] -> Anchor widenAnchor Anchor a [AddEpAnn an]) (Maybe Anchor -> Maybe AddEpAnn -> Maybe AddEpAnn -> [AddEpAnn] -> [TrailingAnn] -> AnnList AnnList Maybe Anchor anc Maybe AddEpAnn o Maybe AddEpAnn c (AddEpAnn anAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] r) [TrailingAnn] t) (EpAnnComments cs EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs2) | Bool otherwise = Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (RealSrcSpan -> Anchor -> Anchor patch_anchor RealSrcSpan rs Anchor a) (Maybe Anchor -> Maybe AddEpAnn -> Maybe AddEpAnn -> [AddEpAnn] -> [TrailingAnn] -> AnnList AnnList ((Anchor -> Anchor) -> Maybe Anchor -> Maybe Anchor forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (RealSrcSpan -> Anchor -> Anchor patch_anchor RealSrcSpan rs) Maybe Anchor anc) Maybe AddEpAnn o Maybe AddEpAnn c (AddEpAnn anAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] r) [TrailingAnn] t) (EpAnnComments cs EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs2) add_where an :: AddEpAnn an@(AddEpAnn AnnKeywordId _ (EpaSpan RealSrcSpan rs Maybe BufSpan _)) EpAnn AnnList EpAnnNotUsed EpAnnComments cs = Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (RealSrcSpan -> AnchorOperation -> Anchor Anchor RealSrcSpan rs AnchorOperation UnchangedAnchor) (Maybe Anchor -> Maybe AddEpAnn -> Maybe AddEpAnn -> [AddEpAnn] -> [TrailingAnn] -> AnnList AnnList (Anchor -> Maybe Anchor forall a. a -> Maybe a Just (Anchor -> Maybe Anchor) -> Anchor -> Maybe Anchor forall a b. (a -> b) -> a -> b $ RealSrcSpan -> AnchorOperation -> Anchor Anchor RealSrcSpan rs AnchorOperation UnchangedAnchor) Maybe AddEpAnn forall a. Maybe a Nothing Maybe AddEpAnn forall a. Maybe a Nothing [AddEpAnn an] []) EpAnnComments cs add_where (AddEpAnn AnnKeywordId _ (EpaDelta DeltaPos _ [LEpaComment] _)) EpAnn AnnList _ EpAnnComments _ = String -> EpAnn AnnList forall a. HasCallStack => String -> a panic String "add_where" -- EpaDelta should only be used for transformations valid_anchor :: RealSrcSpan -> Bool valid_anchor :: RealSrcSpan -> Bool valid_anchor RealSrcSpan r = RealSrcSpan -> Int srcSpanStartLine RealSrcSpan r Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int 0 -- If the decl list for where binds is empty, the anchor ends up -- invalid. In this case, use the parent one patch_anchor :: RealSrcSpan -> Anchor -> Anchor patch_anchor :: RealSrcSpan -> Anchor -> Anchor patch_anchor RealSrcSpan r1 (Anchor RealSrcSpan r0 AnchorOperation op) = RealSrcSpan -> AnchorOperation -> Anchor Anchor RealSrcSpan r AnchorOperation op where r :: RealSrcSpan r = if RealSrcSpan -> Int srcSpanStartLine RealSrcSpan r0 Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 then RealSrcSpan r1 else RealSrcSpan r0 fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList fixValbindsAnn EpAnn AnnList EpAnnNotUsed = EpAnn AnnList forall a. EpAnn a EpAnnNotUsed fixValbindsAnn (EpAnn Anchor anchor (AnnList Maybe Anchor ma Maybe AddEpAnn o Maybe AddEpAnn c [AddEpAnn] r [TrailingAnn] t) EpAnnComments cs) = (Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (Anchor -> [AddEpAnn] -> Anchor widenAnchor Anchor anchor ((TrailingAnn -> AddEpAnn) -> [TrailingAnn] -> [AddEpAnn] forall a b. (a -> b) -> [a] -> [b] map TrailingAnn -> AddEpAnn trailingAnnToAddEpAnn [TrailingAnn] t)) (Maybe Anchor -> Maybe AddEpAnn -> Maybe AddEpAnn -> [AddEpAnn] -> [TrailingAnn] -> AnnList AnnList Maybe Anchor ma Maybe AddEpAnn o Maybe AddEpAnn c [AddEpAnn] r [TrailingAnn] t) EpAnnComments cs) -- | The 'Anchor' for a stmtlist is based on either the location or -- the first semicolon annotion. stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor stmtsAnchor :: forall a. Located (OrdList AddEpAnn, a) -> Anchor stmtsAnchor (L SrcSpan l ((ConsOL (AddEpAnn AnnKeywordId _ (EpaSpan RealSrcSpan r Maybe BufSpan _)) OrdList AddEpAnn _), a _)) = Anchor -> RealSrcSpan -> Anchor widenAnchorR (RealSrcSpan -> AnchorOperation -> Anchor Anchor (SrcSpan -> RealSrcSpan realSrcSpan SrcSpan l) AnchorOperation UnchangedAnchor) RealSrcSpan r stmtsAnchor (L SrcSpan l (OrdList AddEpAnn, a) _) = RealSrcSpan -> AnchorOperation -> Anchor Anchor (SrcSpan -> RealSrcSpan realSrcSpan SrcSpan l) AnchorOperation UnchangedAnchor 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 { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)) mbs, [GenLocated SrcSpanAnnA (Sig GhcPs)] sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] fam_ds, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] tfam_insts , [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] dfam_insts, [GenLocated SrcSpanAnnA (DocDecl GhcPs)] _) <- OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) cvBindsAndSigs OrdList (LHsDecl GhcPs) binding ; Bool -> P () forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m () massert ([GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] fam_ds Bool -> Bool -> Bool && [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)] tfam_insts Bool -> Bool -> Bool && [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] dfam_insts) ; HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs)) -> HsValBindsLR GhcPs GhcPs -> P (HsValBindsLR GhcPs GhcPs) forall a b. (a -> b) -> a -> b $ XValBinds GhcPs GhcPs -> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBindsLR GhcPs GhcPs forall idL idR. XValBinds idL idR -> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR ValBinds XValBinds GhcPs GhcPs AnnSortKey NoAnnSortKey LHsBinds GhcPs Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)) mbs [LSig GhcPs] [GenLocated SrcSpanAnnA (Sig GhcPs)] sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) -- 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 [GenLocated SrcSpanAnnA (HsDecl GhcPs)] fb' <- [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> P [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall {m :: * -> *} {a}. MonadP m => [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] drop_bad_decls (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)) -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)) fb) (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)), [GenLocated SrcSpanAnnA (Sig GhcPs)], [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)], [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)], [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)], [GenLocated SrcSpanAnnA (DocDecl GhcPs)]) -> P (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)), [GenLocated SrcSpanAnnA (Sig GhcPs)], [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)], [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)], [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)], [GenLocated SrcSpanAnnA (DocDecl GhcPs)]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return ([LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionBindsAndSigs ([LHsDecl GhcPs] -> [LHsDecl GhcPs] getMonoBindAll [LHsDecl GhcPs] [GenLocated SrcSpanAnnA (HsDecl GhcPs)] fb')) where -- 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 (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] drop_bad_decls [] = [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return [] drop_bad_decls (L SrcSpanAnn' a l (SpliceD XSpliceD GhcPs _ SpliceDecl GhcPs d) : [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] ds) = do MsgEnvelope PsMessage -> m () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnn' a -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnn' a l) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ SpliceDecl GhcPs -> PsMessage PsErrDeclSpliceNotAtTopLevel SpliceDecl GhcPs d [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] ds drop_bad_decls (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs) d:[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] ds) = (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs) dGenLocated (SrcSpanAnn' a) (HsDecl GhcPs) -> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] forall a. a -> [a] -> [a] :) ([GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]) -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] -> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)] ds ----------------------------------------------------------------------------- -- 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 -> SrcSpanAnnA forall ann. SrcAnn ann -> SrcAnn ann removeCommentsA SrcSpanAnnA loc1) Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) mtchs1] (SrcSpanAnnA -> SrcSpanAnnA forall ann. Monoid ann => SrcAnn ann -> SrcAnn ann commentsOnlyA SrcSpanAnnA loc1) [LHsDecl GhcPs] binds [] where go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpanAnnA loc ((L SrcSpanAnnA loc2 (ValD XValD GhcPs _ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL fun_id = (L SrcSpanAnnN _ RdrName f2) , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR) fun_matches = MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body] mg_alts = (L SrcSpanAnnL _ [L SrcSpanAnnA lm2 Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) mtchs2]) } }))) : [LHsDecl GhcPs] binds) [LHsDecl GhcPs] _ | RdrName f1 RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == RdrName f2 = let (SrcSpanAnnA loc2', SrcSpanAnnA lm2') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) transferAnnsA SrcSpanAnnA loc2 SrcSpanAnnA lm2 in [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go (SrcSpanAnnA -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA lm2' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) mtchs2 GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall a. a -> [a] -> [a] : [LMatch GhcPs (LHsExpr GhcPs)] [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] mtchs) (SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a combineSrcSpansA SrcSpanAnnA loc SrcSpanAnnA loc2') [LHsDecl GhcPs] binds [] go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpanAnnA loc (doc_decl :: LHsDecl GhcPs doc_decl@(L SrcSpanAnnA loc2 (DocD {})) : [LHsDecl GhcPs] binds) [LHsDecl GhcPs] doc_decls = let doc_decls' :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)] doc_decls' = LHsDecl GhcPs GenLocated SrcSpanAnnA (HsDecl GhcPs) doc_decl GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] [GenLocated SrcSpanAnnA (HsDecl GhcPs)] doc_decls in [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] mtchs (SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a combineSrcSpansA SrcSpanAnnA loc SrcSpanAnnA loc2) [LHsDecl GhcPs] binds [LHsDecl GhcPs] [GenLocated SrcSpanAnnA (HsDecl GhcPs)] doc_decls' go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpanAnnA loc [LHsDecl GhcPs] binds [LHsDecl GhcPs] doc_decls = ( SrcSpanAnnA -> HsBindLR GhcPs GhcPs -> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA loc (GenLocated SrcSpanAnnN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName fun_id1 ([GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall a e2 an. Semigroup a => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] mkLocatedList ([GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]) -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall a b. (a -> b) -> a -> b $ [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall a. [a] -> [a] reverse [LMatch GhcPs (LHsExpr GhcPs)] [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] mtchs)) , ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall a. [a] -> [a] reverse [LHsDecl GhcPs] [GenLocated SrcSpanAnnA (HsDecl GhcPs)] doc_decls) [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall a. [a] -> [a] -> [a] ++ [LHsDecl GhcPs] [GenLocated SrcSpanAnnA (HsDecl GhcPs)] binds) -- 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) -- 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 -> [LPat p] m_pats = [LPat GhcPs] args }) : [LMatch GhcPs (LHsExpr GhcPs)] _) = Bool -> Bool not ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LPat GhcPs] [GenLocated SrcSpanAnnA (Pat GhcPs)] args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). {- ********************************************************************** #PrefixToHS-utils# Utilities for conversion ********************************************************************* -} {- Note [Parsing data constructors is hard] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The problem with parsing data constructors is that they look a lot like types. Compare: (s1) data T = C t1 t2 (s2) type T = C t1 t2 Syntactically, there's little difference between these declarations, except in (s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. This similarity would pose no problem if we knew ahead of time if we are parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple (but wrong!) rule comes to mind: in 'data' declarations assume we are parsing data constructors, and in other contexts (e.g. 'type' declarations) assume we are parsing type constructors. This simple rule does not work because of two problematic cases: (p1) data T = C t1 t2 :+ t3 (p2) data T = C t1 t2 => t3 In (p1) we encounter (:+) and it turns out we are parsing an infix data declaration, so (C t1 t2) is a type and 'C' is a type constructor. In (p2) we encounter (=>) and it turns out we are parsing an existential context, so (C t1 t2) is a constraint and 'C' is a type constructor. As the result, in order to determine whether (C t1 t2) declares a data constructor, a type, or a context, we would need unlimited lookahead which 'happy' is not so happy with. -} -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) tyConToDataCon :: GenLocated SrcSpanAnnN RdrName -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName) tyConToDataCon (L SrcSpanAnnN loc RdrName tc) | String -> Bool okConOcc (OccName -> String occNameString OccName occ) = GenLocated SrcSpanAnnN RdrName -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName) forall a. a -> Either (MsgEnvelope PsMessage) a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN loc (RdrName -> NameSpace -> RdrName setRdrNameSpace RdrName tc NameSpace srcDataName)) | Bool otherwise = MsgEnvelope PsMessage -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName) forall a b. a -> Either a b Left (MsgEnvelope PsMessage -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName)) -> MsgEnvelope PsMessage -> Either (MsgEnvelope PsMessage) (GenLocated SrcSpanAnnN RdrName) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnnN -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnN loc) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (RdrName -> PsMessage PsErrNotADataCon RdrName tc) where occ :: OccName occ = RdrName -> OccName rdrNameOcc RdrName tc mkPatSynMatchGroup :: LocatedN RdrName -> LocatedL (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup :: GenLocated SrcSpanAnnN RdrName -> LocatedL (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (L SrcSpanAnnN loc RdrName patsyn_name) (L SrcSpanAnnL ld OrdList (LHsDecl GhcPs) decls) = do { [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] matches <- (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))) -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> P [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) fromDecl (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)) -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)) decls) ; Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when ([GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] matches) (SrcSpan -> P () wrongNumberErr (SrcSpanAnnN -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnN loc)) ; MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) -> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall a b. (a -> b) -> a -> b $ Origin -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) forall (p :: Pass) (body :: * -> *). AnnoBody p body => Origin -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup Origin FromSource (SrcSpanAnnL -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall l e. l -> e -> GenLocated l e L SrcSpanAnnL ld [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] matches) } where fromDecl :: GenLocated SrcSpanAnnA (HsDecl GhcPs) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) fromDecl (L SrcSpanAnnA loc decl :: HsDecl GhcPs decl@(ValD XValD GhcPs _ (PatBind XPatBind GhcPs GhcPs _ -- 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)) 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. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) HsDecl GhcPs decl ; Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) 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 GhcPs m_ctxt = HsMatchContext GhcPs ctxt, m_pats :: [LPat GhcPs] m_pats = [LPat GhcPs] pats , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) rhs } where ctxt :: HsMatchContext GhcPs ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs) mc_fun = LIdP (NoGhcTc GhcPs) XRec GhcPs (ConLikeP GhcPs) ln , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity Prefix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness NoSrcStrict } InfixCon LPat GhcPs p1 LPat GhcPs p2 -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall a b. (a -> b) -> a -> b $ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_ext = XConPat GhcPs XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) noAnn , m_ctxt :: HsMatchContext GhcPs m_ctxt = HsMatchContext GhcPs ctxt , m_pats :: [LPat GhcPs] m_pats = [LPat GhcPs p1, LPat GhcPs p2] , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) rhs } where ctxt :: HsMatchContext GhcPs ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs) mc_fun = LIdP (NoGhcTc GhcPs) XRec GhcPs (ConLikeP GhcPs) ln , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity Infix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness NoSrcStrict } RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall a. SrcSpan -> LPat GhcPs -> P a recordPatSynErr (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) LPat GhcPs pat ; GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))) -> GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA loc Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) match } fromDecl (L SrcSpanAnnA loc HsDecl GhcPs decl) = SrcSpan -> HsDecl GhcPs -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) extraDeclErr (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) HsDecl GhcPs decl extraDeclErr :: SrcSpan -> HsDecl GhcPs -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) extraDeclErr SrcSpan loc HsDecl GhcPs decl = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (RdrName -> HsDecl GhcPs -> PsMessage PsErrNoSingleWhereBindInPatSynDecl RdrName patsyn_name HsDecl GhcPs decl) wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P () wrongNameBindingErr SrcSpan loc HsDecl GhcPs decl = MsgEnvelope PsMessage -> P () forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (RdrName -> HsDecl GhcPs -> PsMessage PsErrInvalidWhereBindInPatSynDecl RdrName patsyn_name HsDecl GhcPs decl) wrongNumberErr :: SrcSpan -> P () wrongNumberErr SrcSpan loc = MsgEnvelope PsMessage -> P () forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (RdrName -> PsMessage PsErrEmptyWhereInPatSynDecl RdrName patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a recordPatSynErr SrcSpan loc LPat GhcPs pat = MsgEnvelope PsMessage -> P a forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P a) -> MsgEnvelope PsMessage -> P a forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (LPat GhcPs -> PsMessage PsErrRecordSyntaxInPatSynDecl LPat GhcPs pat) mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs mkConDeclH98 :: EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs mkConDeclH98 EpAnn [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName name Maybe [LHsTyVarBndr Specificity GhcPs] mb_forall Maybe (LHsContext GhcPs) mb_cxt HsConDeclH98Details GhcPs args = ConDeclH98 { con_ext :: XConDeclH98 GhcPs con_ext = XConDeclH98 GhcPs EpAnn [AddEpAnn] ann , con_name :: XRec GhcPs (IdP GhcPs) con_name = XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName name , con_forall :: Bool con_forall = Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> Bool forall a. Maybe a -> Bool isJust Maybe [LHsTyVarBndr Specificity GhcPs] Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] mb_forall , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs] con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs] Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] mb_forall Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] forall a. Maybe a -> a -> a `orElse` [] , con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt = Maybe (LHsContext GhcPs) mb_cxt , con_args :: HsConDeclH98Details GhcPs con_args = HsConDeclH98Details GhcPs args , con_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) -> LHsUniToken "::" "∷" GhcPs -> LHsSigType GhcPs -> P (LConDecl GhcPs) mkGadtDecl :: SrcSpan -> NonEmpty (GenLocated SrcSpanAnnN RdrName) -> LHsUniToken "::" "\8759" GhcPs -> LHsSigType GhcPs -> P (LConDecl GhcPs) mkGadtDecl SrcSpan loc NonEmpty (GenLocated SrcSpanAnnN RdrName) names LHsUniToken "::" "\8759" GhcPs dcol LHsSigType GhcPs ty = do EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc let l :: SrcSpanAnnA l = SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc (HsConDeclGADTDetails GhcPs args, GenLocated SrcSpanAnnA (HsType GhcPs) res_ty, [AddEpAnn] annsa, EpAnnComments csa) <- case LHsType GhcPs body_ty of L SrcSpanAnnA ll (HsFunTy XFunTy GhcPs af HsArrow GhcPs hsArr (L SrcSpanAnnA loc' (HsRecTy XRecTy GhcPs an [LConDeclField GhcPs] rf)) LHsType GhcPs res_ty) -> do let an' :: EpAnn AnnList an' = SrcSpan -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList forall a. Monoid a => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a addCommentsToEpAnn (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc') XRecTy GhcPs EpAnn AnnList an (EpAnn NoEpAnns -> EpAnnComments forall ann. EpAnn ann -> EpAnnComments comments XFunTy GhcPs EpAnn NoEpAnns af) GenLocated TokenLocation (HsUniToken "->" "\8594") arr <- case HsArrow GhcPs hsArr of HsUnrestrictedArrow LHsUniToken "->" "\8594" GhcPs arr -> GenLocated TokenLocation (HsUniToken "->" "\8594") -> P (GenLocated TokenLocation (HsUniToken "->" "\8594")) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return LHsUniToken "->" "\8594" GhcPs GenLocated TokenLocation (HsUniToken "->" "\8594") arr HsArrow GhcPs _ -> do MsgEnvelope PsMessage -> P () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpan forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) body_ty) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (HsArrow GhcPs -> PsMessage PsErrIllegalGadtRecordMultiplicity HsArrow GhcPs hsArr) GenLocated TokenLocation (HsUniToken "->" "\8594") -> P (GenLocated TokenLocation (HsUniToken "->" "\8594")) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return GenLocated TokenLocation (HsUniToken "->" "\8594") forall (tok :: Symbol) (utok :: Symbol). GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok (HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments) -> P (HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return ( XRec GhcPs [LConDeclField GhcPs] -> LHsUniToken "->" "\8594" GhcPs -> HsConDeclGADTDetails GhcPs forall pass. XRec pass [LConDeclField pass] -> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass RecConGADT (SrcSpanAnnL -> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] forall l e. l -> e -> GenLocated l e L (EpAnn AnnList -> SrcSpan -> SrcSpanAnnL forall a. a -> SrcSpan -> SrcSpanAnn' a SrcSpanAnn EpAnn AnnList an' (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc')) [LConDeclField GhcPs] [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] rf) LHsUniToken "->" "\8594" GhcPs GenLocated TokenLocation (HsUniToken "->" "\8594") arr, LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) res_ty , [], EpAnn AnnListItem -> EpAnnComments forall ann. EpAnn ann -> EpAnnComments epAnnComments (SrcSpanAnnA -> EpAnn AnnListItem forall a. SrcSpanAnn' a -> a ann SrcSpanAnnA ll)) LHsType GhcPs _ -> do let ([AddEpAnn] anns, EpAnnComments cs, [HsScaled GhcPs (LHsType GhcPs)] arg_types, LHsType GhcPs res_type) = LHsType GhcPs -> ([AddEpAnn], EpAnnComments, [HsScaled GhcPs (LHsType GhcPs)], LHsType GhcPs) forall (p :: Pass). LHsType (GhcPass p) -> ([AddEpAnn], EpAnnComments, [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p)) splitHsFunType LHsType GhcPs body_ty (HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments) -> P (HsConDeclGADTDetails GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs), [AddEpAnn], EpAnnComments) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs forall pass. [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)] arg_types, LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) res_type, [AddEpAnn] anns, EpAnnComments cs) let an :: EpAnn [AddEpAnn] an = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] annsa (EpAnnComments cs EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments csa) GenLocated SrcSpanAnnA (ConDecl GhcPs) -> P (GenLocated SrcSpanAnnA (ConDecl GhcPs)) forall a. a -> P a forall (f :: * -> *) a. Applicative f => a -> f a pure (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> P (GenLocated SrcSpanAnnA (ConDecl GhcPs))) -> GenLocated SrcSpanAnnA (ConDecl GhcPs) -> P (GenLocated SrcSpanAnnA (ConDecl GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA l ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs con_g_ext = XConDeclGADT GhcPs EpAnn [AddEpAnn] an , con_names :: NonEmpty (XRec GhcPs (IdP GhcPs)) con_names = NonEmpty (XRec GhcPs (IdP GhcPs)) NonEmpty (GenLocated SrcSpanAnnN RdrName) names , con_dcolon :: LHsUniToken "::" "\8759" GhcPs con_dcolon = LHsUniToken "::" "\8759" GhcPs dcol , con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs) con_bndrs = SrcSpanAnnA -> HsOuterSigTyVarBndrs GhcPs -> GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs GhcPs) forall l e. l -> e -> GenLocated l e L (GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpanAnnA forall l e. GenLocated l e -> l getLoc LHsSigType GhcPs GenLocated SrcSpanAnnA (HsSigType GhcPs) ty) HsOuterSigTyVarBndrs GhcPs outer_bndrs , con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt = Maybe (LHsContext GhcPs) mcxt , con_g_args :: HsConDeclGADTDetails GhcPs con_g_args = HsConDeclGADTDetails GhcPs args , con_res_ty :: LHsType GhcPs con_res_ty = LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) res_ty , con_doc :: Maybe (LHsDoc GhcPs) con_doc = Maybe (LHsDoc GhcPs) forall a. Maybe a Nothing } where (HsOuterSigTyVarBndrs GhcPs outer_bndrs, Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs body_ty) = LHsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs) splitLHsGadtTy LHsSigType GhcPs ty setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. -- 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. 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 ((() :: Constraint) => Name -> Module Name -> Module nameModule Name n) OccName occ | Bool otherwise -- This can happen when quoting and then -- splicing a fixity declaration for a type = Name -> RdrName Exact (Unique -> OccName -> SrcSpan -> Name mkSystemNameAt (Name -> Unique nameUnique Name n) OccName occ (Name -> SrcSpan nameSrcSpan Name n)) where occ :: OccName occ = NameSpace -> OccName -> OccName setOccNameSpace NameSpace ns (Name -> OccName nameOccName Name n) setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace (ATyCon TyCon tc) NameSpace ns | NameSpace -> Bool isDataConNameSpace NameSpace ns = TyCon -> RdrName ty_con_data_con TyCon tc | NameSpace -> Bool isTcClsNameSpace NameSpace ns = Name -> RdrName Exact (TyCon -> Name forall a. NamedThing a => a -> Name getName TyCon tc) -- No-op setWiredInNameSpace (AConLike (RealDataCon DataCon dc)) NameSpace ns | NameSpace -> Bool isTcClsNameSpace NameSpace ns = DataCon -> RdrName data_con_ty_con DataCon dc | NameSpace -> Bool isDataConNameSpace NameSpace ns = Name -> RdrName Exact (DataCon -> Name forall a. NamedThing a => a -> Name getName DataCon dc) -- No-op setWiredInNameSpace TyThing thing NameSpace ns = String -> SDoc -> RdrName forall a. HasCallStack => String -> SDoc -> a pprPanic String "setWiredinNameSpace" (NameSpace -> SDoc pprNameSpace NameSpace ns SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> TyThing -> SDoc forall a. Outputable a => a -> SDoc ppr TyThing thing) ty_con_data_con :: TyCon -> RdrName ty_con_data_con :: TyCon -> RdrName ty_con_data_con TyCon tc | TyCon -> Bool isTupleTyCon TyCon tc , Just DataCon dc <- TyCon -> Maybe DataCon tyConSingleDataCon_maybe TyCon tc = Name -> RdrName Exact (DataCon -> Name forall a. NamedThing a => a -> Name getName DataCon dc) | TyCon tc TyCon -> Unique -> Bool forall a. Uniquable a => a -> Unique -> Bool `hasKey` Unique listTyConKey = Name -> RdrName Exact Name nilDataConName | Bool otherwise -- See Note [setRdrNameSpace for wired-in names] = OccName -> RdrName Unqual (NameSpace -> OccName -> OccName setOccNameSpace NameSpace srcDataName (TyCon -> OccName forall a. NamedThing a => a -> OccName getOccName TyCon tc)) data_con_ty_con :: DataCon -> RdrName data_con_ty_con :: DataCon -> RdrName data_con_ty_con DataCon dc | let tc :: TyCon tc = DataCon -> TyCon dataConTyCon DataCon dc , TyCon -> Bool isTupleTyCon TyCon tc = Name -> RdrName Exact (TyCon -> Name forall a. NamedThing a => a -> Name getName TyCon tc) | DataCon dc DataCon -> Unique -> Bool forall a. Uniquable a => a -> Unique -> Bool `hasKey` Unique nilDataConKey = Name -> RdrName Exact Name listTyConName | Bool otherwise -- See Note [setRdrNameSpace for wired-in names] = OccName -> RdrName Unqual (NameSpace -> OccName -> OccName setOccNameSpace NameSpace tcClsName (DataCon -> OccName forall a. NamedThing a => a -> OccName getOccName DataCon dc)) {- Note [setRdrNameSpace for wired-in names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC.Types, which declares (:), we have infixr 5 : The ambiguity about which ":" is meant is resolved by parsing it as a data constructor, but then using dataTcOccs to try the type constructor too; and that in turn calls setRdrNameSpace to change the name-space of ":" to tcClsName. There isn't a corresponding ":" type constructor, but it's painful to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a -- Adapts the Either monad to the P monad eitherToP :: forall (m :: * -> *) a. MonadP m => Either (MsgEnvelope PsMessage) a -> m a eitherToP (Left MsgEnvelope PsMessage err) = MsgEnvelope PsMessage -> m a forall a. MsgEnvelope PsMessage -> m a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError MsgEnvelope PsMessage err eitherToP (Right a thing) = a -> m a forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a thing checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) -- the synthesized type variables -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars :: SDoc -> SDoc -> GenLocated SrcSpanAnnN RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) checkTyVars SDoc pp_what SDoc equals_or_where GenLocated SrcSpanAnnN RdrName tc [LHsTypeArg GhcPs] tparms = do { [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] tvs <- (HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> P [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) check [LHsTypeArg GhcPs] [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] tparms ; LHsQTyVars GhcPs -> P (LHsQTyVars GhcPs) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs mkHsQTvs [LHsTyVarBndr () GhcPs] [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)] tvs) } where check :: HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) check (HsTypeArg SrcSpan _ ki :: GenLocated SrcSpanAnnA (HsType GhcPs) ki@(L SrcSpanAnnA loc HsType GhcPs _)) = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (LHsType GhcPs -> SDoc -> RdrName -> PsMessage PsErrUnexpectedTypeAppInDecl LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) ki SDoc pp_what (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName tc)) check (HsValArg GenLocated SrcSpanAnnA (HsType GhcPs) ty) = [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chkParens [] [] EpAnnComments emptyComments LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) ty check (HsArgPar SrcSpan sp) = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan sp (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (SDoc -> RdrName -> PsMessage PsErrMalformedDecl SDoc pp_what (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName tc)) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chkParens [AddEpAnn] ops [AddEpAnn] cps EpAnnComments cs (L SrcSpanAnnA l (HsParTy XParTy GhcPs an LHsType GhcPs ty)) = let (AddEpAnn o,AddEpAnn c) = RealSrcSpan -> (AddEpAnn, AddEpAnn) mkParensEpAnn (SrcSpan -> RealSrcSpan realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) in [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chkParens (AddEpAnn oAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] ops) (AddEpAnn cAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] cps) (EpAnnComments cs EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnn AnnParen -> EpAnnComments forall ann. EpAnn ann -> EpAnnComments epAnnComments XParTy GhcPs EpAnn AnnParen an) LHsType GhcPs ty chkParens [AddEpAnn] ops [AddEpAnn] cps EpAnnComments cs LHsType GhcPs ty = [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk [AddEpAnn] ops [AddEpAnn] cps EpAnnComments cs LHsType GhcPs ty -- Check that the name space is correct! chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk [AddEpAnn] ops [AddEpAnn] cps EpAnnComments cs (L SrcSpanAnnA l (HsKindSig XKindSig GhcPs annk (L SrcSpanAnnA annt (HsTyVar XTyVar GhcPs ann PromotionFlag _ (L SrcSpanAnnN lv RdrName tv))) LHsType GhcPs k)) | RdrName -> Bool isRdrTyVar RdrName tv = let an :: [AddEpAnn] an = ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps in GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> HsTyVarBndr () GhcPs -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> [AddEpAnn] -> SrcSpanAnnA forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an widenLocatedAn (SrcSpanAnnA l SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA forall a. Semigroup a => a -> a -> a Semi.<> SrcSpanAnnA annt) [AddEpAnn] an) (XKindedTyVar GhcPs -> () -> XRec GhcPs (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs forall flag pass. XKindedTyVar pass -> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass KindedTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (XKindSig GhcPs EpAnn [AddEpAnn] annk EpAnn [AddEpAnn] -> EpAnn [AddEpAnn] -> EpAnn [AddEpAnn] forall a. Semigroup a => a -> a -> a Semi.<> XTyVar GhcPs EpAnn [AddEpAnn] ann) [AddEpAnn] an EpAnnComments cs) () (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN lv RdrName tv) LHsType GhcPs k)) chk [AddEpAnn] ops [AddEpAnn] cps EpAnnComments cs (L SrcSpanAnnA l (HsTyVar XTyVar GhcPs ann PromotionFlag _ (L SrcSpanAnnN ltv RdrName tv))) | RdrName -> Bool isRdrTyVar RdrName tv = let an :: [AddEpAnn] an = ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps in GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> HsTyVarBndr () GhcPs -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> [AddEpAnn] -> SrcSpanAnnA forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an widenLocatedAn SrcSpanAnnA l [AddEpAnn] an) (XUserTyVar GhcPs -> () -> XRec GhcPs (IdP GhcPs) -> HsTyVarBndr () GhcPs forall flag pass. XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass UserTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns XTyVar GhcPs EpAnn [AddEpAnn] ann [AddEpAnn] an EpAnnComments cs) () (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN ltv RdrName tv))) chk [AddEpAnn] _ [AddEpAnn] _ EpAnnComments _ t :: LHsType GhcPs t@(L SrcSpanAnnA loc HsType GhcPs _) = MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs)) -> MsgEnvelope PsMessage -> P (LHsTyVarBndr () GhcPs) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (LHsType GhcPs -> SDoc -> RdrName -> [LHsTypeArg GhcPs] -> SDoc -> PsMessage PsErrUnexpectedTypeInDecl LHsType GhcPs t SDoc pp_what (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName tc) [LHsTypeArg GhcPs] tparms SDoc equals_or_where) 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 Bool allowed <- ExtBits -> P Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits DatatypeContextsBit Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool allowed (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ MsgEnvelope PsMessage -> P () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] -> SrcSpan forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA LHsContext GhcPs GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] c) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (LHsContext GhcPs -> PsMessage PsErrIllegalDataTypeContext LHsContext GhcPs c) type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ 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 (SrcAnn NoEpAnns) (RuleBndr GhcPs)) -> [LRuleTyTmVar] -> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)] forall a b. (a -> b) -> [a] -> [b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs) forall a b. (a -> b) -> GenLocated (SrcAnn NoEpAnns) a -> GenLocated (SrcAnn NoEpAnns) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RuleTyTmVar -> RuleBndr GhcPs cvt_one) where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs cvt_one (RuleTyTmVar EpAnn [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName v Maybe (LHsType GhcPs) Nothing) = XCRuleBndr GhcPs -> XRec GhcPs (IdP GhcPs) -> RuleBndr GhcPs forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass RuleBndr XCRuleBndr GhcPs EpAnn [AddEpAnn] ann XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName v cvt_one (RuleTyTmVar EpAnn [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName v (Just LHsType GhcPs sig)) = XRuleBndrSig GhcPs -> XRec GhcPs (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs forall pass. XRuleBndrSig pass -> LIdP pass -> HsPatSigType pass -> RuleBndr pass RuleBndrSig XRuleBndrSig GhcPs EpAnn [AddEpAnn] ann XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName v (EpAnn NoEpAnns -> LHsType GhcPs -> HsPatSigType GhcPs mkHsPatSigType EpAnn NoEpAnns forall a. EpAnn 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} {ann}. GenLocated (SrcSpanAnn' a) RuleTyTmVar -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs) cvt_one where cvt_one :: GenLocated (SrcSpanAnn' a) RuleTyTmVar -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs) cvt_one (L SrcSpanAnn' a l (RuleTyTmVar EpAnn [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName v Maybe (LHsType GhcPs) Nothing)) = SrcAnn ann -> HsTyVarBndr () GhcPs -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnn' a -> SrcAnn ann forall a ann. SrcSpanAnn' a -> SrcAnn ann l2l SrcSpanAnn' a l) (XUserTyVar GhcPs -> () -> XRec GhcPs (IdP GhcPs) -> HsTyVarBndr () GhcPs forall flag pass. XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass UserTyVar XUserTyVar GhcPs EpAnn [AddEpAnn] ann () ((RdrName -> RdrName) -> GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName forall a b. (a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RdrName -> RdrName tm_to_ty GenLocated SrcSpanAnnN RdrName v)) cvt_one (L SrcSpanAnn' a l (RuleTyTmVar EpAnn [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName v (Just LHsType GhcPs sig))) = SrcAnn ann -> HsTyVarBndr () GhcPs -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnn' a -> SrcAnn ann forall a ann. SrcSpanAnn' a -> SrcAnn ann l2l SrcSpanAnn' a l) (XKindedTyVar GhcPs -> () -> XRec GhcPs (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs forall flag pass. XKindedTyVar pass -> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass KindedTyVar XKindedTyVar GhcPs EpAnn [AddEpAnn] ann () ((RdrName -> RdrName) -> GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName forall a b. (a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RdrName -> RdrName tm_to_ty GenLocated SrcSpanAnnN 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 => GenLocated (SrcSpanAnn' a) RdrName -> f () check (GenLocated SrcSpanAnnA RdrName -> P ()) -> (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> GenLocated SrcSpanAnnA RdrName) -> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> P () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsTyVarBndr flag GhcPs -> RdrName) -> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> GenLocated SrcSpanAnnA RdrName forall a b. (a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HsTyVarBndr flag GhcPs -> IdP GhcPs HsTyVarBndr flag GhcPs -> RdrName forall flag (p :: Pass). HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) hsTyVarName) where check :: GenLocated (SrcSpanAnn' a) RdrName -> f () check (L SrcSpanAnn' a loc (Unqual OccName occ)) = Bool -> f () -> f () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (OccName -> 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 "forall",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 (SrcSpanAnn' a -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnn' a loc) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (OccName -> PsMessage PsErrParseErrorOnInput OccName occ)) check GenLocated (SrcSpanAnn' a) RdrName _ = String -> f () forall a. 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 Bool allowed <- ExtBits -> m Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits TraditionalRecordSyntaxBit Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool allowed (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ MsgEnvelope PsMessage -> m () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (SDoc -> PsMessage PsErrIllegalTraditionalRecordSyntax (a -> SDoc forall a. Outputable a => a -> SDoc ppr a r)) LocatedA a -> m (LocatedA a) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return LocatedA a lr -- | 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 Bool gadtSyntax <- ExtBits -> P Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits GadtSyntaxBit -- GADTs implies GADTSyntax Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool gadtSyntax (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ MsgEnvelope PsMessage -> P () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> P ()) -> MsgEnvelope PsMessage -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan span (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ PsMessage PsErrIllegalWhereInDataDecl Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]) -> P (Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return Located ([AddEpAnn], [LConDecl GhcPs]) Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]) gadts checkEmptyGADTs Located ([AddEpAnn], [LConDecl GhcPs]) gadts = Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]) -> P (Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)])) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return Located ([AddEpAnn], [LConDecl GhcPs]) Located ([AddEpAnn], [GenLocated SrcSpanAnnA (ConDecl GhcPs)]) gadts -- 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 -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces checkTyClHdr :: Bool -> LHsType GhcPs -> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddEpAnn]) checkTyClHdr Bool is_cls LHsType GhcPs ty = GenLocated SrcSpanAnnA (HsType GhcPs) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) goL LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) ty [] [] [] LexicalFixity Prefix where goL :: GenLocated SrcSpanAnnA (HsType GhcPs) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) goL (L SrcSpanAnnA l HsType GhcPs ty) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix = SrcSpan -> HsType GhcPs -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) go (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) HsType GhcPs ty [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix -- workaround to define '*' despite StarIsType go :: SrcSpan -> HsType GhcPs -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) go SrcSpan _ (HsParTy XParTy GhcPs an (L SrcSpanAnnA l (HsStarTy XStarTy GhcPs _ Bool isUni))) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops' [AddEpAnn] cps' LexicalFixity fix = do { SrcSpan -> PsMessage -> P () addPsMessage (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) PsMessage PsWarnStarBinder ; let name :: OccName name = NameSpace -> FastString -> OccName mkOccNameFS NameSpace tcClsName (Bool -> FastString starSym Bool isUni) ; let a' :: SrcSpanAnnN a' = SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN newAnns SrcSpanAnnA l XParTy GhcPs EpAnn AnnParen an ; (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN a' (OccName -> RdrName Unqual OccName name), [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc, LexicalFixity fix , ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops') [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps') } go SrcSpan _ (HsTyVar XTyVar GhcPs _ PromotionFlag _ ltc :: XRec GhcPs (IdP GhcPs) ltc@(L SrcSpanAnnN _ RdrName tc)) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix | RdrName -> Bool isRdrTc RdrName tc = (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName ltc, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc, LexicalFixity fix, ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps) go SrcSpan _ (HsOpTy XOpTy GhcPs _ PromotionFlag _ LHsType GhcPs t1 ltc :: XRec GhcPs (IdP GhcPs) ltc@(L SrcSpanAnnN _ RdrName tc) LHsType GhcPs t2) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity _fix | RdrName -> Bool isRdrTc RdrName tc = (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName ltc, GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) t1HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] forall a. a -> [a] -> [a] :GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) t2HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] forall a. a -> [a] -> [a] :[HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc, LexicalFixity Infix, ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps) go SrcSpan l (HsParTy XParTy GhcPs _ LHsType GhcPs ty) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix = GenLocated SrcSpanAnnA (HsType GhcPs) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) goL LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) ty [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc (AddEpAnn oAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] ops) (AddEpAnn cAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] cps) LexicalFixity fix where (AddEpAnn o,AddEpAnn c) = RealSrcSpan -> (AddEpAnn, AddEpAnn) mkParensEpAnn (SrcSpan -> RealSrcSpan realSrcSpan SrcSpan l) go SrcSpan _ (HsAppTy XAppTy GhcPs _ LHsType GhcPs t1 LHsType GhcPs t2) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix = GenLocated SrcSpanAnnA (HsType GhcPs) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) goL LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) t1 (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) t2HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] forall a. a -> [a] -> [a] :[HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc) [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix go SrcSpan _ (HsAppKindTy XAppKindTy GhcPs l LHsType GhcPs ty LHsType GhcPs ki) [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix = GenLocated SrcSpanAnnA (HsType GhcPs) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [AddEpAnn] -> [AddEpAnn] -> LexicalFixity -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) goL LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) ty (SrcSpan -> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) forall tm ty. SrcSpan -> ty -> HsArg tm ty HsTypeArg XAppKindTy GhcPs SrcSpan l LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) kiHsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] forall a. a -> [a] -> [a] :[HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] acc) [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix go SrcSpan l (HsTupleTy XTupleTy GhcPs _ HsTupleSort HsBoxedOrConstraintTuple [LHsType GhcPs] ts) [] [AddEpAnn] ops [AddEpAnn] cps LexicalFixity fix = (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnN forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan l) (Name -> RdrName nameRdrName Name tup_name) , (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))) -> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] forall a b. (a -> b) -> [a] -> [b] map GenLocated SrcSpanAnnA (HsType GhcPs) -> HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs)) forall tm ty. tm -> HsArg tm ty HsValArg [LHsType GhcPs] [GenLocated SrcSpanAnnA (HsType GhcPs)] ts, LexicalFixity fix, ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops)[AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++[AddEpAnn] cps) where arity :: Int arity = [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [LHsType GhcPs] [GenLocated SrcSpanAnnA (HsType GhcPs)] ts tup_name :: Name tup_name | Bool is_cls = Int -> Name cTupleTyConName Int arity | Bool otherwise = TyCon -> Name forall a. NamedThing a => a -> Name getName (Boxity -> Int -> TyCon tupleTyCon Boxity Boxed Int arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) go SrcSpan l HsType GhcPs _ [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))] _ [AddEpAnn] _ [AddEpAnn] _ LexicalFixity _ = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn])) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName, [HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))], LexicalFixity, [AddEpAnn]) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan l (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (LHsType GhcPs -> PsMessage PsErrMalformedTyOrClDecl LHsType GhcPs ty) -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN newAnns (SrcSpanAnn EpAnn AnnListItem EpAnnNotUsed SrcSpan l) (EpAnn Anchor as (AnnParen ParenType _ EpaLocation o EpaLocation c) EpAnnComments cs) = let lr :: RealSrcSpan lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans (SrcSpan -> RealSrcSpan realSrcSpan SrcSpan l) (Anchor -> RealSrcSpan anchor Anchor as) an :: EpAnn NameAnn an = (Anchor -> NameAnn -> EpAnnComments -> EpAnn NameAnn forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (RealSrcSpan -> AnchorOperation -> Anchor Anchor RealSrcSpan lr AnchorOperation UnchangedAnchor) (NameAdornment -> EpaLocation -> EpaLocation -> EpaLocation -> [TrailingAnn] -> NameAnn NameAnn NameAdornment NameParens EpaLocation o (SrcSpan -> EpaLocation srcSpan2e SrcSpan l) EpaLocation c []) EpAnnComments cs) in EpAnn NameAnn -> SrcSpan -> SrcSpanAnnN forall a. a -> SrcSpan -> SrcSpanAnn' a SrcSpanAnn EpAnn NameAnn an (RealSrcSpan -> Maybe BufSpan -> SrcSpan RealSrcSpan RealSrcSpan lr Maybe BufSpan forall a. Maybe a Strict.Nothing) newAnns SrcSpanAnnA _ EpAnn AnnParen EpAnnNotUsed = String -> SrcSpanAnnN forall a. HasCallStack => String -> a panic String "missing AnnParen" newAnns (SrcSpanAnn (EpAnn Anchor ap (AnnListItem [TrailingAnn] ta) EpAnnComments csp) SrcSpan l) (EpAnn Anchor as (AnnParen ParenType _ EpaLocation o EpaLocation c) EpAnnComments cs) = let lr :: RealSrcSpan lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans (Anchor -> RealSrcSpan anchor Anchor ap) (Anchor -> RealSrcSpan anchor Anchor as) an :: EpAnn NameAnn an = (Anchor -> NameAnn -> EpAnnComments -> EpAnn NameAnn forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (RealSrcSpan -> AnchorOperation -> Anchor Anchor RealSrcSpan lr AnchorOperation UnchangedAnchor) (NameAdornment -> EpaLocation -> EpaLocation -> EpaLocation -> [TrailingAnn] -> NameAnn NameAnn NameAdornment NameParens EpaLocation o (SrcSpan -> EpaLocation srcSpan2e SrcSpan l) EpaLocation c [TrailingAnn] ta) (EpAnnComments csp EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs)) in EpAnn NameAnn -> SrcSpan -> SrcSpanAnnN forall a. a -> SrcSpan -> SrcSpanAnn' a SrcSpanAnn EpAnn NameAnn an (RealSrcSpan -> Maybe BufSpan -> SrcSpan RealSrcSpan RealSrcSpan lr Maybe BufSpan forall a. Maybe a Strict.Nothing) -- | 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 => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check (Maybe ModuleName -> LHsExpr GhcPs -> PsMessage PsErrDoInFunAppExpr Maybe ModuleName m) LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsDo XDo GhcPs _ (MDoExpr Maybe ModuleName m) XRec GhcPs [ExprLStmt GhcPs] _ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check (Maybe ModuleName -> LHsExpr GhcPs -> PsMessage PsErrMDoInFunAppExpr Maybe ModuleName m) LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsLam {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsExpr GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage PsErrLambdaInFunAppExpr LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsCase {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsExpr GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage PsErrCaseInFunAppExpr LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsLamCase XLamCase GhcPs _ LamCaseVariant lc_variant MatchGroup GhcPs (LHsExpr GhcPs) _ -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check (LamCaseVariant -> LHsExpr GhcPs -> PsMessage PsErrLambdaCaseInFunAppExpr LamCaseVariant lc_variant) LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsLet {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsExpr GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage PsErrLetInFunAppExpr LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsIf {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsExpr GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage PsErrIfInFunAppExpr LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsProc {} -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsExpr GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PsMessage PsErrProcInFunAppExpr LHsExpr GhcPs GenLocated SrcSpanAnnA (HsExpr GhcPs) expr HsExpr GhcPs _ -> () -> PV () forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd :: LHsCmd GhcPs -> PV () checkCmd LHsCmd GhcPs cmd = case GenLocated SrcSpanAnnA (HsCmd GhcPs) -> HsCmd GhcPs forall l e. GenLocated l e -> e unLoc LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd of HsCmdLam {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsCmd GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage PsErrLambdaCmdInFunAppCmd LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmdCase {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsCmd GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage PsErrCaseCmdInFunAppCmd LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmdLamCase XCmdLamCase GhcPs _ LamCaseVariant lc_variant MatchGroup GhcPs (LHsCmd GhcPs) _ -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check (LamCaseVariant -> LHsCmd GhcPs -> PsMessage PsErrLambdaCaseCmdInFunAppCmd LamCaseVariant lc_variant) LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmdIf {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsCmd GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage PsErrIfCmdInFunAppCmd LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmdLet {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsCmd GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage PsErrLetCmdInFunAppCmd LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmdDo {} -> (GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage) -> GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV () forall {m :: * -> *} {a} {e}. MonadP m => (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check LHsCmd GhcPs -> PsMessage GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PsMessage PsErrDoCmdInFunAppCmd LHsCmd GhcPs GenLocated SrcSpanAnnA (HsCmd GhcPs) cmd HsCmd GhcPs _ -> () -> PV () forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return () check :: (GenLocated (SrcSpanAnn' a) e -> PsMessage) -> GenLocated (SrcSpanAnn' a) e -> m () check GenLocated (SrcSpanAnn' a) e -> PsMessage err GenLocated (SrcSpanAnn' a) e a = do Bool blockArguments <- ExtBits -> m Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits BlockArgumentsBit Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool blockArguments (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ MsgEnvelope PsMessage -> m () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> m ()) -> MsgEnvelope PsMessage -> m () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (GenLocated (SrcSpanAnn' a) e -> SrcSpan forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA GenLocated (SrcSpanAnn' a) e a) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ (GenLocated (SrcSpanAnn' a) e -> PsMessage err GenLocated (SrcSpanAnn' a) e a) -- | 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 (SrcSpanAnn EpAnn AnnListItem _ SrcSpan l) HsType GhcPs _orig_t) = ([EpaLocation], [EpaLocation], EpAnnComments) -> LHsType GhcPs -> P (LHsContext GhcPs) check ([],[],EpAnnComments emptyComments) LHsType GhcPs orig_t where check :: ([EpaLocation],[EpaLocation],EpAnnComments) -> LHsType GhcPs -> P (LHsContext GhcPs) check :: ([EpaLocation], [EpaLocation], EpAnnComments) -> LHsType GhcPs -> P (LHsContext GhcPs) check ([EpaLocation] oparens,[EpaLocation] cparens,EpAnnComments cs) (L SrcSpanAnnA _l (HsTupleTy XTupleTy GhcPs ann' HsTupleSort HsBoxedOrConstraintTuple [LHsType GhcPs] ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. -- Ditto () = do let ([EpaLocation] op,[EpaLocation] cp,EpAnnComments cs') = case XTupleTy GhcPs ann' of XTupleTy GhcPs EpAnn AnnParen EpAnnNotUsed -> ([],[],EpAnnComments emptyComments) EpAnn Anchor _ (AnnParen ParenType _ EpaLocation o EpaLocation c) EpAnnComments cs -> ([EpaLocation o],[EpaLocation c],EpAnnComments cs) GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] -> P (GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnn' (EpAnn AnnContext) -> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] forall l e. l -> e -> GenLocated l e L (EpAnn AnnContext -> SrcSpan -> SrcSpanAnn' (EpAnn AnnContext) forall a. a -> SrcSpan -> SrcSpanAnn' a SrcSpanAnn (Anchor -> AnnContext -> EpAnnComments -> EpAnn AnnContext forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan l) -- Append parens so that the original order in the source is maintained (Maybe (IsUnicodeSyntax, EpaLocation) -> [EpaLocation] -> [EpaLocation] -> AnnContext AnnContext Maybe (IsUnicodeSyntax, EpaLocation) forall a. Maybe a Nothing ([EpaLocation] oparens [EpaLocation] -> [EpaLocation] -> [EpaLocation] forall a. [a] -> [a] -> [a] ++ [EpaLocation] op) ([EpaLocation] cp [EpaLocation] -> [EpaLocation] -> [EpaLocation] forall a. [a] -> [a] -> [a] ++ [EpaLocation] cparens)) (EpAnnComments cs EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments cs')) SrcSpan l) [LHsType GhcPs] [GenLocated SrcSpanAnnA (HsType GhcPs)] ts) check ([EpaLocation] opi,[EpaLocation] cpi,EpAnnComments csi) (L SrcSpanAnnA _lp1 (HsParTy XParTy GhcPs ann' LHsType GhcPs ty)) -- to be sure HsParTy doesn't get into the way = do let ([EpaLocation] op,[EpaLocation] cp,EpAnnComments cs') = case XParTy GhcPs ann' of XParTy GhcPs EpAnn AnnParen EpAnnNotUsed -> ([],[],EpAnnComments emptyComments) EpAnn Anchor _ (AnnParen ParenType _ EpaLocation open EpaLocation close ) EpAnnComments cs -> ([EpaLocation open],[EpaLocation close],EpAnnComments cs) ([EpaLocation], [EpaLocation], EpAnnComments) -> LHsType GhcPs -> P (LHsContext GhcPs) check ([EpaLocation] op[EpaLocation] -> [EpaLocation] -> [EpaLocation] forall a. [a] -> [a] -> [a] ++[EpaLocation] opi,[EpaLocation] cp[EpaLocation] -> [EpaLocation] -> [EpaLocation] forall a. [a] -> [a] -> [a] ++[EpaLocation] cpi,EpAnnComments cs' EpAnnComments -> EpAnnComments -> EpAnnComments forall a. Semigroup a => a -> a -> a Semi.<> EpAnnComments csi) LHsType GhcPs ty -- No need for anns, returning original check ([EpaLocation] _opi,[EpaLocation] _cpi,EpAnnComments _csi) LHsType GhcPs _t = GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] -> P (GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)]) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnn' (EpAnn AnnContext) -> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> GenLocated (SrcSpanAnn' (EpAnn AnnContext)) [GenLocated SrcSpanAnnA (HsType GhcPs)] forall l e. l -> e -> GenLocated l e L (EpAnn AnnContext -> SrcSpan -> SrcSpanAnn' (EpAnn AnnContext) forall a. a -> SrcSpan -> SrcSpanAnn' a SrcSpanAnn (Anchor -> AnnContext -> EpAnnComments -> EpAnn AnnContext forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan l) (Maybe (IsUnicodeSyntax, EpaLocation) -> [EpaLocation] -> [EpaLocation] -> AnnContext AnnContext Maybe (IsUnicodeSyntax, EpaLocation) forall a. Maybe a Nothing [] []) EpAnnComments emptyComments) SrcSpan l) [LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) orig_t]) checkImportDecl :: Maybe EpaLocation -> Maybe EpaLocation -> P () checkImportDecl :: Maybe EpaLocation -> Maybe EpaLocation -> P () checkImportDecl Maybe EpaLocation mPre Maybe EpaLocation mPost = do let whenJust :: Maybe a -> (a -> f ()) -> f () whenJust Maybe a mg a -> f () f = f () -> (a -> f ()) -> Maybe a -> f () forall b a. b -> (a -> b) -> Maybe a -> b maybe (() -> f () forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure ()) a -> f () f Maybe a mg Bool importQualifiedPostEnabled <- ExtBits -> P Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits ImportQualifiedPostBit -- Error if 'qualified' found in postpositive position and -- 'ImportQualifiedPost' is not in effect. Maybe EpaLocation -> (EpaLocation -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe EpaLocation mPost ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \EpaLocation post -> Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool -> Bool not Bool importQualifiedPostEnabled) (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> P () 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. Maybe EpaLocation -> (EpaLocation -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe EpaLocation mPost ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \EpaLocation post -> Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Maybe EpaLocation -> Bool forall a. Maybe a -> Bool isJust Maybe EpaLocation mPre) (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> P () 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. Maybe EpaLocation -> (EpaLocation -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe EpaLocation mPre ((EpaLocation -> P ()) -> P ()) -> (EpaLocation -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \EpaLocation pre -> SrcSpan -> P () warnPrepositiveQualifiedModule (RealSrcSpan -> Maybe BufSpan -> SrcSpan RealSrcSpan (EpaLocation -> RealSrcSpan epaLocationRealSrcSpan EpaLocation pre) Maybe BufSpan forall a. Maybe a Strict.Nothing) -- ------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. PV a -> P a runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs))) -> (LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> LocatedA (PatBuilder GhcPs) -> P (GenLocated SrcSpanAnnA (Pat GhcPs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) checkLPat checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_details ParseContext extraDetails PV (LocatedA (PatBuilder GhcPs)) pp = ParseContext -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. ParseContext -> PV a -> P a runPV_details ParseContext extraDetails (PV (LocatedA (PatBuilder GhcPs)) pp PV (LocatedA (PatBuilder GhcPs)) -> (LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a b. PV a -> (a -> PV b) -> PV b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e :: LocatedA (PatBuilder GhcPs) e@(L SrcSpanAnnA l PatBuilder GhcPs _) = SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpanAnnA l LocatedA (PatBuilder GhcPs) e [] [] checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpanAnnA loc (L SrcSpanAnnA l e :: PatBuilder GhcPs e@(PatBuilderVar (L SrcSpanAnnN ln RdrName c))) [HsConPatTyArg GhcPs] tyargs [LPat GhcPs] args | RdrName -> Bool isRdrDataCon RdrName c = GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (LPat GhcPs) GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (LPat GhcPs)) -> (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)) -> Pat GhcPs -> PV (LPat GhcPs) forall b c a. (b -> c) -> (a -> b) -> a -> c . SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA loc (Pat GhcPs -> PV (LPat GhcPs)) -> Pat GhcPs -> PV (LPat GhcPs) forall a b. (a -> b) -> a -> b $ ConPat { pat_con_ext :: XConPat GhcPs pat_con_ext = XConPat GhcPs EpAnn [AddEpAnn] forall a. EpAnn a noAnn -- AZ: where should this come from? , pat_con :: XRec GhcPs (ConLikeP GhcPs) pat_con = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN ln RdrName c , pat_args :: HsConPatDetails GhcPs pat_args = [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 } | Bool -> Bool not ([HsConPatTyArg GhcPs] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [HsConPatTyArg GhcPs] tyargs) = SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. SrcSpan -> PsMessage -> PV a patFail (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) (PsMessage -> PV (LPat GhcPs)) -> (PsErrInPatDetails -> PsMessage) -> PsErrInPatDetails -> PV (LPat GhcPs) forall b c a. (b -> c) -> (a -> b) -> a -> c . PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage PsErrInPat PatBuilder GhcPs e (PsErrInPatDetails -> PV (LPat GhcPs)) -> PsErrInPatDetails -> PV (LPat GhcPs) forall a b. (a -> b) -> a -> b $ [HsConPatTyArg GhcPs] -> PsErrInPatDetails PEIP_TypeArgs [HsConPatTyArg GhcPs] tyargs | (Bool -> Bool not ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LPat GhcPs] [GenLocated SrcSpanAnnA (Pat GhcPs)] args) Bool -> Bool -> Bool && RdrName -> Bool patIsRec RdrName c) = do ParseContext ctx <- PV ParseContext askParseContext SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. SrcSpan -> PsMessage -> PV a patFail (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) (PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> (PsErrInPatDetails -> PsMessage) -> PsErrInPatDetails -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage PsErrInPat PatBuilder GhcPs e (PsErrInPatDetails -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> PsErrInPatDetails -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a b. (a -> b) -> a -> b $ [LPat GhcPs] -> PatIsRecursive -> ParseContext -> PsErrInPatDetails PEIP_RecPattern [LPat GhcPs] args PatIsRecursive YesPatIsRecursive ParseContext ctx checkPat SrcSpanAnnA loc (L SrcSpanAnnA _ (PatBuilderAppType LocatedA (PatBuilder GhcPs) f LHsToken "@" GhcPs at HsPatSigType GhcPs t)) [HsConPatTyArg GhcPs] tyargs [LPat GhcPs] args = SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpanAnnA loc LocatedA (PatBuilder GhcPs) f (LHsToken "@" GhcPs -> HsPatSigType GhcPs -> HsConPatTyArg GhcPs forall p. LHsToken "@" p -> HsPatSigType p -> HsConPatTyArg p HsConPatTyArg LHsToken "@" GhcPs at HsPatSigType GhcPs t HsConPatTyArg GhcPs -> [HsConPatTyArg GhcPs] -> [HsConPatTyArg GhcPs] forall a. a -> [a] -> [a] : [HsConPatTyArg GhcPs] tyargs) [LPat GhcPs] args checkPat SrcSpanAnnA loc (L SrcSpanAnnA _ (PatBuilderApp LocatedA (PatBuilder GhcPs) f LocatedA (PatBuilder GhcPs) e)) [] [LPat GhcPs] args = do GenLocated SrcSpanAnnA (Pat GhcPs) p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat LocatedA (PatBuilder GhcPs) e SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpanAnnA loc LocatedA (PatBuilder GhcPs) f [] (GenLocated SrcSpanAnnA (Pat GhcPs) p GenLocated SrcSpanAnnA (Pat GhcPs) -> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [GenLocated SrcSpanAnnA (Pat GhcPs)] forall a. a -> [a] -> [a] : [LPat GhcPs] [GenLocated SrcSpanAnnA (Pat GhcPs)] args) checkPat SrcSpanAnnA loc (L SrcSpanAnnA l PatBuilder GhcPs e) [] [] = do Pat GhcPs p <- SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat SrcSpanAnnA loc PatBuilder GhcPs e GenLocated SrcSpanAnnA (Pat GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA l Pat GhcPs p) checkPat SrcSpanAnnA loc LocatedA (PatBuilder GhcPs) e [HsConPatTyArg GhcPs] _ [LPat GhcPs] _ = do PsErrInPatDetails details <- ParseContext -> PsErrInPatDetails fromParseContext (ParseContext -> PsErrInPatDetails) -> PV ParseContext -> PV PsErrInPatDetails forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> PV ParseContext askParseContext SrcSpan -> PsMessage -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. SrcSpan -> PsMessage -> PV a patFail (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage PsErrInPat (LocatedA (PatBuilder GhcPs) -> PatBuilder GhcPs forall l e. GenLocated l e -> e unLoc LocatedA (PatBuilder GhcPs) e) PsErrInPatDetails details) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat SrcSpanAnnA loc PatBuilder GhcPs e0 = do Bool nPlusKPatterns <- ExtBits -> PV Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits NPlusKPatternsBit case PatBuilder GhcPs e0 of PatBuilderPat Pat GhcPs p -> Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return Pat GhcPs p PatBuilderVar GenLocated SrcSpanAnnN RdrName x -> Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (XVarPat GhcPs -> XRec GhcPs (IdP GhcPs) -> Pat GhcPs forall p. XVarPat p -> LIdP p -> Pat p VarPat XVarPat GhcPs NoExtField noExtField XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName x) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer PatBuilderOverLit HsOverLit GhcPs pos_lit -> Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs mkNPat (SrcAnn NoEpAnns -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> SrcAnn NoEpAnns forall a ann. SrcSpanAnn' a -> SrcAnn ann l2l SrcSpanAnnA loc) HsOverLit GhcPs pos_lit) Maybe NoExtField Maybe (SyntaxExpr GhcPs) forall a. Maybe a Nothing EpAnn [AddEpAnn] forall a. EpAnn a noAnn) -- 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 {}}))) (EpAnn Anchor anc [AddEpAnn] _ EpAnnComments cs) | Bool nPlusKPatterns Bool -> Bool -> Bool && (RdrName plus RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == RdrName plus_RDR) -> Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs mkNPlusKPat (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN nloc RdrName n) (SrcAnn NoEpAnns -> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs) forall l e. l -> e -> GenLocated l e L (SrcSpanAnnA -> SrcAnn NoEpAnns forall a ann. SrcSpanAnn' a -> SrcAnn ann l2l SrcSpanAnnA lloc) HsOverLit GhcPs lit) (Anchor -> EpaLocation -> EpAnnComments -> EpAnn EpaLocation forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn Anchor anc (SrcSpanAnnN -> EpaLocation forall ann. SrcAnn ann -> EpaLocation epaLocationFromSrcAnn SrcSpanAnnN l) EpAnnComments cs)) -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp LocatedA (PatBuilder GhcPs) _ GenLocated SrcSpanAnnN RdrName op LocatedA (PatBuilder GhcPs) _ EpAnn [AddEpAnn] _ | RdrName -> Bool opIsAt (GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN RdrName op) -> do MsgEnvelope PsMessage -> PV () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (MsgEnvelope PsMessage -> PV ()) -> MsgEnvelope PsMessage -> PV () forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (GenLocated SrcSpanAnnN RdrName -> SrcSpan forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA GenLocated SrcSpanAnnN RdrName op) PsMessage PsErrAtInPatPos Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (XWildPat GhcPs -> Pat GhcPs forall p. XWildPat p -> Pat p WildPat XWildPat GhcPs NoExtField noExtField) PatBuilderOpApp LocatedA (PatBuilder GhcPs) l (L SrcSpanAnnN cl RdrName c) LocatedA (PatBuilder GhcPs) r EpAnn [AddEpAnn] anns | RdrName -> Bool isRdrDataCon RdrName c -> do GenLocated SrcSpanAnnA (Pat GhcPs) l <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat LocatedA (PatBuilder GhcPs) l GenLocated SrcSpanAnnA (Pat GhcPs) r <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat LocatedA (PatBuilder GhcPs) r Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (Pat GhcPs -> PV (Pat GhcPs)) -> Pat GhcPs -> PV (Pat GhcPs) forall a b. (a -> b) -> a -> b $ ConPat { pat_con_ext :: XConPat GhcPs pat_con_ext = XConPat GhcPs EpAnn [AddEpAnn] anns , pat_con :: XRec GhcPs (ConLikeP GhcPs) pat_con = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN cl RdrName c , pat_args :: HsConPatDetails GhcPs pat_args = GenLocated SrcSpanAnnA (Pat GhcPs) -> GenLocated SrcSpanAnnA (Pat GhcPs) -> HsConDetails (HsConPatTyArg GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs)) (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))) forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec InfixCon GenLocated SrcSpanAnnA (Pat GhcPs) l GenLocated SrcSpanAnnA (Pat GhcPs) r } PatBuilderPar LHsToken "(" GhcPs lpar LocatedA (PatBuilder GhcPs) e LHsToken ")" GhcPs rpar -> do GenLocated SrcSpanAnnA (Pat GhcPs) p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat LocatedA (PatBuilder GhcPs) e Pat GhcPs -> PV (Pat GhcPs) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (XParPat GhcPs -> LHsToken "(" GhcPs -> LPat GhcPs -> LHsToken ")" GhcPs -> Pat GhcPs forall p. XParPat p -> LHsToken "(" p -> LPat p -> LHsToken ")" p -> Pat p ParPat (Anchor -> NoEpAnns -> EpAnnComments -> EpAnn NoEpAnns forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc)) NoEpAnns NoEpAnns EpAnnComments emptyComments) LHsToken "(" GhcPs lpar LPat GhcPs GenLocated SrcSpanAnnA (Pat GhcPs) p LHsToken ")" GhcPs rpar) PatBuilder GhcPs _ -> do PsErrInPatDetails details <- ParseContext -> PsErrInPatDetails fromParseContext (ParseContext -> PsErrInPatDetails) -> PV ParseContext -> PV PsErrInPatDetails forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> PV ParseContext askParseContext SrcSpan -> PsMessage -> PV (Pat GhcPs) forall a. SrcSpan -> PsMessage -> PV a patFail (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA loc) (PatBuilder GhcPs -> PsErrInPatDetails -> PsMessage PsErrInPat PatBuilder GhcPs e0 PsErrInPatDetails details) placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging placeHolderPunRhs :: forall b. DisambECP b => PV (LocatedA b) placeHolderPunRhs = GenLocated SrcSpanAnnN RdrName -> PV (LocatedA b) forall b. DisambECP b => GenLocated SrcSpanAnnN RdrName -> PV (LocatedA b) mkHsVarPV (RdrName -> GenLocated SrcSpanAnnN RdrName forall a an. a -> LocatedAn an a noLocA RdrName pun_RDR) plus_RDR, pun_RDR :: RdrName plus_RDR :: RdrName plus_RDR = NameSpace -> FastString -> RdrName mkUnqual NameSpace varName (String -> FastString fsLit String "+") -- 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 (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA (PatBuilder GhcPs)) fld) = do GenLocated SrcSpanAnnA (Pat GhcPs) p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA (PatBuilder GhcPs)) -> LocatedA (PatBuilder GhcPs) forall lhs rhs. HsFieldBind lhs rhs -> rhs hfbRHS HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA (PatBuilder GhcPs)) fld) GenLocated SrcSpanAnnA (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs))) -> PV (GenLocated SrcSpanAnnA (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs)))) forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpanAnnA -> HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs)) -> GenLocated SrcSpanAnnA (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs))) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA l (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (LocatedA (PatBuilder GhcPs)) fld { hfbRHS = 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) -> Maybe (AddEpAnn, LHsType GhcPs) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkValDef :: SrcSpan -> LocatedA (PatBuilder GhcPs) -> Maybe (AddEpAnn, LHsType GhcPs) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkValDef SrcSpan loc LocatedA (PatBuilder GhcPs) lhs (Just (AddEpAnn sigAnn, LHsType GhcPs sig)) Located (GRHSs GhcPs (LHsExpr GhcPs)) grhss -- x :: ty = rhs parses as a *pattern* binding = do GenLocated SrcSpanAnnA (Pat GhcPs) lhs' <- PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a. PV a -> P a runPV (PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs))) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) -> P (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA (PatBuilder GhcPs)) forall b. DisambECP b => SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b) mkHsTySigPV (LocatedA (PatBuilder GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA forall a e1 e2. Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a combineLocsA LocatedA (PatBuilder GhcPs) lhs LHsType GhcPs GenLocated SrcSpanAnnA (HsType GhcPs) sig) LocatedA (PatBuilder GhcPs) lhs LHsType GhcPs sig [AddEpAnn sigAnn] PV (LocatedA (PatBuilder GhcPs)) -> (LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) forall a b. PV a -> (a -> PV b) -> PV b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) checkLPat SrcSpan -> [AddEpAnn] -> LPat GhcPs -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkPatBind SrcSpan loc [] LPat GhcPs GenLocated SrcSpanAnnA (Pat GhcPs) lhs' Located (GRHSs GhcPs (LHsExpr GhcPs)) grhss checkValDef SrcSpan loc LocatedA (PatBuilder GhcPs) lhs Maybe (AddEpAnn, LHsType GhcPs) Nothing Located (GRHSs GhcPs (LHsExpr GhcPs)) g = do { Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn]) mb_fun <- LocatedA (PatBuilder GhcPs) -> P (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn])) isFunLhs LocatedA (PatBuilder GhcPs) lhs ; case Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn]) mb_fun of Just (GenLocated SrcSpanAnnN RdrName fun, LexicalFixity is_infix, [LocatedA (PatBuilder GhcPs)] pats, [AddEpAnn] ann) -> SrcStrictness -> SrcSpan -> [AddEpAnn] -> GenLocated SrcSpanAnnN RdrName -> LexicalFixity -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkFunBind SrcStrictness NoSrcStrict SrcSpan loc [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName fun LexicalFixity is_infix [LocatedA (PatBuilder GhcPs)] pats Located (GRHSs GhcPs (LHsExpr GhcPs)) g Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn]) Nothing -> do GenLocated SrcSpanAnnA (Pat GhcPs) lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern LocatedA (PatBuilder GhcPs) lhs SrcSpan -> [AddEpAnn] -> LPat GhcPs -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkPatBind SrcSpan loc [] LPat GhcPs GenLocated SrcSpanAnnA (Pat GhcPs) lhs' Located (GRHSs GhcPs (LHsExpr GhcPs)) g } checkFunBind :: SrcStrictness -> SrcSpan -> [AddEpAnn] -> LocatedN RdrName -> LexicalFixity -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkFunBind :: SrcStrictness -> SrcSpan -> [AddEpAnn] -> GenLocated SrcSpanAnnN RdrName -> LexicalFixity -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkFunBind SrcStrictness strictness SrcSpan locF [AddEpAnn] ann GenLocated SrcSpanAnnN RdrName fun LexicalFixity is_infix [LocatedA (PatBuilder GhcPs)] pats (L SrcSpan _ GRHSs GhcPs (LHsExpr GhcPs) grhss) = do [GenLocated SrcSpanAnnA (Pat GhcPs)] ps <- ParseContext -> PV [GenLocated SrcSpanAnnA (Pat GhcPs)] -> P [GenLocated SrcSpanAnnA (Pat GhcPs)] forall a. ParseContext -> PV a -> P a runPV_details ParseContext extraDetails ((LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs))) -> [LocatedA (PatBuilder GhcPs)] -> PV [GenLocated SrcSpanAnnA (Pat GhcPs)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) LocatedA (PatBuilder GhcPs) -> PV (GenLocated SrcSpanAnnA (Pat GhcPs)) checkLPat [LocatedA (PatBuilder GhcPs)] pats) let match_span :: SrcSpanAnnA match_span = SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA forall a b. (a -> b) -> a -> b $ SrcSpan locF EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan locF HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind GenLocated SrcSpanAnnN RdrName fun (SrcSpanAnnL -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnL forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan (SrcSpan -> SrcSpanAnnL) -> SrcSpan -> SrcSpanAnnL forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA match_span) [SrcSpanAnnA -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall l e. l -> e -> GenLocated l e L SrcSpanAnnA match_span (Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_ext = Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan locF) [AddEpAnn] ann EpAnnComments cs , m_ctxt :: HsMatchContext GhcPs m_ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs) mc_fun = LIdP (NoGhcTc GhcPs) GenLocated SrcSpanAnnN RdrName fun , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity is_infix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness strictness } , m_pats :: [LPat GhcPs] m_pats = [LPat GhcPs] [GenLocated SrcSpanAnnA (Pat GhcPs)] ps , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) grhss })])) -- 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 -> Maybe RdrName) -> RdrName -> Maybe RdrName forall a b. (a -> b) -> a -> b $ GenLocated SrcSpanAnnN RdrName -> RdrName forall l e. GenLocated l e -> e unLoc GenLocated SrcSpanAnnN 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 :: GenLocated SrcSpanAnnN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind GenLocated SrcSpanAnnN 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) GenLocated SrcSpanAnnN 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 -> [AddEpAnn] -> LPat GhcPs -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkPatBind :: SrcSpan -> [AddEpAnn] -> LPat GhcPs -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBindLR GhcPs GhcPs) checkPatBind SrcSpan loc [AddEpAnn] annsIn (L SrcSpanAnnA _ (BangPat (EpAnn Anchor _ [AddEpAnn] ans EpAnnComments cs) (L SrcSpanAnnA _ (VarPat XVarPat GhcPs _ XRec GhcPs (IdP GhcPs) v)))) (L SrcSpan _match_span GRHSs GhcPs (LHsExpr GhcPs) grhss) = HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpanAnnN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName v (SrcSpanAnnL -> [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))] forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnL forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) [SrcSpanAnnA -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) forall l e. l -> e -> GenLocated l e L (SrcSpan -> SrcSpanAnnA forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) (EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnN RdrName -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) ([AddEpAnn] ans[AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++[AddEpAnn] annsIn) EpAnnComments cs) XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName v)])) where m :: EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnN RdrName -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m EpAnn [AddEpAnn] a GenLocated SrcSpanAnnN RdrName v = Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_ext = XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) EpAnn [AddEpAnn] a , m_ctxt :: HsMatchContext GhcPs m_ctxt = FunRhs { mc_fun :: LIdP (NoGhcTc GhcPs) mc_fun = LIdP (NoGhcTc GhcPs) GenLocated SrcSpanAnnN RdrName v , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity Prefix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness SrcStrict } , m_pats :: [LPat GhcPs] m_pats = [] , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) grhss } checkPatBind SrcSpan loc [AddEpAnn] annsIn LPat GhcPs lhs (L SrcSpan _ GRHSs GhcPs (LHsExpr GhcPs) grhss) = do EpAnnComments cs <- SrcSpan -> P EpAnnComments forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments getCommentsFor SrcSpan loc HsBindLR GhcPs GhcPs -> P (HsBindLR GhcPs GhcPs) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return (XPatBind GhcPs GhcPs -> LPat GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) -> HsBindLR GhcPs GhcPs forall idL idR. XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> HsBindLR idL idR PatBind (Anchor -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann EpAnn (SrcSpan -> Anchor spanAsAnchor SrcSpan loc) [AddEpAnn] annsIn EpAnnComments cs) LPat GhcPs lhs GRHSs GhcPs (LHsExpr GhcPs) grhss) checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs :: LHsExpr GhcPs -> P (GenLocated SrcSpanAnnN RdrName) checkValSigLhs (L SrcSpanAnnA _ (HsVar XVar GhcPs _ lrdr :: XRec GhcPs (IdP GhcPs) lrdr@(L SrcSpanAnnN _ RdrName v))) | RdrName -> Bool isUnqual RdrName v , Bool -> Bool not (OccName -> Bool isDataOcc (RdrName -> OccName rdrNameOcc RdrName v)) = GenLocated SrcSpanAnnN RdrName -> P (GenLocated SrcSpanAnnN RdrName) forall a. a -> P a forall (m :: * -> *) a. Monad m => a -> m a return XRec GhcPs (IdP GhcPs) GenLocated SrcSpanAnnN RdrName lrdr checkValSigLhs lhs :: LHsExpr GhcPs lhs@(L SrcSpanAnnA l HsExpr GhcPs _) = MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName) forall a. MsgEnvelope PsMessage -> P a forall (m :: * -> *) a. MonadP m => MsgEnvelope PsMessage -> m a addFatalError (MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName)) -> MsgEnvelope PsMessage -> P (GenLocated SrcSpanAnnN RdrName) forall a b. (a -> b) -> a -> b $ SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope (SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) (PsMessage -> MsgEnvelope PsMessage) -> PsMessage -> MsgEnvelope PsMessage forall a b. (a -> b) -> a -> b $ LHsExpr GhcPs -> PsMessage PsErrInvalidTypeSignature LHsExpr GhcPs lhs checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) => (a -> Bool -> b -> Bool -> c -> PsMessage) -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse :: forall a b c. (Outputable a, Outputable b, Outputable c) => (a -> Bool -> b -> Bool -> c -> PsMessage) -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse a -> Bool -> b -> Bool -> c -> PsMessage err LocatedA a guardExpr Bool semiThen LocatedA b thenExpr Bool semiElse LocatedA c elseExpr | Bool semiThen Bool -> Bool -> Bool || Bool semiElse = do Bool doAndIfThenElse <- ExtBits -> PV Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits DoAndIfThenElseBit let e :: PsMessage e = a -> Bool -> b -> Bool -> c -> PsMessage err (LocatedA a -> a forall l e. GenLocated l e -> e unLoc LocatedA a guardExpr) Bool semiThen (LocatedA b -> b forall l e. GenLocated l e -> e unLoc LocatedA b thenExpr) Bool semiElse (LocatedA c -> c forall l e. GenLocated l e -> e unLoc LocatedA c elseExpr) loc :: SrcSpan loc = Located a -> Located c -> SrcSpan forall a b. Located a -> Located b -> SrcSpan combineLocs (LocatedA a -> Located a forall a e. LocatedAn a e -> Located e reLoc LocatedA a guardExpr) (LocatedA c -> Located c forall a e. LocatedAn a e -> Located e reLoc LocatedA c elseExpr) Bool -> PV () -> PV () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool doAndIfThenElse (PV () -> PV ()) -> PV () -> PV () forall a b. (a -> b) -> a -> b $ MsgEnvelope PsMessage -> PV () forall (m :: * -> *). MonadP m => MsgEnvelope PsMessage -> m () addError (SrcSpan -> PsMessage -> MsgEnvelope PsMessage forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope SrcSpan loc PsMessage e) | Bool otherwise = () -> PV () forall a. a -> PV a forall (m :: * -> *) a. Monad m => a -> m a return () isFunLhs :: LocatedA (PatBuilder GhcPs) -> P (Maybe (LocatedN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)],[AddEpAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS isFunLhs :: LocatedA (PatBuilder GhcPs) -> P (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn])) isFunLhs LocatedA (PatBuilder GhcPs) e = LocatedA (PatBuilder GhcPs) -> [LocatedA (PatBuilder GhcPs)] -> [AddEpAnn] -> [AddEpAnn] -> P (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder GhcPs)], [AddEpAnn])) forall {m :: * -> *} {p}. Monad m => LocatedA (PatBuilder p) -> [LocatedA (PatBuilder p)] -> [AddEpAnn] -> [AddEpAnn] -> m (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn])) go LocatedA (PatBuilder GhcPs) e [] [] [] where go :: LocatedA (PatBuilder p) -> [LocatedA (PatBuilder p)] -> [AddEpAnn] -> [AddEpAnn] -> m (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn])) go (L SrcSpanAnnA _ (PatBuilderVar (L SrcSpanAnnN loc RdrName f))) [LocatedA (PatBuilder p)] es [AddEpAnn] ops [AddEpAnn] cps | Bool -> Bool not (RdrName -> Bool isRdrDataCon RdrName f) = Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn]) -> m (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn])) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return ((GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn]) -> Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn]) forall a. a -> Maybe a Just (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName forall l e. l -> e -> GenLocated l e L SrcSpanAnnN loc RdrName f, LexicalFixity Prefix, [LocatedA (PatBuilder p)] es, ([AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] reverse [AddEpAnn] ops) [AddEpAnn] -> [AddEpAnn] -> [AddEpAnn] forall a. [a] -> [a] -> [a] ++ [AddEpAnn] cps)) go (L SrcSpanAnnA _ (PatBuilderApp LocatedA (PatBuilder p) f LocatedA (PatBuilder p) e)) [LocatedA (PatBuilder p)] es [AddEpAnn] ops [AddEpAnn] cps = LocatedA (PatBuilder p) -> [LocatedA (PatBuilder p)] -> [AddEpAnn] -> [AddEpAnn] -> m (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn])) go LocatedA (PatBuilder p) f (LocatedA (PatBuilder p) eLocatedA (PatBuilder p) -> [LocatedA (PatBuilder p)] -> [LocatedA (PatBuilder p)] forall a. a -> [a] -> [a] :[LocatedA (PatBuilder p)] es) [AddEpAnn] ops [AddEpAnn] cps go (L SrcSpanAnnA l (PatBuilderPar LHsToken "(" p _ LocatedA (PatBuilder p) e LHsToken ")" p _)) es :: [LocatedA (PatBuilder p)] es@(LocatedA (PatBuilder p) _:[LocatedA (PatBuilder p)] _) [AddEpAnn] ops [AddEpAnn] cps = let (AddEpAnn o,AddEpAnn c) = RealSrcSpan -> (AddEpAnn, AddEpAnn) mkParensEpAnn (SrcSpan -> RealSrcSpan realSrcSpan (SrcSpan -> RealSrcSpan) -> SrcSpan -> RealSrcSpan forall a b. (a -> b) -> a -> b $ SrcSpanAnnA -> SrcSpan forall a. SrcSpanAnn' a -> SrcSpan locA SrcSpanAnnA l) in LocatedA (PatBuilder p) -> [LocatedA (PatBuilder p)] -> [AddEpAnn] -> [AddEpAnn] -> m (Maybe (GenLocated SrcSpanAnnN RdrName, LexicalFixity, [LocatedA (PatBuilder p)], [AddEpAnn])) go LocatedA (PatBuilder p) e [LocatedA (PatBuilder p)] es (AddEpAnn oAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] ops) (AddEpAnn cAddEpAnn -> [AddEpAnn] -> [AddEpAnn] forall a. a -> [a] -> [a] :[AddEpAnn] cps) go (L SrcSpanAnnA loc (PatBuilderOpApp LocatedA (PatBuilder p) l (L SrcSpanAnnN loc' RdrName op) LocatedA (PatBuilder p) r (EpAnn Anchor loca [AddEpAnn] anns EpAnnComments cs)))