-- -- (c) The University of Glasgow 2002-2006 -- -- Functions over HsSyn specialised to RdrName. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Parser.PostProcess ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkSpliceDecl, mkRoleAnnotDecl, mkClassDecl, mkTyData, mkDataFamInst, mkTySynonym, mkTyFamInstEqn, mkStandaloneKindSig, mkTyFamInst, mkFamDecl, mkLHsSigType, mkInlinePragma, mkPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyClD, mkInstD, mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, filterCTuple, fromSpecTyVarBndr, fromSpecTyVarBndrs, cvBindGroup, cvBindsAndSigs, cvTopDecls, placeHolderPunRhs, -- Stuff to do with Foreign declarations mkImport, parseCImport, mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located 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_msg, checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, LRuleTyTmVar, RuleTyTmVar(..), mkRuleBndrs, mkRuleTyVarBndrs, checkRuleTyVarBndrNames, checkRecordSyntax, checkEmptyGADTs, addFatalError, hintBangPat, TyEl(..), mergeOps, mergeDataCon, mkBangTy, mkMultTy, -- Help with processing exports ImpExpSubSpec(..), ImpExpQcSpec(..), mkModuleImpExp, mkTypeImpExp, mkImpExpSubSpec, checkImportSpec, -- Token symbols forallSym, starSym, -- Warnings and errors warnStarIsType, warnPrepositiveQualifiedModule, failOpFewArgs, failOpNotEnabledImportQualifiedPost, failOpImportQualifiedTwice, SumOrTuple (..), -- Expression/command/pattern ambiguity resolution PV, runPV, ECP(ECP, runECP_PV), runECP_P, DisambInfixOp(..), DisambECP(..), ecpFromExp, ecpFromCmd, PatBuilder ) 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.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Parser.Lexer import GHC.Utils.Lexeme ( isLexCon ) import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, tupleTyConName, cTupleTyConNameArity_maybe ) import GHC.Types.ForeignCall import GHC.Builtin.Names ( allNameStrings ) import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) import GHC.Data.OrdList ( OrdList, fromOL ) import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Parser.Annotation import Data.List import GHC.Driver.Session ( WarningFlag(..), DynFlags ) import GHC.Utils.Error ( Messages ) import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.Char import qualified Data.Monoid as Monoid import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) import Data.Kind ( Type ) #include "HsVersions.h" {- ********************************************************************** 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 SrcSpan loc TyClDecl (GhcPass p) d) = SrcSpan -> HsDecl (GhcPass p) -> GenLocated SrcSpan (HsDecl (GhcPass p)) forall l e. l -> e -> GenLocated l e L SrcSpan loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p) forall p. XTyClD p -> TyClDecl p -> HsDecl p TyClD NoExtField XTyClD (GhcPass p) noExtField TyClDecl (GhcPass p) d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) mkInstD :: forall (p :: Pass). LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) mkInstD (L SrcSpan loc InstDecl (GhcPass p) d) = SrcSpan -> HsDecl (GhcPass p) -> GenLocated SrcSpan (HsDecl (GhcPass p)) forall l e. l -> e -> GenLocated l e L SrcSpan loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p) forall p. XInstD p -> InstDecl p -> HsDecl p InstD NoExtField XInstD (GhcPass p) noExtField InstDecl (GhcPass p) d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo -> P (LTyClDecl GhcPs) mkClassDecl :: forall a. SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo -> P (LTyClDecl GhcPs) mkClassDecl SrcSpan loc (L SrcSpan _ (Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs tycl_hdr)) Located (a, [LHsFunDep GhcPs]) fds OrdList (LHsDecl GhcPs) where_cls LayoutInfo layoutInfo = do { (LHsBinds GhcPs binds, [LSig GhcPs] sigs, [LFamilyDecl GhcPs] ats, [LTyFamInstDecl GhcPs] at_defs, [LDataFamInstDecl GhcPs] _, [LDocDecl] docs) <- OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) cvBindsAndSigs OrdList (LHsDecl GhcPs) where_cls ; let cxt :: LHsContext GhcPs cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs forall a. a -> Maybe a -> a fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs forall e. e -> Located e noLoc []) Maybe (LHsContext GhcPs) mcxt ; (Located RdrName cls, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool True LHsType GhcPs tycl_hdr ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] ann -- Add any API Annotations to the top SrcSpan ; (LHsQTyVars GhcPs tyvars,[AddAnn] annst) <- SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs, [AddAnn]) checkTyVars (String -> SDoc text String "class") SDoc whereDots Located RdrName cls [LHsTypeArg GhcPs] tparams ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] annst -- Add any API Annotations to the top SrcSpan ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (ClassDecl :: forall pass. XClassDecl pass -> LHsContext pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl] -> TyClDecl pass ClassDecl { tcdCExt :: XClassDecl GhcPs tcdCExt = LayoutInfo XClassDecl GhcPs layoutInfo , tcdCtxt :: LHsContext GhcPs tcdCtxt = LHsContext GhcPs cxt , tcdLName :: Located (IdP GhcPs) tcdLName = Located RdrName Located (IdP GhcPs) cls, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars , tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity , tcdFDs :: [LHsFunDep GhcPs] tcdFDs = (a, [Located (FunDep (Located RdrName))]) -> [Located (FunDep (Located RdrName))] forall a b. (a, b) -> b snd (GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))]) -> (a, [Located (FunDep (Located RdrName))]) forall l e. GenLocated l e -> e unLoc GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))]) Located (a, [LHsFunDep GhcPs]) fds) , tcdSigs :: [LSig GhcPs] tcdSigs = [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs [LSig GhcPs] sigs , tcdMeths :: LHsBinds GhcPs tcdMeths = LHsBinds GhcPs binds , tcdATs :: [LFamilyDecl GhcPs] tcdATs = [LFamilyDecl GhcPs] ats, tcdATDefs :: [LTyFamInstDecl GhcPs] tcdATDefs = [LTyFamInstDecl GhcPs] at_defs , tcdDocs :: [LDocDecl] tcdDocs = [LDocDecl] docs })) } mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) mkTyData SrcSpan loc NewOrData new_or_data Maybe (Located CType) cType (L SrcSpan _ (Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs tycl_hdr)) Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons HsDeriving GhcPs maybe_deriv = do { (Located RdrName tc, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool False LHsType GhcPs tycl_hdr ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] ann -- Add any API Annotations to the top SrcSpan ; (LHsQTyVars GhcPs tyvars, [AddAnn] anns) <- SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs, [AddAnn]) checkTyVars (NewOrData -> SDoc forall a. Outputable a => a -> SDoc ppr NewOrData new_or_data) SDoc equalsDots Located RdrName tc [LHsTypeArg GhcPs] tparams ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] anns -- Add any API Annotations to the top SrcSpan ; HsDataDefn GhcPs defn <- NewOrData -> Maybe (Located CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) mkDataDefn NewOrData new_or_data Maybe (Located CType) cType Maybe (LHsContext GhcPs) mcxt Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons HsDeriving GhcPs maybe_deriv ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (DataDecl :: forall pass. XDataDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass DataDecl { tcdDExt :: XDataDecl GhcPs tcdDExt = NoExtField XDataDecl GhcPs noExtField, tcdLName :: Located (IdP GhcPs) tcdLName = Located RdrName Located (IdP GhcPs) tc, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars, tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity, tcdDataDefn :: HsDataDefn GhcPs tcdDataDefn = HsDataDefn GhcPs defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) mkDataDefn :: NewOrData -> Maybe (Located CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) mkDataDefn NewOrData new_or_data Maybe (Located CType) cType Maybe (LHsContext GhcPs) mcxt Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons HsDeriving GhcPs maybe_deriv = do { Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Maybe (LHsContext GhcPs) mcxt ; let cxt :: LHsContext GhcPs cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs forall a. a -> Maybe a -> a fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs forall e. e -> Located e noLoc []) Maybe (LHsContext GhcPs) mcxt ; HsDataDefn GhcPs -> P (HsDataDefn GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (HsDataDefn :: forall pass. XCHsDataDefn pass -> NewOrData -> LHsContext pass -> Maybe (Located CType) -> Maybe (LHsKind pass) -> [LConDecl pass] -> HsDeriving pass -> HsDataDefn pass HsDataDefn { dd_ext :: XCHsDataDefn GhcPs dd_ext = NoExtField XCHsDataDefn GhcPs noExtField , dd_ND :: NewOrData dd_ND = NewOrData new_or_data, dd_cType :: Maybe (Located CType) dd_cType = Maybe (Located CType) cType , dd_ctxt :: LHsContext GhcPs dd_ctxt = LHsContext GhcPs cxt , dd_cons :: [LConDecl GhcPs] dd_cons = [LConDecl GhcPs] data_cons , dd_kindSig :: Maybe (LHsType GhcPs) dd_kindSig = Maybe (LHsType GhcPs) ksig , dd_derivs :: HsDeriving GhcPs dd_derivs = HsDeriving GhcPs maybe_deriv }) } mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS -> P (LTyClDecl GhcPs) mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs) mkTySynonym SrcSpan loc LHsType GhcPs lhs LHsType GhcPs rhs = do { (Located RdrName tc, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] ann -- Add any API Annotations to the top SrcSpan ; (LHsQTyVars GhcPs tyvars, [AddAnn] anns) <- SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs, [AddAnn]) checkTyVars (String -> SDoc text String "type") SDoc equalsDots Located RdrName tc [LHsTypeArg GhcPs] tparams ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] anns -- Add any API Annotations to the top SrcSpan ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (SynDecl :: forall pass. XSynDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass SynDecl { tcdSExt :: XSynDecl GhcPs tcdSExt = NoExtField XSynDecl GhcPs noExtField , tcdLName :: Located (IdP GhcPs) tcdLName = Located RdrName Located (IdP GhcPs) tc, tcdTyVars :: LHsQTyVars GhcPs tcdTyVars = LHsQTyVars GhcPs tyvars , tcdFixity :: LexicalFixity tcdFixity = LexicalFixity fixity , tcdRhs :: LHsType GhcPs tcdRhs = LHsType GhcPs rhs })) } mkStandaloneKindSig :: SrcSpan -> Located [Located RdrName] -- LHS -> LHsKind GhcPs -- RHS -> P (LStandaloneKindSig GhcPs) mkStandaloneKindSig :: SrcSpan -> Located [Located RdrName] -> LHsType GhcPs -> P (LStandaloneKindSig GhcPs) mkStandaloneKindSig SrcSpan loc Located [Located RdrName] lhs LHsType GhcPs rhs = do { [Located RdrName] vs <- (Located RdrName -> P (Located RdrName)) -> [Located RdrName] -> P [Located RdrName] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Located RdrName -> P (Located RdrName) forall {m :: * -> *}. MonadP m => Located RdrName -> m (Located RdrName) check_lhs_name (Located [Located RdrName] -> [Located RdrName] forall l e. GenLocated l e -> e unLoc Located [Located RdrName] lhs) ; Located RdrName v <- [Located RdrName] -> P (Located RdrName) check_singular_lhs ([Located RdrName] -> [Located RdrName] forall a. [a] -> [a] reverse [Located RdrName] vs) ; LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)) -> LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs) forall a b. (a -> b) -> a -> b $ SrcSpan -> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs) -> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs forall a b. (a -> b) -> a -> b $ XStandaloneKindSig GhcPs -> Located (IdP GhcPs) -> LHsSigType GhcPs -> StandaloneKindSig GhcPs forall pass. XStandaloneKindSig pass -> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass StandaloneKindSig NoExtField XStandaloneKindSig GhcPs noExtField Located RdrName Located (IdP GhcPs) v (LHsType GhcPs -> LHsSigType GhcPs mkLHsSigType LHsType GhcPs rhs) } where check_lhs_name :: Located RdrName -> m (Located RdrName) check_lhs_name v :: Located RdrName v@(Located 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 Located RdrName -> m (Located RdrName) forall (m :: * -> *) a. Monad m => a -> m a return Located RdrName v else SrcSpan -> SDoc -> m (Located RdrName) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc Located RdrName v) (SDoc -> m (Located RdrName)) -> SDoc -> m (Located RdrName) forall a b. (a -> b) -> a -> b $ SDoc -> Int -> SDoc -> SDoc hang (String -> SDoc text String "Expected an unqualified type constructor:") Int 2 (Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr Located RdrName v) check_singular_lhs :: [Located RdrName] -> P (Located RdrName) check_singular_lhs [Located RdrName] vs = case [Located RdrName] vs of [] -> String -> P (Located RdrName) forall a. String -> a panic String "mkStandaloneKindSig: empty left-hand side" [Located RdrName v] -> Located RdrName -> P (Located RdrName) forall (m :: * -> *) a. Monad m => a -> m a return Located RdrName v [Located RdrName] _ -> SrcSpan -> SDoc -> P (Located RdrName) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError (Located [Located RdrName] -> SrcSpan forall l e. GenLocated l e -> l getLoc Located [Located RdrName] lhs) (SDoc -> P (Located RdrName)) -> SDoc -> P (Located RdrName) forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc vcat [ SDoc -> Int -> SDoc -> SDoc hang (String -> SDoc text String "Standalone kind signatures do not support multiple names at the moment:") Int 2 ((Located RdrName -> SDoc) -> [Located RdrName] -> SDoc forall a. (a -> SDoc) -> [a] -> SDoc pprWithCommas Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr [Located RdrName] vs) , String -> SDoc text String "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> LHsType GhcPs -> P (TyFamInstEqn GhcPs,[AddAnn]) mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> LHsType GhcPs -> P (TyFamInstEqn GhcPs, [AddAnn]) mkTyFamInstEqn Maybe [LHsTyVarBndr () GhcPs] bndrs LHsType GhcPs lhs LHsType GhcPs rhs = do { (Located RdrName tc, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs forall thing. thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs (FamEqn :: forall pass rhs. XCFamEqn pass rhs -> Located (IdP pass) -> Maybe [LHsTyVarBndr () pass] -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs) feqn_ext = NoExtField XCFamEqn GhcPs (LHsType GhcPs) noExtField , feqn_tycon :: Located (IdP GhcPs) feqn_tycon = Located RdrName Located (IdP GhcPs) tc , feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs = Maybe [LHsTyVarBndr () GhcPs] bndrs , feqn_pats :: [LHsTypeArg GhcPs] feqn_pats = [LHsTypeArg GhcPs] tparams , feqn_fixity :: LexicalFixity feqn_fixity = LexicalFixity fixity , feqn_rhs :: LHsType GhcPs feqn_rhs = LHsType GhcPs rhs }), [AddAnn] ann) } mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs] , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs) mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) -> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs) mkDataFamInst SrcSpan loc NewOrData new_or_data Maybe (Located CType) cType (Maybe (LHsContext GhcPs) mcxt, Maybe [LHsTyVarBndr () GhcPs] bndrs, LHsType GhcPs tycl_hdr) Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons HsDeriving GhcPs maybe_deriv = do { (Located RdrName tc, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool False LHsType GhcPs tycl_hdr ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] ann -- Add any API Annotations to the top SrcSpan ; HsDataDefn GhcPs defn <- NewOrData -> Maybe (Located CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsType GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) mkDataDefn NewOrData new_or_data Maybe (Located CType) cType Maybe (LHsContext GhcPs) mcxt Maybe (LHsType GhcPs) ksig [LConDecl GhcPs] data_cons HsDeriving GhcPs maybe_deriv ; LInstDecl GhcPs -> P (LInstDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass DataFamInstD NoExtField XDataFamInstD GhcPs noExtField (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs forall pass. FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass DataFamInstDecl (FamEqn GhcPs (HsDataDefn GhcPs) -> FamInstEqn GhcPs (HsDataDefn GhcPs) forall thing. thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs (FamEqn :: forall pass rhs. XCFamEqn pass rhs -> Located (IdP pass) -> Maybe [LHsTyVarBndr () pass] -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs) feqn_ext = NoExtField XCFamEqn GhcPs (HsDataDefn GhcPs) noExtField , feqn_tycon :: Located (IdP GhcPs) feqn_tycon = Located RdrName Located (IdP GhcPs) tc , feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs = Maybe [LHsTyVarBndr () GhcPs] bndrs , feqn_pats :: [LHsTypeArg GhcPs] feqn_pats = [LHsTypeArg GhcPs] tparams , feqn_fixity :: LexicalFixity feqn_fixity = LexicalFixity fixity , feqn_rhs :: HsDataDefn GhcPs feqn_rhs = HsDataDefn GhcPs defn }))))) } mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst SrcSpan loc TyFamInstEqn GhcPs eqn = LInstDecl GhcPs -> P (LInstDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass TyFamInstD NoExtField XTyFamInstD GhcPs noExtField (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs forall pass. TyFamInstEqn pass -> TyFamInstDecl pass TyFamInstDecl TyFamInstEqn GhcPs eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> LHsType GhcPs -- LHS -> Located (FamilyResultSig GhcPs) -- Optional result signature -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation -> P (LTyClDecl GhcPs) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> LHsType GhcPs -> Located (FamilyResultSig GhcPs) -> Maybe (LInjectivityAnn GhcPs) -> P (LTyClDecl GhcPs) mkFamDecl SrcSpan loc FamilyInfo GhcPs info LHsType GhcPs lhs Located (FamilyResultSig GhcPs) ksig Maybe (LInjectivityAnn GhcPs) injAnn = do { (Located RdrName tc, [LHsTypeArg GhcPs] tparams, LexicalFixity fixity, [AddAnn] ann) <- Bool -> LHsType GhcPs -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool False LHsType GhcPs lhs ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] ann -- Add any API Annotations to the top SrcSpan ; (LHsQTyVars GhcPs tyvars, [AddAnn] anns) <- SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs, [AddAnn]) checkTyVars (FamilyInfo GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr FamilyInfo GhcPs info) SDoc equals_or_where Located RdrName tc [LHsTypeArg GhcPs] tparams ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan loc [AddAnn] anns -- Add any API Annotations to the top SrcSpan ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass FamDecl NoExtField XFamDecl GhcPs noExtField (FamilyDecl :: forall pass. XCFamilyDecl pass -> FamilyInfo pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LFamilyResultSig pass -> Maybe (LInjectivityAnn pass) -> FamilyDecl pass FamilyDecl { fdExt :: XCFamilyDecl GhcPs fdExt = NoExtField XCFamilyDecl GhcPs noExtField , fdInfo :: FamilyInfo GhcPs fdInfo = FamilyInfo GhcPs info, fdLName :: Located (IdP GhcPs) fdLName = Located RdrName Located (IdP GhcPs) tc , fdTyVars :: LHsQTyVars GhcPs fdTyVars = LHsQTyVars GhcPs tyvars , fdFixity :: LexicalFixity fdFixity = LexicalFixity fixity , fdResultSig :: Located (FamilyResultSig GhcPs) fdResultSig = Located (FamilyResultSig GhcPs) ksig , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs) fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs) injAnn }))) } where equals_or_where :: SDoc equals_or_where = case FamilyInfo GhcPs info of FamilyInfo GhcPs DataFamily -> SDoc empty FamilyInfo GhcPs OpenTypeFamily -> SDoc empty ClosedTypeFamily {} -> SDoc whereDots mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD -- but if she wrote, say, -- f x then behave as if she'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 -> HsDecl GhcPs mkSpliceDecl lexpr :: LHsExpr GhcPs lexpr@(L SrcSpan loc HsExpr GhcPs expr) | HsSpliceE XSpliceE GhcPs _ splice :: HsSplice GhcPs splice@(HsUntypedSplice {}) <- HsExpr GhcPs expr = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD NoExtField XSpliceD GhcPs noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl NoExtField XSpliceDecl GhcPs noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc HsSplice GhcPs splice) SpliceExplicitFlag ExplicitSplice) | HsSpliceE XSpliceE GhcPs _ splice :: HsSplice GhcPs splice@(HsQuasiQuote {}) <- HsExpr GhcPs expr = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD NoExtField XSpliceD GhcPs noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl NoExtField XSpliceDecl GhcPs noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc HsSplice GhcPs splice) SpliceExplicitFlag ExplicitSplice) | Bool otherwise = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD NoExtField XSpliceD GhcPs noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl NoExtField XSpliceDecl GhcPs noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice SpliceDecoration BareSplice LHsExpr GhcPs lexpr)) SpliceExplicitFlag ImplicitSplice) mkRoleAnnotDecl :: SrcSpan -> Located RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl :: SrcSpan -> Located RdrName -> [Located (Maybe FastString)] -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl SrcSpan loc Located RdrName tycon [Located (Maybe FastString)] roles = do { [GenLocated SrcSpan (Maybe Role)] roles' <- (Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))) -> [Located (Maybe FastString)] -> P [GenLocated SrcSpan (Maybe Role)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role)) parse_role [Located (Maybe FastString)] roles ; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)) -> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs) forall a b. (a -> b) -> a -> b $ SrcSpan -> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs) -> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs forall a b. (a -> b) -> a -> b $ XCRoleAnnotDecl GhcPs -> Located (IdP GhcPs) -> [GenLocated SrcSpan (Maybe Role)] -> RoleAnnotDecl GhcPs forall pass. XCRoleAnnotDecl pass -> Located (IdP pass) -> [GenLocated SrcSpan (Maybe Role)] -> RoleAnnotDecl pass RoleAnnotDecl NoExtField XCRoleAnnotDecl GhcPs noExtField Located RdrName Located (IdP GhcPs) tycon [GenLocated SrcSpan (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 SrcSpan (Maybe Role)) parse_role (L SrcSpan loc_role Maybe FastString Nothing) = GenLocated SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role)) forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role))) -> GenLocated SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role) forall l e. l -> e -> GenLocated l e L 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 SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role)) forall (m :: * -> *) a. Monad m => a -> m a return (GenLocated SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role))) -> GenLocated SrcSpan (Maybe Role) -> P (GenLocated SrcSpan (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role) forall l e. l -> e -> GenLocated l e L SrcSpan loc_role (Maybe Role -> GenLocated SrcSpan (Maybe Role)) -> Maybe Role -> GenLocated SrcSpan (Maybe Role) forall a b. (a -> b) -> a -> b $ Role -> Maybe Role forall a. a -> Maybe a Just Role found_role Maybe Role Nothing -> let nearby :: [Role] nearby = String -> [(String, Role)] -> [Role] forall a. String -> [(String, a)] -> [a] fuzzyLookup (FastString -> String unpackFS FastString role) ((FastString -> String) -> [(FastString, Role)] -> [(String, Role)] forall a c b. (a -> c) -> [(a, b)] -> [(c, b)] mapFst FastString -> String unpackFS [(FastString, Role)] possible_roles) in SrcSpan -> SDoc -> P (GenLocated SrcSpan (Maybe Role)) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc_role (String -> SDoc text String "Illegal role name" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (FastString -> SDoc forall a. Outputable a => a -> SDoc ppr FastString role) SDoc -> SDoc -> SDoc $$ [Role] -> SDoc forall {a}. Outputable a => [a] -> SDoc suggestions [Role] nearby) suggestions :: [a] -> SDoc suggestions [] = SDoc empty suggestions [a r] = String -> SDoc text String "Perhaps you meant" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (a -> SDoc forall a. Outputable a => a -> SDoc ppr a r) -- will this last case ever happen?? suggestions [a] list = SDoc -> Int -> SDoc -> SDoc hang (String -> SDoc text String "Perhaps you meant one of these:") Int 2 ((a -> SDoc) -> [a] -> SDoc forall a. (a -> SDoc) -> [a] -> SDoc pprWithCommas (SDoc -> SDoc quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> SDoc forall a. Outputable a => a -> SDoc ppr) [a] list) -- | 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 = (LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)) -> [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () 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 SrcSpan loc (UserTyVar XUserTyVar GhcPs xtv Specificity flag Located (IdP GhcPs) idp)) -> (Specificity -> SrcSpan -> P () check_spec Specificity flag SrcSpan loc) P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs) -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall a b. (a -> b) -> a -> b $ XUserTyVar GhcPs -> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs forall flag pass. XUserTyVar pass -> flag -> Located (IdP pass) -> HsTyVarBndr flag pass UserTyVar XUserTyVar GhcPs xtv () Located (IdP GhcPs) idp) (L SrcSpan loc (KindedTyVar XKindedTyVar GhcPs xtv Specificity flag Located (IdP GhcPs) idp LHsType GhcPs k)) -> (Specificity -> SrcSpan -> P () check_spec Specificity flag SrcSpan loc) P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs) -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall a b. (a -> b) -> a -> b $ XKindedTyVar GhcPs -> () -> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs forall flag pass. XKindedTyVar pass -> flag -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr flag pass KindedTyVar XKindedTyVar GhcPs xtv () Located (IdP GhcPs) idp LHsType GhcPs k) where check_spec :: Specificity -> SrcSpan -> P () check_spec :: Specificity -> SrcSpan -> P () check_spec Specificity SpecifiedSpec SrcSpan _ = () -> P () forall (m :: * -> *) a. Monad m => a -> m a return () check_spec Specificity InferredSpec SrcSpan loc = SrcSpan -> SDoc -> P () forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (String -> SDoc text String "Inferred type variables are not allowed here") {- ********************************************************************** #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 (LHsDecl GhcPs) -> [LHsDecl GhcPs] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) decls) -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup OrdList (LHsDecl GhcPs) binding = do { (LHsBinds GhcPs mbs, [LSig GhcPs] sigs, [LFamilyDecl GhcPs] fam_ds, [LTyFamInstDecl GhcPs] tfam_insts , [LDataFamInstDecl GhcPs] dfam_insts, [LDocDecl] _) <- OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) cvBindsAndSigs OrdList (LHsDecl GhcPs) binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) HsValBinds GhcPs -> P (HsValBinds GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (HsValBinds GhcPs -> P (HsValBinds GhcPs)) -> HsValBinds GhcPs -> P (HsValBinds GhcPs) forall a b. (a -> b) -> a -> b $ XValBinds GhcPs GhcPs -> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBinds GhcPs forall idL idR. XValBinds idL idR -> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR ValBinds NoExtField XValBinds GhcPs GhcPs noExtField LHsBinds GhcPs mbs [LSig GhcPs] sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -- 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]) cvBindsAndSigs OrdList (LHsDecl GhcPs) fb = do [LHsDecl GhcPs] fb' <- [LHsDecl GhcPs] -> P [LHsDecl GhcPs] forall {f :: * -> *} {p}. (MonadP f, Outputable (SpliceDecl p)) => [GenLocated SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] drop_bad_decls (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) fb) (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) forall (m :: * -> *) a. Monad m => a -> m a return ([LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) partitionBindsAndSigs ([LHsDecl GhcPs] -> [LHsDecl GhcPs] getMonoBindAll [LHsDecl 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 SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] drop_bad_decls [] = [GenLocated SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] forall (m :: * -> *) a. Monad m => a -> m a return [] drop_bad_decls (L SrcSpan l (SpliceD XSpliceD p _ SpliceDecl p d) : [GenLocated SrcSpan (HsDecl p)] ds) = do SrcSpan -> SDoc -> f () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError SrcSpan l (SDoc -> f ()) -> SDoc -> f () forall a b. (a -> b) -> a -> b $ SDoc -> Int -> SDoc -> SDoc hang (String -> SDoc text String "Declaration splices are allowed only" SDoc -> SDoc -> SDoc <+> String -> SDoc text String "at the top level:") Int 2 (SpliceDecl p -> SDoc forall a. Outputable a => a -> SDoc ppr SpliceDecl p d) [GenLocated SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] drop_bad_decls [GenLocated SrcSpan (HsDecl p)] ds drop_bad_decls (GenLocated SrcSpan (HsDecl p) d:[GenLocated SrcSpan (HsDecl p)] ds) = (GenLocated SrcSpan (HsDecl p) dGenLocated SrcSpan (HsDecl p) -> [GenLocated SrcSpan (HsDecl p)] -> [GenLocated SrcSpan (HsDecl p)] forall a. a -> [a] -> [a] :) ([GenLocated SrcSpan (HsDecl p)] -> [GenLocated SrcSpan (HsDecl p)]) -> f [GenLocated SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [GenLocated SrcSpan (HsDecl p)] -> f [GenLocated SrcSpan (HsDecl p)] drop_bad_decls [GenLocated SrcSpan (HsDecl p)] 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 SrcSpan loc1 (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL) fun_id = fun_id1 :: Located (IdP GhcPs) fun_id1@(L SrcSpan _ IdP GhcPs f1) , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR) fun_matches = MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body] mg_alts = (L SrcSpan _ [LMatch GhcPs (LHsExpr GhcPs)] mtchs1) } })) [LHsDecl GhcPs] binds | [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [LMatch GhcPs (LHsExpr GhcPs)] mtchs1 = [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] mtchs1 SrcSpan loc1 [LHsDecl GhcPs] binds [] where go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpan loc ((L SrcSpan loc2 (ValD XValD GhcPs _ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL) fun_id = (L SrcSpan _ IdP GhcPs f2) , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR) fun_matches = MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body] mg_alts = (L SrcSpan _ [LMatch GhcPs (LHsExpr GhcPs)] mtchs2) } }))) : [LHsDecl GhcPs] binds) [LHsDecl GhcPs] _ | RdrName IdP GhcPs f1 RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == RdrName IdP GhcPs f2 = [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go ([LMatch GhcPs (LHsExpr GhcPs)] mtchs2 [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)] forall a. [a] -> [a] -> [a] ++ [LMatch GhcPs (LHsExpr GhcPs)] mtchs) (SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan loc SrcSpan loc2) [LHsDecl GhcPs] binds [] go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpan loc (doc_decl :: LHsDecl GhcPs doc_decl@(L SrcSpan loc2 (DocD {})) : [LHsDecl GhcPs] binds) [LHsDecl GhcPs] doc_decls = let doc_decls' :: [LHsDecl GhcPs] doc_decls' = LHsDecl GhcPs doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] doc_decls in [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] mtchs (SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan loc SrcSpan loc2) [LHsDecl GhcPs] binds [LHsDecl GhcPs] doc_decls' go [LMatch GhcPs (LHsExpr GhcPs)] mtchs SrcSpan loc [LHsDecl GhcPs] binds [LHsDecl GhcPs] doc_decls = ( SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan loc (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind Located RdrName Located (IdP GhcPs) fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)] forall a. [a] -> [a] reverse [LMatch GhcPs (LHsExpr GhcPs)] mtchs)) , ([LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. [a] -> [a] reverse [LHsDecl GhcPs] doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. [a] -> [a] -> [a] ++ [LHsDecl 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 SrcSpan l (ValD XValD GhcPs _ HsBindLR GhcPs GhcPs b) : [LHsDecl GhcPs] ds) = let (L SrcSpan l' HsBindLR GhcPs GhcPs b', [LHsDecl GhcPs] ds') = LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) getMonoBind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsBindLR GhcPs GhcPs b) [LHsDecl GhcPs] ds in SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l' (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs forall p. XValD p -> HsBind p -> HsDecl p ValD NoExtField XValD GhcPs noExtField HsBindLR GhcPs GhcPs b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] -> [LHsDecl GhcPs] getMonoBindAll [LHsDecl GhcPs] ds' getMonoBindAll (LHsDecl GhcPs d : [LHsDecl GhcPs] ds) = LHsDecl GhcPs d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] -> [LHsDecl GhcPs] getMonoBindAll [LHsDecl GhcPs] ds has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = String -> Bool forall a. String -> a panic String "GHC.Parser.PostProcess.has_args" has_args (L SrcSpan _ (Match { m_pats :: forall p body. Match p body -> [LPat p] m_pats = [LPat GhcPs] args }) : [LMatch GhcPs (LHsExpr GhcPs)] _) = Bool -> Bool not ([Located (Pat GhcPs)] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Located (Pat GhcPs)] [LPat 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. To further complicate matters, the interpretation of (!) and (~) is different in constructors and types: (b1) type T = C ! D (b2) data T = C ! D (b3) data T = C ! D => E In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At the same time, in (b2) it is a strictness annotation: 'C' is a data constructor with a single strict argument 'D'. For the programmer, these cases are usually easy to tell apart due to whitespace conventions: (b2) data T = C !D -- no space after the bang hints that -- it is a strictness annotation For the parser, on the other hand, this whitespace does not matter. We cannot tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited lookahead. The solution that accounts for all of these issues is to initially parse data declarations and types as a reversed list of TyEl: data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | ... For example, both occurrences of (C ! D) in the following example are parsed into equal lists of TyEl: data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") , TyElOpr "!" , TyElOpd (HsTyVar "C") ] Note that elements are in reverse order. Also, 'C' is parsed as a type constructor (HsTyVar) even when it is a data constructor. We fix this in `tyConToDataCon`. By the time the list of TyEl is assembled, we have looked ahead enough to decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for data constructors). These functions are where the actual job of parsing is done. -} -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon SrcSpan loc RdrName tc | OccName -> Bool isTcOcc OccName occ Bool -> Bool -> Bool || OccName -> Bool isDataOcc OccName occ , FastString -> Bool isLexCon (OccName -> FastString occNameFS OccName occ) = Located RdrName -> Either (SrcSpan, SDoc) (Located RdrName) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc (RdrName -> NameSpace -> RdrName setRdrNameSpace RdrName tc NameSpace srcDataName)) | Bool otherwise = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName) forall a b. a -> Either a b Left (SrcSpan loc, SDoc msg) where occ :: OccName occ = RdrName -> OccName rdrNameOcc RdrName tc msg :: SDoc msg = String -> SDoc text String "Not a data constructor:" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr RdrName tc) mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (L SrcSpan loc RdrName patsyn_name) (L SrcSpan _ OrdList (LHsDecl GhcPs) decls) = do { [LMatch GhcPs (LHsExpr GhcPs)] matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))) -> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)) fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) decls) ; Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LMatch GhcPs (LHsExpr GhcPs)] matches) (SrcSpan -> P () wrongNumberErr SrcSpan loc) ; MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsExpr GhcPs))) -> MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) forall a b. (a -> b) -> a -> b $ Origin -> [LMatch GhcPs (LHsExpr GhcPs)] -> MatchGroup GhcPs (LHsExpr GhcPs) forall name (body :: * -> *). (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name)) mkMatchGroup Origin FromSource [LMatch GhcPs (LHsExpr GhcPs)] matches } where fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)) fromDecl (L SrcSpan loc decl :: HsDecl GhcPs decl@(ValD XValD GhcPs _ (PatBind XPatBind GhcPs GhcPs _ pat :: LPat GhcPs pat@(L SrcSpan _ (ConPat NoExtField XConPat GhcPs NoExtField ln :: Located (ConLikeP GhcPs) ln@(L SrcSpan _ ConLikeP GhcPs name) HsConPatDetails GhcPs details)) GRHSs GhcPs (LHsExpr GhcPs) rhs ([Tickish Id], [[Tickish Id]]) _))) = do { Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (RdrName ConLikeP GhcPs 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 SrcSpan loc HsDecl GhcPs decl ; Match GhcPs (LHsExpr GhcPs) match <- case HsConPatDetails GhcPs details of PrefixCon [LPat GhcPs] pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))) -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)) forall a b. (a -> b) -> a -> b $ Match :: forall p body. XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = NoExtField XCMatch GhcPs (LHsExpr GhcPs) noExtField , m_ctxt :: HsMatchContext (NoGhcTc GhcPs) m_ctxt = HsMatchContext GhcPs HsMatchContext (NoGhcTc GhcPs) ctxt, m_pats :: [LPat GhcPs] m_pats = [LPat GhcPs] pats , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) rhs } where ctxt :: HsMatchContext GhcPs ctxt = FunRhs :: forall p. LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p FunRhs { mc_fun :: Located (IdP GhcPs) mc_fun = Located (IdP GhcPs) Located (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 (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))) -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)) forall a b. (a -> b) -> a -> b $ Match :: forall p body. XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = NoExtField XCMatch GhcPs (LHsExpr GhcPs) noExtField , m_ctxt :: HsMatchContext (NoGhcTc GhcPs) m_ctxt = HsMatchContext GhcPs HsMatchContext (NoGhcTc GhcPs) ctxt , m_pats :: [LPat GhcPs] m_pats = [LPat GhcPs p1, LPat GhcPs p2] , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) rhs } where ctxt :: HsMatchContext GhcPs ctxt = FunRhs :: forall p. LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p FunRhs { mc_fun :: Located (IdP GhcPs) mc_fun = Located (IdP GhcPs) Located (ConLikeP GhcPs) ln , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity Infix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness NoSrcStrict } RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (LHsExpr GhcPs)) forall a. SrcSpan -> LPat GhcPs -> P a recordPatSynErr SrcSpan loc LPat GhcPs pat ; LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))) -> LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc Match GhcPs (LHsExpr GhcPs) match } fromDecl (L SrcSpan loc HsDecl GhcPs decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)) forall {m :: * -> *} {a} {a}. (MonadP m, Outputable a) => SrcSpan -> a -> m a extraDeclErr SrcSpan loc HsDecl GhcPs decl extraDeclErr :: SrcSpan -> a -> m a extraDeclErr SrcSpan loc a decl = SrcSpan -> SDoc -> m a forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> m a) -> SDoc -> m a forall a b. (a -> b) -> a -> b $ String -> SDoc text String "pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc $$ a -> SDoc forall a. Outputable a => a -> SDoc ppr a decl wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P () wrongNameBindingErr SrcSpan loc HsDecl GhcPs decl = SrcSpan -> SDoc -> P () forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "pattern synonym 'where' clause must bind the pattern synonym's name" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr RdrName patsyn_name) SDoc -> SDoc -> SDoc $$ HsDecl GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr HsDecl GhcPs decl wrongNumberErr :: SrcSpan -> P () wrongNumberErr SrcSpan loc = SrcSpan -> SDoc -> P () forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc $$ String -> SDoc text String "In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc <+> RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr (RdrName patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a recordPatSynErr SrcSpan loc LPat GhcPs pat = SrcSpan -> SDoc -> P a forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> P a) -> SDoc -> P a forall a b. (a -> b) -> a -> b $ String -> SDoc text String "record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc $$ Located (Pat GhcPs) -> SDoc forall a. Outputable a => a -> SDoc ppr Located (Pat GhcPs) LPat GhcPs pat mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) -> ConDecl GhcPs mkConDeclH98 Located RdrName name Maybe [LHsTyVarBndr Specificity GhcPs] mb_forall Maybe (LHsContext GhcPs) mb_cxt HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) args = ConDeclH98 :: forall pass. XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe LHsDocString -> ConDecl pass ConDeclH98 { con_ext :: XConDeclH98 GhcPs con_ext = NoExtField XConDeclH98 GhcPs noExtField , con_name :: Located (IdP GhcPs) con_name = Located RdrName Located (IdP GhcPs) name , con_forall :: Located Bool con_forall = Bool -> Located Bool forall e. e -> Located e noLoc (Bool -> Located Bool) -> Bool -> Located Bool forall a b. (a -> b) -> a -> b $ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool forall a. Maybe a -> Bool isJust Maybe [LHsTyVarBndr Specificity GhcPs] mb_forall , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs] con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs] mb_forall Maybe [LHsTyVarBndr Specificity GhcPs] -> [LHsTyVarBndr Specificity GhcPs] -> [LHsTyVarBndr 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 :: HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) con_args = HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) args , con_doc :: Maybe LHsDocString con_doc = Maybe LHsDocString 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 :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs, [AddAnn]) mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs, [AddAnn]) mkGadtDecl [Located RdrName] names LHsType GhcPs ty = do let (HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) args, LHsType GhcPs res_ty, [AddAnn] anns) | L SrcSpan _ (HsFunTy XFunTy GhcPs _ HsArrow GhcPs _w (L SrcSpan loc (HsRecTy XRecTy GhcPs _ [LConDeclField GhcPs] rf)) LHsType GhcPs res_ty) <- LHsType GhcPs body_ty = (GenLocated SrcSpan [LConDeclField GhcPs] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> [LConDeclField GhcPs] -> GenLocated SrcSpan [LConDeclField GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan loc [LConDeclField GhcPs] rf), LHsType GhcPs res_ty, []) | Bool otherwise = let ([HsScaled GhcPs (LHsType GhcPs)] arg_types, LHsType GhcPs res_type, [AddAnn] anns) = LHsType GhcPs -> ([HsScaled GhcPs (LHsType GhcPs)], LHsType GhcPs, [AddAnn]) forall (p :: Pass). LHsType (GhcPass p) -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn]) splitHsFunType LHsType GhcPs body_ty in ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. [arg] -> HsConDetails arg rec PrefixCon [HsScaled GhcPs (LHsType GhcPs)] arg_types, LHsType GhcPs res_type, [AddAnn] anns) (ConDecl GhcPs, [AddAnn]) -> P (ConDecl GhcPs, [AddAnn]) forall (f :: * -> *) a. Applicative f => a -> f a pure ( ConDeclGADT :: forall pass. XConDeclGADT pass -> [Located (IdP pass)] -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> LHsType pass -> Maybe LHsDocString -> ConDecl pass ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs con_g_ext = NoExtField XConDeclGADT GhcPs noExtField , con_names :: [Located (IdP GhcPs)] con_names = [Located RdrName] [Located (IdP GhcPs)] names , con_forall :: Located Bool con_forall = SrcSpan -> Bool -> Located Bool forall l e. l -> e -> GenLocated l e L (LHsType GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsType GhcPs ty) (Bool -> Located Bool) -> Bool -> Located Bool forall a b. (a -> b) -> a -> b $ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool forall a. Maybe a -> Bool isJust Maybe [LHsTyVarBndr Specificity GhcPs] mtvs , con_qvars :: [LHsTyVarBndr Specificity GhcPs] con_qvars = [LHsTyVarBndr Specificity GhcPs] -> Maybe [LHsTyVarBndr Specificity GhcPs] -> [LHsTyVarBndr Specificity GhcPs] forall a. a -> Maybe a -> a fromMaybe [] Maybe [LHsTyVarBndr Specificity GhcPs] mtvs , con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt = Maybe (LHsContext GhcPs) mcxt , con_args :: HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) con_args = HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) args , con_res_ty :: LHsType GhcPs con_res_ty = LHsType GhcPs res_ty , con_doc :: Maybe LHsDocString con_doc = Maybe LHsDocString forall a. Maybe a Nothing } , [AddAnn] anns ) where (Maybe [LHsTyVarBndr Specificity GhcPs] mtvs, Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs body_ty) = LHsType GhcPs -> (Maybe [LHsTyVarBndr Specificity GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) forall pass. LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass) splitLHsGadtTy LHsType 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 (HasDebugCallStack => Name -> Module Name -> Module nameModule Name n) OccName occ | Bool otherwise -- This can happen when quoting and then -- splicing a fixity declaration for a type = Name -> RdrName Exact (Unique -> OccName -> SrcSpan -> Name mkSystemNameAt (Name -> Unique nameUnique Name n) OccName occ (Name -> SrcSpan nameSrcSpan Name n)) where occ :: OccName occ = NameSpace -> OccName -> OccName setOccNameSpace NameSpace ns (Name -> OccName nameOccName Name n) setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace (ATyCon TyCon tc) NameSpace ns | NameSpace -> Bool isDataConNameSpace NameSpace ns = TyCon -> RdrName ty_con_data_con TyCon tc | NameSpace -> Bool isTcClsNameSpace NameSpace ns = Name -> RdrName Exact (TyCon -> Name forall a. NamedThing a => a -> Name getName TyCon tc) -- No-op setWiredInNameSpace (AConLike (RealDataCon DataCon dc)) NameSpace ns | NameSpace -> Bool isTcClsNameSpace NameSpace ns = DataCon -> RdrName data_con_ty_con DataCon dc | NameSpace -> Bool isDataConNameSpace NameSpace ns = Name -> RdrName Exact (DataCon -> Name forall a. NamedThing a => a -> Name getName DataCon dc) -- No-op setWiredInNameSpace TyThing thing NameSpace ns = String -> SDoc -> RdrName forall a. HasCallStack => String -> SDoc -> a pprPanic String "setWiredinNameSpace" (NameSpace -> SDoc pprNameSpace NameSpace ns SDoc -> SDoc -> SDoc <+> 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)) -- | Replaces constraint tuple names with corresponding boxed ones. filterCTuple :: RdrName -> RdrName filterCTuple :: RdrName -> RdrName filterCTuple (Exact Name n) | Just Int arity <- Name -> Maybe Int cTupleTyConNameArity_maybe Name n = Name -> RdrName Exact (Name -> RdrName) -> Name -> RdrName forall a b. (a -> b) -> a -> b $ TupleSort -> Int -> Name tupleTyConName TupleSort BoxedTuple Int arity filterCTuple RdrName rdr = RdrName rdr {- 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 :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad eitherToP :: forall a. Either (SrcSpan, SDoc) a -> P a eitherToP (Left (SrcSpan loc, SDoc doc)) = SrcSpan -> SDoc -> P a forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc SDoc doc eitherToP (Right a thing) = a -> P a forall (m :: * -> *) a. Monad m => a -> m a return a thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P ( LHsQTyVars GhcPs -- the synthesized type variables , [AddAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs, [AddAnn]) checkTyVars SDoc pp_what SDoc equals_or_where Located RdrName tc [LHsTypeArg GhcPs] tparms = do { ([LHsTyVarBndr () GhcPs] tvs, [[AddAnn]] anns) <- ([(LHsTyVarBndr () GhcPs, [AddAnn])] -> ([LHsTyVarBndr () GhcPs], [[AddAnn]])) -> P [(LHsTyVarBndr () GhcPs, [AddAnn])] -> P ([LHsTyVarBndr () GhcPs], [[AddAnn]]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [(LHsTyVarBndr () GhcPs, [AddAnn])] -> ([LHsTyVarBndr () GhcPs], [[AddAnn]]) forall a b. [(a, b)] -> ([a], [b]) unzip (P [(LHsTyVarBndr () GhcPs, [AddAnn])] -> P ([LHsTyVarBndr () GhcPs], [[AddAnn]])) -> P [(LHsTyVarBndr () GhcPs, [AddAnn])] -> P ([LHsTyVarBndr () GhcPs], [[AddAnn]]) forall a b. (a -> b) -> a -> b $ (LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])) -> [LHsTypeArg GhcPs] -> P [(LHsTyVarBndr () GhcPs, [AddAnn])] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) check [LHsTypeArg GhcPs] tparms ; (LHsQTyVars GhcPs, [AddAnn]) -> P (LHsQTyVars GhcPs, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs mkHsQTvs [LHsTyVarBndr () GhcPs] tvs, [[AddAnn]] -> [AddAnn] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[AddAnn]] anns) } where check :: LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) check (HsTypeArg SrcSpan _ ki :: LHsType GhcPs ki@(L SrcSpan loc HsKind GhcPs _)) = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])) -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]) forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc vcat [ String -> SDoc text String "Unexpected type application" SDoc -> SDoc -> SDoc <+> String -> SDoc text String "@" SDoc -> SDoc -> SDoc <> LHsType GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsType GhcPs ki , String -> SDoc text String "In the" SDoc -> SDoc -> SDoc <+> SDoc pp_what SDoc -> SDoc -> SDoc <+> PtrString -> SDoc ptext (String -> PtrString sLit String "declaration for") SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr Located RdrName tc)] check (HsValArg LHsType GhcPs ty) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) chkParens [] LHsType GhcPs ty check (HsArgPar SrcSpan sp) = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan sp (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])) -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]) forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc vcat [String -> SDoc text String "Malformed" SDoc -> SDoc -> SDoc <+> SDoc pp_what SDoc -> SDoc -> SDoc <+> String -> SDoc text String "declaration for" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr Located RdrName tc)] -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) chkParens [AddAnn] acc (L SrcSpan l (HsParTy XParTy GhcPs _ LHsType GhcPs ty)) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]) chkParens (SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ [AddAnn] acc) LHsType GhcPs ty chkParens [AddAnn] acc LHsType GhcPs ty = do LHsTyVarBndr () GhcPs tv <- LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk LHsType GhcPs ty (LHsTyVarBndr () GhcPs, [AddAnn]) -> P (LHsTyVarBndr () GhcPs, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsTyVarBndr () GhcPs tv, [AddAnn] -> [AddAnn] forall a. [a] -> [a] reverse [AddAnn] acc) -- Check that the name space is correct! chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk (L SrcSpan l (HsKindSig XKindSig GhcPs _ (L SrcSpan lv (HsTyVar XTyVar GhcPs _ PromotionFlag _ (L SrcSpan _ IdP GhcPs tv))) LHsType GhcPs k)) | RdrName -> Bool isRdrTyVar RdrName IdP GhcPs tv = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XKindedTyVar GhcPs -> () -> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs forall flag pass. XKindedTyVar pass -> flag -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr flag pass KindedTyVar NoExtField XKindedTyVar GhcPs noExtField () (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan lv RdrName IdP GhcPs tv) LHsType GhcPs k)) chk (L SrcSpan l (HsTyVar XTyVar GhcPs _ PromotionFlag _ (L SrcSpan ltv IdP GhcPs tv))) | RdrName -> Bool isRdrTyVar RdrName IdP GhcPs tv = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XUserTyVar GhcPs -> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs forall flag pass. XUserTyVar pass -> flag -> Located (IdP pass) -> HsTyVarBndr flag pass UserTyVar NoExtField XUserTyVar GhcPs noExtField () (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan ltv RdrName IdP GhcPs tv))) chk t :: LHsType GhcPs t@(L SrcSpan loc HsKind GhcPs _) = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> P (LHsTyVarBndr () GhcPs)) -> SDoc -> P (LHsTyVarBndr () GhcPs) forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc vcat [ String -> SDoc text String "Unexpected type" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (LHsType GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsType GhcPs t) , String -> SDoc text String "In the" SDoc -> SDoc -> SDoc <+> SDoc pp_what SDoc -> SDoc -> SDoc <+> PtrString -> SDoc ptext (String -> PtrString sLit String "declaration for") SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes SDoc tc' , [SDoc] -> SDoc vcat[ (String -> SDoc text String "A" SDoc -> SDoc -> SDoc <+> SDoc pp_what SDoc -> SDoc -> SDoc <+> PtrString -> SDoc ptext (String -> PtrString sLit String "declaration should have form")) , Int -> SDoc -> SDoc nest Int 2 (SDoc pp_what SDoc -> SDoc -> SDoc <+> SDoc tc' SDoc -> SDoc -> SDoc <+> [SDoc] -> SDoc hsep ((String -> SDoc) -> [String] -> [SDoc] forall a b. (a -> b) -> [a] -> [b] map String -> SDoc text ([LHsTypeArg GhcPs] -> [String] -> [String] forall b a. [b] -> [a] -> [a] takeList [LHsTypeArg GhcPs] tparms [String] allNameStrings)) SDoc -> SDoc -> SDoc <+> SDoc equals_or_where) ] ] -- Avoid printing a constraint tuple in the error message. Print -- a plain old tuple instead (since that's what the user probably -- wrote). See #14907 tc' :: SDoc tc' = Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr (Located RdrName -> SDoc) -> Located RdrName -> SDoc forall a b. (a -> b) -> a -> b $ (RdrName -> RdrName) -> Located RdrName -> Located RdrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RdrName -> RdrName filterCTuple Located RdrName tc whereDots, equalsDots :: SDoc -- Second argument to checkTyVars whereDots :: SDoc whereDots = String -> SDoc text String "where ..." equalsDots :: SDoc equalsDots = String -> SDoc text String "= ..." checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Maybe (LHsContext GhcPs) Nothing = () -> P () forall (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 $ SrcSpan -> SDoc -> P () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError (LHsContext GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsContext GhcPs c) (String -> SDoc text String "Illegal datatype context (use DatatypeContexts):" SDoc -> SDoc -> SDoc <+> LHsContext GhcPs -> SDoc forall (p :: Pass). OutputableBndrId p => LHsContext (GhcPass p) -> SDoc pprLHsContext LHsContext GhcPs c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located 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 -> LRuleBndr GhcPs) -> [LRuleTyTmVar] -> [LRuleBndr GhcPs] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs 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 Located RdrName v Maybe (LHsType GhcPs) Nothing) = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass RuleBndr NoExtField XCRuleBndr GhcPs noExtField Located RdrName Located (IdP GhcPs) v cvt_one (RuleTyTmVar Located RdrName v (Just LHsType GhcPs sig)) = XRuleBndrSig GhcPs -> Located (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs forall pass. XRuleBndrSig pass -> Located (IdP pass) -> HsPatSigType pass -> RuleBndr pass RuleBndrSig NoExtField XRuleBndrSig GhcPs noExtField Located RdrName Located (IdP GhcPs) v (LHsType GhcPs -> HsPatSigType GhcPs mkHsPatSigType LHsType GhcPs sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr () GhcPs) -> [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((RuleTyTmVar -> HsTyVarBndr () GhcPs) -> LRuleTyTmVar -> LHsTyVarBndr () GhcPs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RuleTyTmVar -> HsTyVarBndr () GhcPs cvt_one) where cvt_one :: RuleTyTmVar -> HsTyVarBndr () GhcPs cvt_one (RuleTyTmVar Located RdrName v Maybe (LHsType GhcPs) Nothing) = XUserTyVar GhcPs -> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs forall flag pass. XUserTyVar pass -> flag -> Located (IdP pass) -> HsTyVarBndr flag pass UserTyVar NoExtField XUserTyVar GhcPs noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RdrName -> RdrName tm_to_ty Located RdrName v) cvt_one (RuleTyTmVar Located RdrName v (Just LHsType GhcPs sig)) = XKindedTyVar GhcPs -> () -> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs forall flag pass. XKindedTyVar pass -> flag -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr flag pass KindedTyVar NoExtField XKindedTyVar GhcPs noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RdrName -> RdrName tm_to_ty Located 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. 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 SrcSpan (HsTyVarBndr flag GhcPs) -> P ()) -> [GenLocated SrcSpan (HsTyVarBndr flag GhcPs)] -> P () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Located RdrName -> P () forall {f :: * -> *}. MonadP f => Located RdrName -> f () check (Located RdrName -> P ()) -> (GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName) -> GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> P () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsTyVarBndr flag GhcPs -> RdrName) -> GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HsTyVarBndr flag GhcPs -> RdrName forall flag (p :: Pass). HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) hsTyVarName) where check :: Located RdrName -> f () check (L SrcSpan loc (Unqual OccName occ)) = do Bool -> f () -> f () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when ((OccName -> String occNameString OccName occ String -> String -> Bool forall a. Eq a => a -> a -> Bool ==) (String -> Bool) -> [String] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool `any` [String "forall",String "family",String "role"]) (SrcSpan -> SDoc -> f () forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (String -> SDoc text (String -> SDoc) -> String -> SDoc forall a b. (a -> b) -> a -> b $ String "parse error on input " String -> String -> String forall a. [a] -> [a] -> [a] ++ OccName -> String occNameString OccName occ)) check Located RdrName _ = String -> f () forall a. String -> a panic String "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax :: forall (m :: * -> *) a. (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr :: Located a lr@(L SrcSpan 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 $ SrcSpan -> SDoc -> m () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError SrcSpan loc (SDoc -> m ()) -> SDoc -> m () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Illegal record syntax (use TraditionalRecordSyntax):" SDoc -> SDoc -> SDoc <+> a -> SDoc forall a. Outputable a => a -> SDoc ppr a r Located a -> m (Located a) forall (m :: * -> *) a. Monad m => a -> m a return Located 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 ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs]) gadts@(L SrcSpan span ([AddAnn] _, [])) -- 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 $ SrcSpan -> SDoc -> P () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError SrcSpan span (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc vcat [ String -> SDoc text String "Illegal keyword 'where' in data declaration" , String -> SDoc text String "Perhaps you intended to use GADTs or a similar language" , String -> SDoc text String "extension to enable syntax: data T where" ] Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) forall (m :: * -> *) a. Monad m => a -> m a return Located ([AddAnn], [LConDecl GhcPs]) gadts checkEmptyGADTs Located ([AddAnn], [LConDecl GhcPs]) gadts = Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) forall (m :: * -> *) a. Monad m => a -> m a return Located ([AddAnn], [LConDecl GhcPs]) gadts -- Ordinary GADT declaration. checkTyClHdr :: Bool -- True <=> class header -- False <=> type header -> LHsType GhcPs -> P (Located RdrName, -- the head symbol (type or class name) [LHsTypeArg GhcPs], -- parameters of head symbol LexicalFixity, -- the declaration is in infix format [AddAnn]) -- 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 (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) checkTyClHdr Bool is_cls LHsType GhcPs ty = LHsType GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) goL LHsType GhcPs ty [] [] LexicalFixity Prefix where goL :: LHsType GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) goL (L SrcSpan l HsKind GhcPs ty) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix = SrcSpan -> HsKind GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) go SrcSpan l HsKind GhcPs ty [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix -- workaround to define '*' despite StarIsType go :: SrcSpan -> HsKind GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) go SrcSpan lp (HsParTy XParTy GhcPs _ (L SrcSpan l (HsStarTy XStarTy GhcPs _ Bool isUni))) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix = do { SrcSpan -> P () warnStarBndr SrcSpan l ; let name :: OccName name = NameSpace -> String -> OccName mkOccName NameSpace tcClsName (Bool -> String starSym Bool isUni) ; (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l (OccName -> RdrName Unqual OccName name), [LHsTypeArg GhcPs] acc, LexicalFixity fix, ([AddAnn] ann [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan lp)) } go SrcSpan _ (HsTyVar XTyVar GhcPs _ PromotionFlag _ ltc :: Located (IdP GhcPs) ltc@(L SrcSpan _ IdP GhcPs tc)) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix | RdrName -> Bool isRdrTc RdrName IdP GhcPs tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (Located RdrName Located (IdP GhcPs) ltc, [LHsTypeArg GhcPs] acc, LexicalFixity fix, [AddAnn] ann) go SrcSpan _ (HsOpTy XOpTy GhcPs _ LHsType GhcPs t1 ltc :: Located (IdP GhcPs) ltc@(L SrcSpan _ IdP GhcPs tc) LHsType GhcPs t2) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity _fix | RdrName -> Bool isRdrTc RdrName IdP GhcPs tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (Located RdrName Located (IdP GhcPs) ltc, LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc, LexicalFixity Infix, [AddAnn] ann) go SrcSpan l (HsParTy XParTy GhcPs _ LHsType GhcPs ty) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix = LHsType GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) goL LHsType GhcPs ty [LHsTypeArg GhcPs] acc ([AddAnn] ann [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l) LexicalFixity fix go SrcSpan _ (HsAppTy XAppTy GhcPs _ LHsType GhcPs t1 LHsType GhcPs t2) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix = LHsType GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) goL LHsType GhcPs t1 (LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg LHsType GhcPs t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) [AddAnn] ann LexicalFixity fix go SrcSpan _ (HsAppKindTy XAppKindTy GhcPs l LHsType GhcPs ty LHsType GhcPs ki) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix = LHsType GhcPs -> [LHsTypeArg GhcPs] -> [AddAnn] -> LexicalFixity -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) goL LHsType GhcPs ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. SrcSpan -> ty -> HsArg tm ty HsTypeArg SrcSpan XAppKindTy GhcPs l LHsType GhcPs kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) [AddAnn] ann LexicalFixity fix go SrcSpan l (HsTupleTy XTupleTy GhcPs _ HsTupleSort HsBoxedOrConstraintTuple [LHsType GhcPs] ts) [] [AddAnn] ann LexicalFixity fix = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l (Name -> RdrName nameRdrName Name tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs) -> [LHsType GhcPs] -> [LHsTypeArg GhcPs] forall a b. (a -> b) -> [a] -> [b] map LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg [LHsType GhcPs] ts, LexicalFixity fix, [AddAnn] ann) where arity :: Int arity = [LHsType GhcPs] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [LHsType 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 HsKind GhcPs _ [LHsTypeArg GhcPs] _ [AddAnn] _ LexicalFixity _ = SrcSpan -> SDoc -> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn]) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan l (String -> SDoc text String "Malformed head of type or class declaration:" SDoc -> SDoc -> SDoc <+> LHsType GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsType GhcPs ty) -- | 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 () checkExpBlockArguments, LHsCmd GhcPs -> PV () checkCmdBlockArguments) = (LHsExpr GhcPs -> PV () checkExpr, LHsCmd GhcPs -> PV () checkCmd) where checkExpr :: LHsExpr GhcPs -> PV () checkExpr :: LHsExpr GhcPs -> PV () checkExpr LHsExpr GhcPs expr = do case LHsExpr GhcPs -> HsExpr GhcPs forall l e. GenLocated l e -> e unLoc LHsExpr GhcPs expr of HsDo XDo GhcPs _ (DoExpr Maybe ModuleName m) Located [ExprLStmt GhcPs] _ -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (Maybe ModuleName -> SDoc -> SDoc prependQualified Maybe ModuleName m (String -> SDoc text String "do block")) LHsExpr GhcPs expr HsDo XDo GhcPs _ (MDoExpr Maybe ModuleName m) Located [ExprLStmt GhcPs] _ -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (Maybe ModuleName -> SDoc -> SDoc prependQualified Maybe ModuleName m (String -> SDoc text String "mdo block")) LHsExpr GhcPs expr HsLam {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "lambda expression") LHsExpr GhcPs expr HsCase {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "case expression") LHsExpr GhcPs expr HsLamCase {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "lambda-case expression") LHsExpr GhcPs expr HsLet {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "let expression") LHsExpr GhcPs expr HsIf {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "if expression") LHsExpr GhcPs expr HsProc {} -> SDoc -> LHsExpr GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "proc expression") LHsExpr GhcPs expr HsExpr GhcPs _ -> () -> PV () forall (m :: * -> *) a. Monad m => a -> m a return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd :: LHsCmd GhcPs -> PV () checkCmd LHsCmd GhcPs cmd = case LHsCmd GhcPs -> HsCmd GhcPs forall l e. GenLocated l e -> e unLoc LHsCmd GhcPs cmd of HsCmdLam {} -> SDoc -> LHsCmd GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "lambda command") LHsCmd GhcPs cmd HsCmdCase {} -> SDoc -> LHsCmd GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "case command") LHsCmd GhcPs cmd HsCmdIf {} -> SDoc -> LHsCmd GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "if command") LHsCmd GhcPs cmd HsCmdLet {} -> SDoc -> LHsCmd GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "let command") LHsCmd GhcPs cmd HsCmdDo {} -> SDoc -> LHsCmd GhcPs -> PV () forall a. Outputable a => SDoc -> Located a -> PV () check (String -> SDoc text String "do command") LHsCmd GhcPs cmd HsCmd GhcPs _ -> () -> PV () forall (m :: * -> *) a. Monad m => a -> m a return () check :: Outputable a => SDoc -> Located a -> PV () check :: forall a. Outputable a => SDoc -> Located a -> PV () check SDoc element Located a a = do Bool blockArguments <- ExtBits -> PV Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits BlockArgumentsBit Bool -> PV () -> PV () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool blockArguments (PV () -> PV ()) -> PV () -> PV () forall a b. (a -> b) -> a -> b $ SrcSpan -> SDoc -> PV () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError (Located a -> SrcSpan forall l e. GenLocated l e -> l getLoc Located a a) (SDoc -> PV ()) -> SDoc -> PV () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Unexpected " SDoc -> SDoc -> SDoc <> SDoc element SDoc -> SDoc -> SDoc <> String -> SDoc text String " in function application:" SDoc -> SDoc -> SDoc $$ Int -> SDoc -> SDoc nest Int 4 (Located a -> SDoc forall a. Outputable a => a -> SDoc ppr Located a a) SDoc -> SDoc -> SDoc $$ String -> SDoc text String "You could write it with parentheses" SDoc -> SDoc -> SDoc $$ String -> SDoc text String "Or perhaps you meant to enable BlockArguments?" -- | 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 ([AddAnn],LHsContext GhcPs) checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) checkContext (L SrcSpan l HsKind GhcPs orig_t) = [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) check [] (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs orig_t) where check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) check [AddAnn] anns (L SrcSpan lp (HsTupleTy XTupleTy GhcPs _ HsTupleSort HsBoxedOrConstraintTuple [LHsType GhcPs] ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. = ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([AddAnn] anns [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan lp,SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l [LHsType GhcPs] ts) -- Ditto () check [AddAnn] anns (L SrcSpan lp1 (HsParTy XParTy GhcPs _ LHsType GhcPs ty)) -- to be sure HsParTy doesn't get into the way = [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) check [AddAnn] anns' LHsType GhcPs ty where anns' :: [AddAnn] anns' = if SrcSpan l SrcSpan -> SrcSpan -> Bool forall a. Eq a => a -> a -> Bool == SrcSpan lp1 then [AddAnn] anns else ([AddAnn] anns [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan lp1) -- no need for anns, returning original check [AddAnn] _anns LHsType GhcPs _t = ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([],SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l [SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs orig_t]) checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P () checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P () checkImportDecl Maybe (Located Token) mPre Maybe (Located Token) 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 (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 (Located Token) -> (Located Token -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe (Located Token) mPost ((Located Token -> P ()) -> P ()) -> (Located Token -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \Located Token post -> Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool -> Bool not Bool importQualifiedPostEnabled) (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> P () failOpNotEnabledImportQualifiedPost (Located Token -> SrcSpan forall l e. GenLocated l e -> l getLoc Located Token post) -- Error if 'qualified' occurs in both pre and postpositive -- positions. Maybe (Located Token) -> (Located Token -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe (Located Token) mPost ((Located Token -> P ()) -> P ()) -> (Located Token -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \Located Token post -> Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Maybe (Located Token) -> Bool forall a. Maybe a -> Bool isJust Maybe (Located Token) mPre) (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> P () failOpImportQualifiedTwice (Located Token -> SrcSpan forall l e. GenLocated l e -> l getLoc Located Token post) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. Maybe (Located Token) -> (Located Token -> P ()) -> P () forall {f :: * -> *} {a}. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust Maybe (Located Token) mPre ((Located Token -> P ()) -> P ()) -> (Located Token -> P ()) -> P () forall a b. (a -> b) -> a -> b $ \Located Token pre -> SrcSpan -> P () warnPrepositiveQualifiedModule (Located Token -> SrcSpan forall l e. GenLocated l e -> l getLoc Located Token pre) -- ------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)) forall a. PV a -> P a runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))) -> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))) -> Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)) Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_msg SDoc msg PV (Located (PatBuilder GhcPs)) pp = SDoc -> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)) forall a. SDoc -> PV a -> P a runPV_msg SDoc msg (PV (Located (PatBuilder GhcPs)) pp PV (Located (PatBuilder GhcPs)) -> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)) Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e :: Located (PatBuilder GhcPs) e@(L SrcSpan l PatBuilder GhcPs _) = SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpan l Located (PatBuilder GhcPs) e [] checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpan loc (L SrcSpan l e :: PatBuilder GhcPs e@(PatBuilderVar (L SrcSpan _ RdrName c))) [LPat GhcPs] args | RdrName -> Bool isRdrDataCon RdrName c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (Located (Pat GhcPs) -> PV (Located (Pat GhcPs))) -> (Pat GhcPs -> Located (Pat GhcPs)) -> Pat GhcPs -> PV (Located (Pat GhcPs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . SrcSpan -> Pat GhcPs -> Located (Pat GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc (Pat GhcPs -> PV (Located (Pat GhcPs))) -> Pat GhcPs -> PV (Located (Pat GhcPs)) forall a b. (a -> b) -> a -> b $ ConPat :: forall p. XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p ConPat { pat_con_ext :: XConPat GhcPs pat_con_ext = NoExtField XConPat GhcPs noExtField , pat_con :: Located (ConLikeP GhcPs) pat_con = SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l RdrName c , pat_args :: HsConPatDetails GhcPs pat_args = [Located (Pat GhcPs)] -> HsConDetails (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs))) forall arg rec. [arg] -> HsConDetails arg rec PrefixCon [Located (Pat GhcPs)] [LPat GhcPs] args } | Bool -> Bool not ([Located (Pat GhcPs)] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Located (Pat GhcPs)] [LPat GhcPs] args) Bool -> Bool -> Bool && RdrName -> Bool patIsRec RdrName c = (SDoc -> SDoc) -> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)) forall a. (SDoc -> SDoc) -> PV a -> PV a localPV_msg (\SDoc _ -> String -> SDoc text String "Perhaps you intended to use RecursiveDo") (PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))) -> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> SDoc -> PV (Located (Pat GhcPs)) forall a. SrcSpan -> SDoc -> PV a patFail SrcSpan l (PatBuilder GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr PatBuilder GhcPs e) checkPat SrcSpan loc (L SrcSpan _ (PatBuilderApp Located (PatBuilder GhcPs) f Located (PatBuilder GhcPs) e)) [LPat GhcPs] args = do Located (Pat GhcPs) p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat Located (PatBuilder GhcPs) e SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpan loc Located (PatBuilder GhcPs) f (Located (Pat GhcPs) p Located (Pat GhcPs) -> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)] forall a. a -> [a] -> [a] : [Located (Pat GhcPs)] [LPat GhcPs] args) checkPat SrcSpan loc (L SrcSpan _ PatBuilder GhcPs e) [] = do Pat GhcPs p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat SrcSpan loc PatBuilder GhcPs e Located (Pat GhcPs) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> Pat GhcPs -> Located (Pat GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc Pat GhcPs p) checkPat SrcSpan loc Located (PatBuilder GhcPs) e [LPat GhcPs] _ = SrcSpan -> SDoc -> PV (Located (Pat GhcPs)) forall a. SrcSpan -> SDoc -> PV a patFail SrcSpan loc (Located (PatBuilder GhcPs) -> SDoc forall a. Outputable a => a -> SDoc ppr Located (PatBuilder GhcPs) e) checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat SrcSpan 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 (m :: * -> *) a. Monad m => a -> m a return Pat GhcPs p PatBuilderVar Located RdrName x -> Pat GhcPs -> PV (Pat GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs forall p. XVarPat p -> Located (IdP p) -> Pat p VarPat NoExtField XVarPat GhcPs noExtField Located RdrName Located (IdP GhcPs) 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 (m :: * -> *) a. Monad m => a -> m a return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPat (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan loc HsOverLit GhcPs pos_lit) Maybe (SyntaxExpr GhcPs) forall a. Maybe a Nothing) -- n+k patterns PatBuilderOpApp (L SrcSpan nloc (PatBuilderVar (L SrcSpan _ RdrName n))) (L SrcSpan _ RdrName plus) (L SrcSpan lloc (PatBuilderOverLit lit :: HsOverLit GhcPs lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal ol_val = HsIntegral {}}))) | 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 (m :: * -> *) a. Monad m => a -> m a return (Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs mkNPlusKPat (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan nloc RdrName n) (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan lloc HsOverLit GhcPs lit)) -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp Located (PatBuilder GhcPs) _ Located RdrName op Located (PatBuilder GhcPs) _ | RdrName -> Bool opIsAt (Located RdrName -> RdrName forall l e. GenLocated l e -> e unLoc Located RdrName op) -> do SrcSpan -> SDoc -> PV () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc Located RdrName op) (SDoc -> PV ()) -> SDoc -> PV () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Found a binding for the" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr Located RdrName op) SDoc -> SDoc -> SDoc <+> String -> SDoc text String "operator in a pattern position." SDoc -> SDoc -> SDoc $$ SDoc perhaps_as_pat Pat GhcPs -> PV (Pat GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (XWildPat GhcPs -> Pat GhcPs forall p. XWildPat p -> Pat p WildPat NoExtField XWildPat GhcPs noExtField) PatBuilderOpApp Located (PatBuilder GhcPs) l (L SrcSpan cl RdrName c) Located (PatBuilder GhcPs) r | RdrName -> Bool isRdrDataCon RdrName c -> do Located (Pat GhcPs) l <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat Located (PatBuilder GhcPs) l Located (Pat GhcPs) r <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat Located (PatBuilder GhcPs) r Pat GhcPs -> PV (Pat GhcPs) 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 :: forall p. XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p ConPat { pat_con_ext :: XConPat GhcPs pat_con_ext = NoExtField XConPat GhcPs noExtField , pat_con :: Located (ConLikeP GhcPs) pat_con = SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan cl RdrName c , pat_args :: HsConPatDetails GhcPs pat_args = Located (Pat GhcPs) -> Located (Pat GhcPs) -> HsConDetails (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs))) forall arg rec. arg -> arg -> HsConDetails arg rec InfixCon Located (Pat GhcPs) l Located (Pat GhcPs) r } PatBuilderPar Located (PatBuilder GhcPs) e -> Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat Located (PatBuilder GhcPs) e PV (Located (Pat GhcPs)) -> (Located (Pat GhcPs) -> PV (Pat GhcPs)) -> PV (Pat GhcPs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (Pat GhcPs -> PV (Pat GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (Pat GhcPs -> PV (Pat GhcPs)) -> (Located (Pat GhcPs) -> Pat GhcPs) -> Located (Pat GhcPs) -> PV (Pat GhcPs) forall b c a. (b -> c) -> (a -> b) -> a -> c . (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs forall p. XParPat p -> LPat p -> Pat p ParPat NoExtField XParPat GhcPs noExtField)) PatBuilder GhcPs _ -> SrcSpan -> SDoc -> PV (Pat GhcPs) forall a. SrcSpan -> SDoc -> PV a patFail SrcSpan loc (PatBuilder GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr PatBuilder GhcPs e0) placeHolderPunRhs :: DisambECP b => PV (Located 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 (Located b) placeHolderPunRhs = Located RdrName -> PV (Located b) forall b. DisambECP b => Located RdrName -> PV (Located b) mkHsVarPV (RdrName -> Located RdrName forall e. e -> Located e noLoc 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 (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (L SrcSpan l HsRecField GhcPs (Located (PatBuilder GhcPs)) fld) = do Located (Pat GhcPs) p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat (HsRecField GhcPs (Located (PatBuilder GhcPs)) -> Located (PatBuilder GhcPs) forall id arg. HsRecField' id arg -> arg hsRecFieldArg HsRecField GhcPs (Located (PatBuilder GhcPs)) fld) GenLocated SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))) -> PV (GenLocated SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)) -> GenLocated SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))) forall l e. l -> e -> GenLocated l e L SrcSpan l (HsRecField GhcPs (Located (PatBuilder GhcPs)) fld { hsRecFieldArg :: Located (Pat GhcPs) hsRecFieldArg = Located (Pat GhcPs) p })) patFail :: SrcSpan -> SDoc -> PV a patFail :: forall a. SrcSpan -> SDoc -> PV a patFail SrcSpan loc SDoc e = SrcSpan -> SDoc -> PV a forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan loc (SDoc -> PV a) -> SDoc -> PV a forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Parse error in pattern:" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc forall a. Outputable a => a -> SDoc ppr SDoc e 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") opIsAt :: RdrName -> Bool opIsAt :: RdrName -> Bool opIsAt RdrName e = RdrName e RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == NameSpace -> FastString -> RdrName mkUnqual NameSpace varName (String -> FastString fsLit String "@") --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkValDef :: forall a. Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkValDef Located (PatBuilder GhcPs) lhs (Just LHsType GhcPs sig) Located (a, GRHSs GhcPs (LHsExpr GhcPs)) grhss -- x :: ty = rhs parses as a *pattern* binding = do Located (Pat GhcPs) lhs' <- PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)) forall a. PV a -> P a runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))) -> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> Located (PatBuilder GhcPs) -> LHsType GhcPs -> PV (Located (PatBuilder GhcPs)) forall b. DisambECP b => SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) mkHsTySigPV (Located (PatBuilder GhcPs) -> LHsType GhcPs -> SrcSpan forall a b. Located a -> Located b -> SrcSpan combineLocs Located (PatBuilder GhcPs) lhs LHsType GhcPs sig) Located (PatBuilder GhcPs) lhs LHsType GhcPs sig PV (Located (PatBuilder GhcPs)) -> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)) Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) forall a. LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkPatBind Located (Pat GhcPs) LPat GhcPs lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs)) grhss checkValDef Located (PatBuilder GhcPs) lhs Maybe (LHsType GhcPs) Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs)) g@(L SrcSpan l (a _,GRHSs GhcPs (LHsExpr GhcPs) grhss)) = do { Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) mb_fun <- Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) isFunLhs Located (PatBuilder GhcPs) lhs ; case Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) mb_fun of Just (Located RdrName fun, LexicalFixity is_infix, [Located (PatBuilder GhcPs)] pats, [AddAnn] ann) -> SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkFunBind SrcStrictness NoSrcStrict [AddAnn] ann (Located (PatBuilder GhcPs) -> SrcSpan forall l e. GenLocated l e -> l getLoc Located (PatBuilder GhcPs) lhs) Located RdrName fun LexicalFixity is_infix [Located (PatBuilder GhcPs)] pats (SrcSpan -> GRHSs GhcPs (LHsExpr GhcPs) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) forall l e. l -> e -> GenLocated l e L SrcSpan l GRHSs GhcPs (LHsExpr GhcPs) grhss) Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) Nothing -> do Located (Pat GhcPs) lhs' <- Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern Located (PatBuilder GhcPs) lhs LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) forall a. LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkPatBind Located (Pat GhcPs) LPat GhcPs lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs)) g } checkFunBind :: SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkFunBind :: SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkFunBind SrcStrictness strictness [AddAnn] ann SrcSpan lhs_loc Located RdrName fun LexicalFixity is_infix [Located (PatBuilder GhcPs)] pats (L SrcSpan rhs_span GRHSs GhcPs (LHsExpr GhcPs) grhss) = do [Located (Pat GhcPs)] ps <- SDoc -> PV [Located (Pat GhcPs)] -> P [Located (Pat GhcPs)] forall a. SDoc -> PV a -> P a runPV_msg SDoc param_hint ((Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))) -> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)) Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat [Located (PatBuilder GhcPs)] pats) let match_span :: SrcSpan match_span = SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan lhs_loc SrcSpan rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann ([AddAnn], HsBindLR GhcPs GhcPs) -> P ([AddAnn], HsBindLR GhcPs GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([AddAnn] ann, Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind Located RdrName fun [SrcSpan -> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan match_span (Match :: forall p body. XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = NoExtField XCMatch GhcPs (LHsExpr GhcPs) noExtField , m_ctxt :: HsMatchContext (NoGhcTc GhcPs) m_ctxt = FunRhs :: forall p. LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p FunRhs { mc_fun :: Located (IdP GhcPs) mc_fun = Located RdrName Located (IdP GhcPs) fun , mc_fixity :: LexicalFixity mc_fixity = LexicalFixity is_infix , mc_strictness :: SrcStrictness mc_strictness = SrcStrictness strictness } , m_pats :: [LPat GhcPs] m_pats = [Located (Pat GhcPs)] [LPat GhcPs] ps , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where param_hint :: SDoc param_hint | LexicalFixity Infix <- LexicalFixity is_infix = String -> SDoc text String "In a function binding for the" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (Located RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr Located RdrName fun) SDoc -> SDoc -> SDoc <+> String -> SDoc text String "operator." SDoc -> SDoc -> SDoc $$ if RdrName -> Bool opIsAt (Located RdrName -> RdrName forall l e. GenLocated l e -> e unLoc Located RdrName fun) then SDoc perhaps_as_pat else SDoc empty | Bool otherwise = SDoc empty perhaps_as_pat :: SDoc perhaps_as_pat :: SDoc perhaps_as_pat = String -> SDoc text String "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind Located RdrName fn [LMatch GhcPs (LHsExpr GhcPs)] ms = FunBind :: forall idL idR. XFunBind idL idR -> Located (IdP idL) -> MatchGroup idR (LHsExpr idR) -> [Tickish Id] -> HsBindLR idL idR FunBind { fun_ext :: XFunBind GhcPs GhcPs fun_ext = NoExtField XFunBind GhcPs GhcPs noExtField, fun_id :: Located (IdP GhcPs) fun_id = Located RdrName Located (IdP GhcPs) fn, fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs) fun_matches = Origin -> [LMatch GhcPs (LHsExpr GhcPs)] -> MatchGroup GhcPs (LHsExpr GhcPs) forall name (body :: * -> *). (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name)) mkMatchGroup Origin FromSource [LMatch GhcPs (LHsExpr GhcPs)] ms, fun_tick :: [Tickish Id] fun_tick = [] } -- See Note [FunBind vs PatBind] checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind :: forall a. LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBindLR GhcPs GhcPs) checkPatBind LPat GhcPs lhs (L SrcSpan rhs_span (a _,GRHSs GhcPs (LHsExpr GhcPs) grhss)) | BangPat XBangPat GhcPs _ LPat GhcPs p <- Located (Pat GhcPs) -> Pat GhcPs forall l e. GenLocated l e -> e unLoc Located (Pat GhcPs) LPat GhcPs lhs , VarPat XVarPat GhcPs _ Located (IdP GhcPs) v <- Located (Pat GhcPs) -> Pat GhcPs forall l e. GenLocated l e -> e unLoc Located (Pat GhcPs) LPat GhcPs p = ([AddAnn], HsBindLR GhcPs GhcPs) -> P ([AddAnn], HsBindLR GhcPs GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([], Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs makeFunBind Located RdrName Located (IdP GhcPs) v [SrcSpan -> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) forall l e. l -> e -> GenLocated l e L SrcSpan match_span (Located RdrName -> Match GhcPs (LHsExpr GhcPs) m Located RdrName Located (IdP GhcPs) v)]) where match_span :: SrcSpan match_span = SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (Located (Pat GhcPs) -> SrcSpan forall l e. GenLocated l e -> l getLoc Located (Pat GhcPs) LPat GhcPs lhs) SrcSpan rhs_span m :: Located RdrName -> Match GhcPs (LHsExpr GhcPs) m Located RdrName v = Match :: forall p body. XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = NoExtField XCMatch GhcPs (LHsExpr GhcPs) noExtField , m_ctxt :: HsMatchContext (NoGhcTc GhcPs) m_ctxt = FunRhs :: forall p. LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p FunRhs { mc_fun :: Located (IdP GhcPs) mc_fun = Located RdrName Located (IdP GhcPs) 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 (LHsExpr GhcPs) m_grhss = GRHSs GhcPs (LHsExpr GhcPs) grhss } checkPatBind LPat GhcPs lhs (L SrcSpan _ (a _,GRHSs GhcPs (LHsExpr GhcPs) grhss)) = ([AddAnn], HsBindLR GhcPs GhcPs) -> P ([AddAnn], HsBindLR GhcPs GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([],XPatBind GhcPs GhcPs -> LPat GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) -> ([Tickish Id], [[Tickish Id]]) -> HsBindLR GhcPs GhcPs forall idL idR. XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> ([Tickish Id], [[Tickish Id]]) -> HsBindLR idL idR PatBind NoExtField XPatBind GhcPs GhcPs noExtField LPat GhcPs lhs GRHSs GhcPs (LHsExpr GhcPs) grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (L SrcSpan _ (HsVar XVar GhcPs _ lrdr :: Located (IdP GhcPs) lrdr@(L SrcSpan _ IdP GhcPs v))) | RdrName -> Bool isUnqual RdrName IdP GhcPs v , Bool -> Bool not (OccName -> Bool isDataOcc (RdrName -> OccName rdrNameOcc RdrName IdP GhcPs v)) = Located RdrName -> P (Located RdrName) forall (m :: * -> *) a. Monad m => a -> m a return Located RdrName Located (IdP GhcPs) lrdr checkValSigLhs lhs :: LHsExpr GhcPs lhs@(L SrcSpan l HsExpr GhcPs _) = SrcSpan -> SDoc -> P (Located RdrName) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan l ((String -> SDoc text String "Invalid type signature:" SDoc -> SDoc -> SDoc <+> LHsExpr GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsExpr GhcPs lhs SDoc -> SDoc -> SDoc <+> String -> SDoc text String ":: ...") SDoc -> SDoc -> SDoc $$ String -> SDoc text String hint) where hint :: String hint | RdrName IdP GhcPs foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool `looks_like` LHsExpr GhcPs lhs = String "Perhaps you meant to use ForeignFunctionInterface?" | RdrName IdP GhcPs default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool `looks_like` LHsExpr GhcPs lhs = String "Perhaps you meant to use DefaultSignatures?" | RdrName IdP GhcPs pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool `looks_like` LHsExpr GhcPs lhs = String "Perhaps you meant to use PatternSynonyms?" | Bool otherwise = String "Should be of form <variable> :: <type>" -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword looks_like :: IdP p -> LHsExpr p -> Bool looks_like IdP p s (L SrcSpan _ (HsVar XVar p _ (L SrcSpan _ IdP p v))) = IdP p v IdP p -> IdP p -> Bool forall a. Eq a => a -> a -> Bool == IdP p s looks_like IdP p s (L SrcSpan _ (HsApp XApp p _ LHsExpr p lhs LHsExpr p _)) = IdP p -> LHsExpr p -> Bool looks_like IdP p s LHsExpr p lhs looks_like IdP p _ LHsExpr p _ = Bool False foreign_RDR :: RdrName foreign_RDR = NameSpace -> FastString -> RdrName mkUnqual NameSpace varName (String -> FastString fsLit String "foreign") default_RDR :: RdrName default_RDR = NameSpace -> FastString -> RdrName mkUnqual NameSpace varName (String -> FastString fsLit String "default") pattern_RDR :: RdrName pattern_RDR = NameSpace -> FastString -> RdrName mkUnqual NameSpace varName (String -> FastString fsLit String "pattern") checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) => Located a -> Bool -> b -> Bool -> Located c -> PV () checkDoAndIfThenElse :: forall a b c. (Outputable a, Outputable b, Outputable c) => Located a -> Bool -> b -> Bool -> Located c -> PV () checkDoAndIfThenElse Located a guardExpr Bool semiThen b thenExpr Bool semiElse Located 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 Bool -> PV () -> PV () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool doAndIfThenElse (PV () -> PV ()) -> PV () -> PV () forall a b. (a -> b) -> a -> b $ do SrcSpan -> SDoc -> PV () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError (Located a -> Located c -> SrcSpan forall a b. Located a -> Located b -> SrcSpan combineLocs Located a guardExpr Located c elseExpr) (String -> SDoc text String "Unexpected semi-colons in conditional:" SDoc -> SDoc -> SDoc $$ Int -> SDoc -> SDoc nest Int 4 SDoc expr SDoc -> SDoc -> SDoc $$ String -> SDoc text String "Perhaps you meant to use DoAndIfThenElse?") | Bool otherwise = () -> PV () forall (m :: * -> *) a. Monad m => a -> m a return () where pprOptSemi :: Bool -> SDoc pprOptSemi Bool True = SDoc semi pprOptSemi Bool False = SDoc empty expr :: SDoc expr = String -> SDoc text String "if" SDoc -> SDoc -> SDoc <+> Located a -> SDoc forall a. Outputable a => a -> SDoc ppr Located a guardExpr SDoc -> SDoc -> SDoc <> Bool -> SDoc pprOptSemi Bool semiThen SDoc -> SDoc -> SDoc <+> String -> SDoc text String "then" SDoc -> SDoc -> SDoc <+> b -> SDoc forall a. Outputable a => a -> SDoc ppr b thenExpr SDoc -> SDoc -> SDoc <> Bool -> SDoc pprOptSemi Bool semiElse SDoc -> SDoc -> SDoc <+> String -> SDoc text String "else" SDoc -> SDoc -> SDoc <+> Located c -> SDoc forall a. Outputable a => a -> SDoc ppr Located c elseExpr isFunLhs :: Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS isFunLhs :: Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) isFunLhs Located (PatBuilder GhcPs) e = Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall {m :: * -> *} {p}. Monad m => Located (PatBuilder p) -> [Located (PatBuilder p)] -> [AddAnn] -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) go Located (PatBuilder GhcPs) e [] [] where go :: Located (PatBuilder p) -> [Located (PatBuilder p)] -> [AddAnn] -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) go (L SrcSpan loc (PatBuilderVar (L SrcSpan _ RdrName f))) [Located (PatBuilder p)] es [AddAnn] ann | Bool -> Bool not (RdrName -> Bool isRdrDataCon RdrName f) = Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc RdrName f, LexicalFixity Prefix, [Located (PatBuilder p)] es, [AddAnn] ann)) go (L SrcSpan _ (PatBuilderApp Located (PatBuilder p) f Located (PatBuilder p) e)) [Located (PatBuilder p)] es [AddAnn] ann = Located (PatBuilder p) -> [Located (PatBuilder p)] -> [AddAnn] -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) go Located (PatBuilder p) f (Located (PatBuilder p) eLocated (PatBuilder p) -> [Located (PatBuilder p)] -> [Located (PatBuilder p)] forall a. a -> [a] -> [a] :[Located (PatBuilder p)] es) [AddAnn] ann go (L SrcSpan l (PatBuilderPar Located (PatBuilder p) e)) es :: [Located (PatBuilder p)] es@(Located (PatBuilder p) _:[Located (PatBuilder p)] _) [AddAnn] ann = Located (PatBuilder p) -> [Located (PatBuilder p)] -> [AddAnn] -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) go Located (PatBuilder p) e [Located (PatBuilder p)] es ([AddAnn] ann [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l) go (L SrcSpan loc (PatBuilderOpApp Located (PatBuilder p) l (L SrcSpan loc' RdrName op) Located (PatBuilder p) r)) [Located (PatBuilder p)] es [AddAnn] ann | Bool -> Bool not (RdrName -> Bool isRdrDataCon RdrName op) -- We have found the function! = Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc' RdrName op, LexicalFixity Infix, (Located (PatBuilder p) lLocated (PatBuilder p) -> [Located (PatBuilder p)] -> [Located (PatBuilder p)] forall a. a -> [a] -> [a] :Located (PatBuilder p) rLocated (PatBuilder p) -> [Located (PatBuilder p)] -> [Located (PatBuilder p)] forall a. a -> [a] -> [a] :[Located (PatBuilder p)] es), [AddAnn] ann)) | Bool otherwise -- Infix data con; keep going = do { Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) mb_l <- Located (PatBuilder p) -> [Located (PatBuilder p)] -> [AddAnn] -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) go Located (PatBuilder p) l [Located (PatBuilder p)] es [AddAnn] ann ; case Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) mb_l of Just (Located RdrName op', LexicalFixity Infix, Located (PatBuilder p) j : Located (PatBuilder p) k : [Located (PatBuilder p)] es', [AddAnn] ann') -> Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) forall a. a -> Maybe a Just (Located RdrName op', LexicalFixity Infix, Located (PatBuilder p) j Located (PatBuilder p) -> [Located (PatBuilder p)] -> [Located (PatBuilder p)] forall a. a -> [a] -> [a] : Located (PatBuilder p) op_app Located (PatBuilder p) -> [Located (PatBuilder p)] -> [Located (PatBuilder p)] forall a. a -> [a] -> [a] : [Located (PatBuilder p)] es', [AddAnn] ann')) where op_app :: Located (PatBuilder p) op_app = SrcSpan -> PatBuilder p -> Located (PatBuilder p) forall l e. l -> e -> GenLocated l e L SrcSpan loc (Located (PatBuilder p) -> Located RdrName -> Located (PatBuilder p) -> PatBuilder p forall p. Located (PatBuilder p) -> Located RdrName -> Located (PatBuilder p) -> PatBuilder p PatBuilderOpApp Located (PatBuilder p) k (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc' RdrName op) Located (PatBuilder p) r) Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) _ -> Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) forall a. Maybe a Nothing } go Located (PatBuilder p) _ [Located (PatBuilder p)] _ [AddAnn] _ = Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) -> m (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder p)], [AddAnn]) forall a. Maybe a Nothing -- | Either an operator or an operand. data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | TyElKindApp SrcSpan (LHsType GhcPs) -- See Note [TyElKindApp SrcSpan interpretation] | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) {- Note [TyElKindApp SrcSpan interpretation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A TyElKindApp captures type application written in haskell as @ Foo where Foo is some type. The SrcSpan reflects both elements, and there are AnnAt and AnnVal API Annotations attached to this SrcSpan for the specific locations of each within it. -} instance Outputable TyEl where ppr :: TyEl -> SDoc ppr (TyElOpr RdrName name) = RdrName -> SDoc forall a. Outputable a => a -> SDoc ppr RdrName name ppr (TyElOpd HsKind GhcPs ty) = HsKind GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr HsKind GhcPs ty ppr (TyElKindApp SrcSpan _ LHsType GhcPs ki) = String -> SDoc text String "@" SDoc -> SDoc -> SDoc <> LHsType GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsType GhcPs ki ppr (TyElUnpackedness ([AddAnn] _, SourceText _, SrcUnpackedness unpk)) = SrcUnpackedness -> SDoc forall a. Outputable a => a -> SDoc ppr SrcUnpackedness unpk -- | Extract a strictness/unpackedness annotation from the front of a reversed -- 'TyEl' list. pUnpackedness :: [Located TyEl] -- reversed TyEl -> Maybe ( SrcSpan , [AddAnn] , SourceText , SrcUnpackedness , [Located TyEl] {- remaining TyEl -}) pUnpackedness :: [Located TyEl] -> Maybe (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) pUnpackedness (L SrcSpan l TyEl x1 : [Located TyEl] xs) | TyElUnpackedness ([AddAnn] anns, SourceText prag, SrcUnpackedness unpk) <- TyEl x1 = (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) -> Maybe (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) forall a. a -> Maybe a Just (SrcSpan l, [AddAnn] anns, SourceText prag, SrcUnpackedness unpk, [Located TyEl] xs) pUnpackedness [Located TyEl] _ = Maybe (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) forall a. Maybe a Nothing pBangTy :: LHsType GhcPs -- a type to be wrapped inside HsBangTy -> [Located TyEl] -- reversed TyEl -> ( Bool {- has a strict mark been consumed? -} , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) pBangTy :: LHsType GhcPs -> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl]) pBangTy lt :: LHsType GhcPs lt@(L SrcSpan l1 HsKind GhcPs _) [Located TyEl] xs = case [Located TyEl] -> Maybe (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) pUnpackedness [Located TyEl] xs of Maybe (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl]) Nothing -> (Bool False, LHsType GhcPs lt, () -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure (), [Located TyEl] xs) Just (SrcSpan l2, [AddAnn] anns, SourceText prag, SrcUnpackedness unpk, [Located TyEl] xs') -> let bl :: SrcSpan bl = SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan l1 SrcSpan l2 ([AddAnn] anns2, HsKind GhcPs bt) = (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsKind GhcPs) addUnpackedness (SourceText prag, SrcUnpackedness unpk) LHsType GhcPs lt in (Bool True, SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan bl HsKind GhcPs bt, SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan bl ([AddAnn] anns [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ [AddAnn] anns2), [Located TyEl] xs') mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsKind GhcPs mkBangTy SrcStrictness strictness = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs forall pass. XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass HsBangTy NoExtField XBangTy GhcPs noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText NoSourceText SrcUnpackedness NoSrcUnpack SrcStrictness strictness) addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs) addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsKind GhcPs) addUnpackedness (SourceText prag, SrcUnpackedness unpk) (L SrcSpan l (HsBangTy XBangTy GhcPs x HsSrcBang bang LHsType GhcPs t)) | HsSrcBang SourceText NoSourceText SrcUnpackedness NoSrcUnpack SrcStrictness strictness <- HsSrcBang bang = let anns :: [AddAnn] anns = case SrcStrictness strictness of SrcStrictness SrcLazy -> [AnnKeywordId -> SrcSpan -> AddAnn AddAnn AnnKeywordId AnnTilde (SrcSpan -> SrcSpan srcSpanFirstCharacter SrcSpan l)] SrcStrictness SrcStrict -> [AnnKeywordId -> SrcSpan -> AddAnn AddAnn AnnKeywordId AnnBang (SrcSpan -> SrcSpan srcSpanFirstCharacter SrcSpan l)] SrcStrictness NoSrcStrict -> [] in ([AddAnn] anns, XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs forall pass. XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass HsBangTy XBangTy GhcPs x (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText prag SrcUnpackedness unpk SrcStrictness strictness) LHsType GhcPs t) addUnpackedness (SourceText prag, SrcUnpackedness unpk) LHsType GhcPs t = ([], XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs forall pass. XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass HsBangTy NoExtField XBangTy GhcPs noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText prag SrcUnpackedness unpk SrcStrictness NoSrcStrict) LHsType GhcPs t) -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a type. -- -- User input: @F x y + G a b * X@ -- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] -- Output corresponds to what the user wrote assuming all operators are of the -- same fixity and right-associative. -- -- It's a bit silly that we're doing it at all, as the renamer will have to -- rearrange this, and it'd be easier to keep things separate. -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) mergeOps :: [Located TyEl] -> P (LHsType GhcPs) mergeOps ((L SrcSpan l1 (TyElOpd HsKind GhcPs t)) : [Located TyEl] xs) | (Bool _, LHsType GhcPs t', P () addAnns, [Located TyEl] xs') <- LHsType GhcPs -> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl]) pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l1 HsKind GhcPs t) [Located TyEl] xs , [Located TyEl] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Located TyEl] xs' -- We accept a BangTy only when there are no preceding TyEl. = P () addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> LHsType GhcPs -> P (LHsType GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return LHsType GhcPs t' mergeOps [Located TyEl] all_xs = Int -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) forall {t}. (Eq t, Num t) => t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) go (Int 0 :: Int) [] LHsType GhcPs -> LHsType GhcPs forall a. a -> a id [Located TyEl] all_xs where -- NB. When modifying clauses in 'go', make sure that the reasoning in -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. -- clause [unpk]: -- handle (NO)UNPACK pragmas go :: t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((L SrcSpan l (TyElUnpackedness ([AddAnn] anns, SourceText unpkSrc, SrcUnpackedness unpk))):[Located TyEl] xs) = if Bool -> Bool not ([LHsTypeArg GhcPs] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsTypeArg GhcPs] acc) Bool -> Bool -> Bool && [Located TyEl] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Located TyEl] xs then do { LHsType GhcPs acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs) forall a. Either (SrcSpan, SDoc) a -> P a eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)) -> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs) forall a b. (a -> b) -> a -> b $ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [LHsTypeArg GhcPs] acc ; let a :: LHsType GhcPs a = LHsType GhcPs -> LHsType GhcPs ops_acc LHsType GhcPs acc' strictMark :: HsSrcBang strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText unpkSrc SrcUnpackedness unpk SrcStrictness NoSrcStrict bl :: SrcSpan bl = SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan l (LHsType GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsType GhcPs a) bt :: HsKind GhcPs bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs forall pass. XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass HsBangTy NoExtField XBangTy GhcPs noExtField HsSrcBang strictMark LHsType GhcPs a ; SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan bl [AddAnn] anns ; LHsType GhcPs -> P (LHsType GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan bl HsKind GhcPs bt) } else SrcSpan -> SDoc -> P (LHsType GhcPs) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan l SDoc unpkError where unpkSDoc :: SDoc unpkSDoc = case SourceText unpkSrc of SourceText NoSourceText -> SrcUnpackedness -> SDoc forall a. Outputable a => a -> SDoc ppr SrcUnpackedness unpk SourceText String str -> String -> SDoc text String str SDoc -> SDoc -> SDoc <> String -> SDoc text String " #-}" unpkError :: SDoc unpkError | Bool -> Bool not ([Located TyEl] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Located TyEl] xs) = SDoc unpkSDoc SDoc -> SDoc -> SDoc <+> String -> SDoc text String "cannot appear inside a type." | [LHsTypeArg GhcPs] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsTypeArg GhcPs] acc Bool -> Bool -> Bool && t k t -> t -> Bool forall a. Eq a => a -> a -> Bool == t 0 = SDoc unpkSDoc SDoc -> SDoc -> SDoc <+> String -> SDoc text String "must be applied to a type." | Bool otherwise = -- See Note [Impossible case in mergeOps clause [unpk]] String -> SDoc forall a. String -> a panic String "mergeOps.UNPACK: impossible position" -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left -- to build its lhs. go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((L SrcSpan l (TyElOpr RdrName op)):[Located TyEl] xs) = if [LHsTypeArg GhcPs] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsTypeArg GhcPs] acc Bool -> Bool -> Bool || [Located TyEl] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null ((Located TyEl -> Bool) -> [Located TyEl] -> [Located TyEl] forall a. (a -> Bool) -> [a] -> [a] filter Located TyEl -> Bool forall {l}. GenLocated l TyEl -> Bool isTyElOpd [Located TyEl] xs) then Located RdrName -> P (LHsType GhcPs) forall a. Located RdrName -> P a failOpFewArgs (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l RdrName op) else do { LHsType GhcPs acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs) forall a. Either (SrcSpan, SDoc) a -> P a eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [LHsTypeArg GhcPs] acc) ; t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) go (t k t -> t -> t forall a. Num a => a -> a -> a + t 1) [] (\LHsType GhcPs c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy LHsType GhcPs c (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l RdrName op) (LHsType GhcPs -> LHsType GhcPs ops_acc LHsType GhcPs acc')) [Located TyEl] xs } where isTyElOpd :: GenLocated l TyEl -> Bool isTyElOpd (L l _ (TyElOpd HsKind GhcPs _)) = Bool True isTyElOpd GenLocated l TyEl _ = Bool False -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((L SrcSpan l (TyElOpd HsKind GhcPs a)):[Located TyEl] xs) = t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) go t k (LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) LHsType GhcPs -> LHsType GhcPs ops_acc [Located TyEl] xs -- clause [tyapp]: -- whenever a type application is encountered, it is added to the accumulator go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((L SrcSpan _ (TyElKindApp SrcSpan l LHsType GhcPs a)):[Located TyEl] xs) = t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [Located TyEl] -> P (LHsType GhcPs) go t k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. SrcSpan -> ty -> HsArg tm ty HsTypeArg SrcSpan l LHsType GhcPs aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) LHsType GhcPs -> LHsType GhcPs ops_acc [Located TyEl] xs -- clause [end] -- See Note [Non-empty 'acc' in mergeOps clause [end]] go t _ [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc [] = do { LHsType GhcPs acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs) forall a. Either (SrcSpan, SDoc) a -> P a eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [LHsTypeArg GhcPs] acc) ; LHsType GhcPs -> P (LHsType GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (LHsType GhcPs -> LHsType GhcPs ops_acc LHsType GhcPs acc') } mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [] = String -> Either (SrcSpan, SDoc) (LHsType GhcPs) forall a. String -> a panic String "mergeOpsAcc: empty input" mergeOpsAcc (HsTypeArg SrcSpan _ (L SrcSpan loc HsKind GhcPs ki):[LHsTypeArg GhcPs] _) = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs) forall a b. a -> Either a b Left (SrcSpan loc, String -> SDoc text String "Unexpected type application:" SDoc -> SDoc -> SDoc <+> HsKind GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr HsKind GhcPs ki) mergeOpsAcc (HsValArg LHsType GhcPs ty : [LHsTypeArg GhcPs] xs) = LHsType GhcPs -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 LHsType GhcPs ty [LHsTypeArg GhcPs] xs where go1 :: LHsType GhcPs -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 :: LHsType GhcPs -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 LHsType GhcPs lhs [] = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs) forall a b. b -> Either a b Right LHsType GhcPs lhs go1 LHsType GhcPs lhs (LHsTypeArg GhcPs x:[LHsTypeArg GhcPs] xs) = case LHsTypeArg GhcPs x of HsValArg LHsType GhcPs ty -> LHsType GhcPs -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy LHsType GhcPs lhs LHsType GhcPs ty) [LHsTypeArg GhcPs] xs HsTypeArg SrcSpan loc LHsType GhcPs ki -> let ty :: LHsType GhcPs ty = XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs forall (p :: Pass). XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppKindTy SrcSpan XAppKindTy GhcPs loc LHsType GhcPs lhs LHsType GhcPs ki in LHsType GhcPs -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 LHsType GhcPs ty [LHsTypeArg GhcPs] xs HsArgPar SrcSpan _ -> LHsType GhcPs -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 LHsType GhcPs lhs [LHsTypeArg GhcPs] xs mergeOpsAcc (HsArgPar SrcSpan _: [LHsTypeArg GhcPs] xs) = [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [LHsTypeArg GhcPs] xs {- Note [Impossible case in mergeOps clause [unpk]] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This case should never occur. Let us consider all possible variations of 'acc', 'xs', and 'k': acc xs k ============================== null | null 0 -- "must be applied to a type" null | not null 0 -- "must be applied to a type" not null | null 0 -- successful parse not null | not null 0 -- "cannot appear inside a type" null | null >0 -- handled in clause [opr] null | not null >0 -- "cannot appear inside a type" not null | null >0 -- successful parse not null | not null >0 -- "cannot appear inside a type" The (null acc && null xs && k>0) case is handled in clause [opr] by the following check: if ... || null (filter isTyElOpd xs) then failOpFewArgs (L l op) We know that this check has been performed because k>0, and by the time we reach the end of the list (null xs), the only way for (null acc) to hold is that there was not a single TyElOpd between the operator and the end of the list. But this case is caught by the check and reported as 'failOpFewArgs'. -} {- Note [Non-empty 'acc' in mergeOps clause [end]] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' without a check. Running 'mergeOps' with an empty input list is forbidden, so we do not consider this possibility. This means we'll hit at least one other clause before we reach clause [end]. * Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit clause [end] from there. * Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' will be non-empty. * Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going to hit clause [opd] at least once before we reach clause [end], making 'acc' non-empty. * There are no other clauses. Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause [end]. -} pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) pInfixSide ((L SrcSpan l (TyElOpd HsKind GhcPs t)):[Located TyEl] xs) | (Bool True, LHsType GhcPs t', P () addAnns, [Located TyEl] xs') <- LHsType GhcPs -> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl]) pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs t) [Located TyEl] xs = (LHsType GhcPs, P (), [Located TyEl]) -> Maybe (LHsType GhcPs, P (), [Located TyEl]) forall a. a -> Maybe a Just (LHsType GhcPs t', P () addAnns, [Located TyEl] xs') pInfixSide (Located TyEl el:[Located TyEl] xs1) | Just LHsTypeArg GhcPs t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs) pLHsTypeArg Located TyEl el = [LHsTypeArg GhcPs] -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) go [LHsTypeArg GhcPs t1] [Located TyEl] xs1 where go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) go :: [LHsTypeArg GhcPs] -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) go [LHsTypeArg GhcPs] acc (Located TyEl el:[Located TyEl] xs) | Just LHsTypeArg GhcPs t <- Located TyEl -> Maybe (LHsTypeArg GhcPs) pLHsTypeArg Located TyEl el = [LHsTypeArg GhcPs] -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) go (LHsTypeArg GhcPs tLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) [Located TyEl] xs go [LHsTypeArg GhcPs] acc [Located TyEl] xs = case [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [LHsTypeArg GhcPs] acc of Left (SrcSpan, SDoc) _ -> Maybe (LHsType GhcPs, P (), [Located TyEl]) forall a. Maybe a Nothing Right LHsType GhcPs acc' -> (LHsType GhcPs, P (), [Located TyEl]) -> Maybe (LHsType GhcPs, P (), [Located TyEl]) forall a. a -> Maybe a Just (LHsType GhcPs acc', () -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure (), [Located TyEl] xs) pInfixSide [Located TyEl] _ = Maybe (LHsType GhcPs, P (), [Located TyEl]) forall a. Maybe a Nothing pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) pLHsTypeArg :: Located TyEl -> Maybe (LHsTypeArg GhcPs) pLHsTypeArg (L SrcSpan l (TyElOpd HsKind GhcPs a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs) forall a. a -> Maybe a Just (LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs a)) pLHsTypeArg (L SrcSpan _ (TyElKindApp SrcSpan l LHsType GhcPs a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs) forall a. a -> Maybe a Just (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. SrcSpan -> ty -> HsArg tm ty HsTypeArg SrcSpan l LHsType GhcPs a) pLHsTypeArg Located TyEl _ = Maybe (LHsTypeArg GhcPs) forall a. Maybe a Nothing orErr :: Maybe a -> b -> Either b a orErr :: forall a b. Maybe a -> b -> Either b a orErr (Just a a) b _ = a -> Either b a forall a b. b -> Either a b Right a a orErr Maybe a Nothing b b = b -> Either b a forall a b. a -> Either a b Left b b -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a data constructor. -- -- User input: @C !A B -- ^ doc@ -- Input to 'mergeDataCon': ["doc", B, !A, C] -- Output: (C, PrefixCon [!A, B], "doc") -- -- See Note [Parsing data constructors is hard] mergeDataCon :: [Located TyEl] -> P ( Located RdrName -- constructor name , HsConDeclDetails GhcPs -- constructor field information ) mergeDataCon :: [Located TyEl] -> P (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs])) mergeDataCon [Located TyEl] all_xs = do { (P () addAnns, (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs])) a) <- Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> P (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall a. Either (SrcSpan, SDoc) a -> P a eitherToP Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) res ; P () addAnns ; (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs])) -> P (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs])) forall (m :: * -> *) a. Monad m => a -> m a return (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs])) a } where -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. res :: Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) res = [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) goFirst [Located TyEl] all_xs goFirst :: [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) goFirst [ L SrcSpan l (TyElOpd (HsTyVar XTyVar GhcPs _ PromotionFlag _ (L SrcSpan _ IdP GhcPs tc))) ] = do { Located RdrName data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon SrcSpan l RdrName IdP GhcPs tc ; (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall (m :: * -> *) a. Monad m => a -> m a return (() -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure (), (Located RdrName data_con, [HsScaled GhcPs (LHsType GhcPs)] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. [arg] -> HsConDetails arg rec PrefixCon [])) } goFirst ((L SrcSpan l (TyElOpd (HsRecTy XRecTy GhcPs _ [LConDeclField GhcPs] fields))):[Located TyEl] xs) | [ L SrcSpan l' (TyElOpd (HsTyVar XTyVar GhcPs _ PromotionFlag _ (L SrcSpan _ IdP GhcPs tc))) ] <- [Located TyEl] xs = do { Located RdrName data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon SrcSpan l' RdrName IdP GhcPs tc ; (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall (m :: * -> *) a. Monad m => a -> m a return (() -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure (), (Located RdrName data_con, GenLocated SrcSpan [LConDeclField GhcPs] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> [LConDeclField GhcPs] -> GenLocated SrcSpan [LConDeclField GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan l [LConDeclField GhcPs] fields))) } goFirst [L SrcSpan l (TyElOpd (HsTupleTy XTupleTy GhcPs _ HsTupleSort HsBoxedOrConstraintTuple [LHsType GhcPs] ts))] = (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall (m :: * -> *) a. Monad m => a -> m a return ( () -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure () , ( SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan l (DataCon -> RdrName forall thing. NamedThing thing => thing -> RdrName getRdrName (Boxity -> Int -> DataCon tupleDataCon Boxity Boxed ([LHsType GhcPs] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [LHsType GhcPs] ts))) , [HsScaled GhcPs (LHsType GhcPs)] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. [arg] -> HsConDetails arg rec PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)) -> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)] forall a b. (a -> b) -> [a] -> [b] map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs) forall a pass. a -> HsScaled pass a hsLinear [LHsType GhcPs] ts) ) ) goFirst ((L SrcSpan l (TyElOpd HsKind GhcPs t)):[Located TyEl] xs) | (Bool _, LHsType GhcPs t', P () addAnns, [Located TyEl] xs') <- LHsType GhcPs -> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl]) pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs t) [Located TyEl] xs = P () -> [LHsType GhcPs] -> [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) go P () addAnns [LHsType GhcPs t'] [Located TyEl] xs' goFirst (L SrcSpan l (TyElKindApp SrcSpan _ LHsType GhcPs _):[Located TyEl] _) = Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) goInfix Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall a. Semigroup a => a -> a -> a Monoid.<> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall a b. a -> Either a b Left (SrcSpan l, SDoc kindAppErr) goFirst [Located TyEl] xs = P () -> [LHsType GhcPs] -> [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) go (() -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure ()) [] [Located TyEl] xs go :: P () -> [LHsType GhcPs] -> [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) go P () addAnns [LHsType GhcPs] ts [ L SrcSpan l (TyElOpd (HsTyVar XTyVar GhcPs _ PromotionFlag _ (L SrcSpan _ IdP GhcPs tc))) ] = do { Located RdrName data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon SrcSpan l RdrName IdP GhcPs tc ; (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) forall (m :: * -> *) a. Monad m => a -> m a return (P () addAnns, (Located RdrName data_con, [HsScaled GhcPs (LHsType GhcPs)] -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]) forall arg rec. [arg] -> HsConDetails arg rec PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)) -> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)] forall a b. (a -> b) -> [a] -> [b] map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs) forall a pass. a -> HsScaled pass a hsLinear [LHsType GhcPs] ts))) } go P () addAnns [LHsType GhcPs] ts ((L SrcSpan l (TyElOpd HsKind GhcPs t)):[Located TyEl] xs) | (Bool _, LHsType GhcPs t', P () addAnns', [Located TyEl] xs') <- LHsType GhcPs -> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl]) pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsKind GhcPs t) [Located TyEl] xs = P () -> [LHsType GhcPs] -> [Located TyEl] -> Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) go (P () addAnns P () -> P () -> P () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> P () addAnns') (LHsType GhcPs t'LHsType GhcPs -> [LHsType GhcPs] -> [LHsType GhcPs] forall a. a -> [a] -> [a] :[LHsType GhcPs] ts) [Located TyEl] xs' go P () _ [LHsType GhcPs] _ ((L SrcSpan _ (TyElOpr RdrName _)):[Located TyEl] _) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. Either (SrcSpan, SDoc) (P (), (Located RdrName, HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (GenLocated SrcSpan [LConDeclField GhcPs]))) goInfix go P () _ [LHsType GhcPs] _ (L SrcSpan l