-- -- (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 #-} module RdrHsSyn ( 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, 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, checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, isBangRdr, isTildeRdr, checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, LRuleTyTmVar, RuleTyTmVar(..), mkRuleBndrs, mkRuleTyVarBndrs, checkRuleTyVarBndrNames, checkRecordSyntax, checkEmptyGADTs, addFatalError, hintBangPat, TyEl(..), mergeOps, mergeDataCon, -- 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, patBuilderBang, ) where import GhcPrelude import GHC.Hs -- Lots of it import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import DataCon ( DataCon, dataConTyCon ) import ConLike ( ConLike(..) ) import CoAxiom ( Role, fsFromRole ) import RdrName import Name import BasicTypes import TcEvidence ( idHsWrapper ) import Lexer import Lexeme ( isLexCon ) import Type ( TyThing(..), funTyCon ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, tupleTyConName, cTupleTyConNameArity_maybe ) import ForeignCall import PrelNames ( allNameStrings ) import SrcLoc import Unique ( hasKey ) import OrdList ( OrdList, fromOL ) import Bag ( emptyBag, consBag ) import Outputable import FastString import Maybes import Util import ApiAnnotation import Data.List import DynFlags ( WarningFlag(..), DynFlags ) import ErrUtils ( 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 ) #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 :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) mkTyClD (LTyClDecl (GhcPass p) -> Located (SrcSpanLess (LTyClDecl (GhcPass p))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (LTyClDecl (GhcPass p)) d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p) forall p. XTyClD p -> TyClDecl p -> HsDecl p TyClD XTyClD (GhcPass p) NoExtField noExtField SrcSpanLess (LTyClDecl (GhcPass p)) TyClDecl (GhcPass p) d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) mkInstD (LInstDecl (GhcPass p) -> Located (SrcSpanLess (LInstDecl (GhcPass p))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (LInstDecl (GhcPass p)) d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p) forall p. XInstD p -> InstDecl p -> HsDecl p InstD XInstD (GhcPass p) NoExtField noExtField SrcSpanLess (LInstDecl (GhcPass p)) InstDecl (GhcPass p) d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) mkClassDecl SrcSpan loc (Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (mcxt, tycl_hdr)) Located (a, [LHsFunDep GhcPs]) fds OrdList (LHsDecl GhcPs) where_cls = 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 (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs forall a. HasSrcSpan a => SrcSpanLess a -> a 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL 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 = XClassDecl GhcPs NoExtField noExtField, 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 (Located (a, [Located (FunDep (Located RdrName))]) -> SrcSpanLess (Located (a, [Located (FunDep (Located RdrName))])) forall a. HasSrcSpan a => a -> SrcSpanLess a unLoc Located (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 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (mcxt, 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (DataDecl :: forall pass. XDataDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass DataDecl { tcdDExt :: XDataDecl GhcPs tcdDExt = XDataDecl GhcPs NoExtField 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 (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs forall a. HasSrcSpan a => SrcSpanLess a -> a 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 = XCHsDataDefn GhcPs NoExtField 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (SynDecl :: forall pass. XSynDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass SynDecl { tcdSExt :: XSynDecl GhcPs tcdSExt = XSynDecl GhcPs NoExtField 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 a (m :: * -> *). (HasSrcSpan a, MonadP m, Outputable a, SrcSpanLess a ~ RdrName) => a -> m a check_lhs_name (Located [Located RdrName] -> SrcSpanLess (Located [Located RdrName]) forall a. HasSrcSpan a => a -> SrcSpanLess a 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 -> SrcSpanLess (LStandaloneKindSig GhcPs) -> LStandaloneKindSig GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (SrcSpanLess (LStandaloneKindSig GhcPs) -> LStandaloneKindSig GhcPs) -> SrcSpanLess (LStandaloneKindSig 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 XStandaloneKindSig GhcPs NoExtField noExtField Located RdrName Located (IdP GhcPs) v (LHsType GhcPs -> LHsSigType GhcPs mkLHsSigType LHsType GhcPs rhs) } where check_lhs_name :: a -> m a check_lhs_name v :: a v@(a -> SrcSpanLess a forall a. HasSrcSpan a => a -> SrcSpanLess a unLoc->SrcSpanLess a name) = if RdrName -> Bool isUnqual SrcSpanLess a RdrName name Bool -> Bool -> Bool && OccName -> Bool isTcOcc (RdrName -> OccName rdrNameOcc SrcSpanLess a RdrName name) then a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a v else SrcSpan -> SDoc -> m a forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError (a -> SrcSpan forall a. HasSrcSpan a => a -> SrcSpan getLoc a v) (SDoc -> m a) -> SDoc -> m a forall a b. (a -> b) -> a -> b $ SDoc -> Int -> SDoc -> SDoc hang (String -> SDoc text String "Expected an unqualified type constructor:") Int 2 (a -> SDoc forall a. Outputable a => a -> SDoc ppr a 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 a. HasSrcSpan a => a -> SrcSpan 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 = XCFamEqn GhcPs (LHsType GhcPs) NoExtField 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 -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass DataFamInstD XDataFamInstD GhcPs NoExtField 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 = XCFamEqn GhcPs (HsDataDefn GhcPs) NoExtField 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 -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass TyFamInstD XTyFamInstD GhcPs NoExtField 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass FamDecl XFamDecl GhcPs NoExtField 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 = XCFamilyDecl GhcPs NoExtField 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@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (LHsExpr GhcPs) expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- SrcSpanLess (LHsExpr GhcPs) expr = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl XSpliceDecl GhcPs NoExtField noExtField (SrcSpan -> SrcSpanLess (Located (HsSplice GhcPs)) -> Located (HsSplice GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess (Located (HsSplice GhcPs)) HsSplice GhcPs splice) SpliceExplicitFlag ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- SrcSpanLess (LHsExpr GhcPs) expr = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl XSpliceDecl GhcPs NoExtField noExtField (SrcSpan -> SrcSpanLess (Located (HsSplice GhcPs)) -> Located (HsSplice GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess (Located (HsSplice GhcPs)) HsSplice GhcPs splice) SpliceExplicitFlag ExplicitSplice) | Bool otherwise = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs forall p. XSpliceD p -> SpliceDecl p -> HsDecl p SpliceD XSpliceD GhcPs NoExtField noExtField (XSpliceDecl GhcPs -> Located (HsSplice GhcPs) -> SpliceExplicitFlag -> SpliceDecl GhcPs forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl XSpliceDecl GhcPs NoExtField noExtField (SrcSpan -> SrcSpanLess (Located (HsSplice GhcPs)) -> Located (HsSplice GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice SpliceDecoration NoParens 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 { [Located (Maybe Role)] roles' <- (Located (Maybe FastString) -> P (Located (Maybe Role))) -> [Located (Maybe FastString)] -> P [Located (Maybe Role)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Located (Maybe FastString) -> P (Located (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 -> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs) -> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs forall a b. (a -> b) -> a -> b $ XCRoleAnnotDecl GhcPs -> Located (IdP GhcPs) -> [Located (Maybe Role)] -> RoleAnnotDecl GhcPs forall pass. XCRoleAnnotDecl pass -> Located (IdP pass) -> [Located (Maybe Role)] -> RoleAnnotDecl pass RoleAnnotDecl XCRoleAnnotDecl GhcPs NoExtField noExtField Located RdrName Located (IdP GhcPs) tycon [Located (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 (Located (Maybe Role)) parse_role (Located (Maybe FastString) -> Located (SrcSpanLess (Located (Maybe FastString))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc_role SrcSpanLess (Located (Maybe FastString)) Nothing) = Located (Maybe Role) -> P (Located (Maybe Role)) forall (m :: * -> *) a. Monad m => a -> m a return (Located (Maybe Role) -> P (Located (Maybe Role))) -> Located (Maybe Role) -> P (Located (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcSpan -> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc_role SrcSpanLess (Located (Maybe Role)) forall a. Maybe a Nothing parse_role (Located (Maybe FastString) -> Located (SrcSpanLess (Located (Maybe FastString))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc_role (Just 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 -> Located (Maybe Role) -> P (Located (Maybe Role)) forall (m :: * -> *) a. Monad m => a -> m a return (Located (Maybe Role) -> P (Located (Maybe Role))) -> Located (Maybe Role) -> P (Located (Maybe Role)) forall a b. (a -> b) -> a -> b $ SrcSpan -> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc_role (SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)) -> SrcSpanLess (Located (Maybe Role)) -> Located (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 (Located (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) parse_role Located (Maybe FastString) _ = String -> P (Located (Maybe Role)) forall a. String -> a panic String "parse_role: Impossible Match" -- due to #15884 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) {- ********************************************************************** #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] go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (ValD x b)) : [LHsDecl GhcPs] ds) = SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l' (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs forall p. XValD p -> HsBind p -> HsDecl p ValD XValD GhcPs x SrcSpanLess (LHsBind GhcPs) HsBind GhcPs b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [LHsDecl GhcPs] ds' where (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l' SrcSpanLess (LHsBind GhcPs) b', [LHsDecl GhcPs] ds') = LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsBind GhcPs) HsBind GhcPs b) [LHsDecl GhcPs] ds go (LHsDecl GhcPs d : [LHsDecl GhcPs] ds) = LHsDecl GhcPs d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] forall a. a -> [a] -> [a] : [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [LHsDecl GhcPs] ds -- 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 XValBinds GhcPs GhcPs NoExtField 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 = [LHsDecl GhcPs] -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) forall (m :: * -> *) a a a a a. (HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, MonadP m, SrcSpanLess a ~ DataFamInstDecl GhcPs, SrcSpanLess a ~ FamilyDecl GhcPs, SrcSpanLess a ~ Sig GhcPs, SrcSpanLess a ~ TyFamInstDecl GhcPs, SrcSpanLess a ~ DocDecl) => [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] forall a. OrdList a -> [a] fromOL OrdList (LHsDecl GhcPs) fb) where go :: [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) go [] = (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs forall a. Bag a emptyBag, [], [], [], [], []) go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (ValD _ b)) : [LHsDecl GhcPs] ds) = do { (LHsBinds GhcPs bs, [a] ss, [a] ts, [a] tfis, [a] dfis, [a] docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) go [LHsDecl GhcPs] ds' ; (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBind GhcPs b' LHsBind GhcPs -> LHsBinds GhcPs -> LHsBinds GhcPs forall a. a -> Bag a -> Bag a `consBag` LHsBinds GhcPs bs, [a] ss, [a] ts, [a] tfis, [a] dfis, [a] docs) } where (LHsBind GhcPs b', [LHsDecl GhcPs] ds') = LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsBind GhcPs) HsBind GhcPs b) [LHsDecl GhcPs] ds go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsDecl GhcPs) decl) : [LHsDecl GhcPs] ds) = do { (LHsBinds GhcPs bs, [a] ss, [a] ts, [a] tfis, [a] dfis, [a] docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) go [LHsDecl GhcPs] ds ; case SrcSpanLess (LHsDecl GhcPs) decl of SigD _ s -> (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs bs, SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a Sig GhcPs s a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] ss, [a] ts, [a] tfis, [a] dfis, [a] docs) TyClD _ (FamDecl _ t) -> (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs bs, [a] ss, SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a FamilyDecl GhcPs t a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] ts, [a] tfis, [a] dfis, [a] docs) InstD _ (TyFamInstD { tfid_inst = tfi }) -> (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs bs, [a] ss, [a] ts, SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a TyFamInstDecl GhcPs tfi a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] tfis, [a] dfis, [a] docs) InstD _ (DataFamInstD { dfid_inst = dfi }) -> (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs bs, [a] ss, [a] ts, [a] tfis, SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a DataFamInstDecl GhcPs dfi a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] dfis, [a] docs) DocD _ d -> (LHsBinds GhcPs, [a], [a], [a], [a], [a]) -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. Monad m => a -> m a return (LHsBinds GhcPs bs, [a] ss, [a] ts, [a] tfis, [a] dfis, SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a DocDecl d a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] docs) SpliceD _ d -> SrcSpan -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a addFatalError SrcSpan l (SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])) -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) 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 GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr SpliceDecl GhcPs d) SrcSpanLess (LHsDecl GhcPs) _ -> String -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]) forall a. HasCallStack => String -> SDoc -> a pprPanic String "cvBindsAndSigs" (HsDecl GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr SrcSpanLess (LHsDecl GhcPs) HsDecl GhcPs decl) } ----------------------------------------------------------------------------- -- 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 (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) , fun_matches = MG { mg_alts = (dL->L _ mtchs1) } })) [LHsDecl GhcPs] binds | [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [LMatch GhcPs (LHsExpr GhcPs)] SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)]) mtchs1 = [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go [LMatch GhcPs (LHsExpr GhcPs)] SrcSpanLess (Located [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 ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) , fun_matches = MG { mg_alts = (dL->L _ mtchs2) } }))) : [LHsDecl GhcPs] binds) [LHsDecl GhcPs] _ | SrcSpanLess (Located RdrName) RdrName f1 RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == SrcSpanLess (Located RdrName) RdrName f2 = [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpan -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) go ([LMatch GhcPs (LHsExpr GhcPs)] SrcSpanLess (Located [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@(LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->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 -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind 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) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = String -> Bool forall a. String -> a panic String "RdrHsSyn:has_args" has_args ((LMatch GhcPs (LHsExpr GhcPs) -> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (Match { m_pats = 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). has_args ((LMatch GhcPs (LHsExpr GhcPs) -> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (XMatch nec)) : [LMatch GhcPs (LHsExpr GhcPs)] _) = NoExtCon -> Bool forall a. NoExtCon -> a noExtCon XXMatch GhcPs (LHsExpr GhcPs) NoExtCon nec has_args (LMatch GhcPs (LHsExpr GhcPs) _ : [LMatch GhcPs (LHsExpr GhcPs)] _) = String -> Bool forall a. String -> a panic String "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** #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) | TyElBang | TyElTilde | ... For example, both occurences 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") , TyElBang , 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 -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL 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 (Located RdrName -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (Located RdrName) patsyn_name) (Located (OrdList (LHsDecl GhcPs)) -> Located (SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ SrcSpanLess (Located (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) SrcSpanLess (Located (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 (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc decl :: SrcSpanLess (LHsDecl GhcPs) decl@(ValD _ (PatBind _ pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) rhs _))) = do { Bool -> P () -> P () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (SrcSpanLess (Located RdrName) RdrName name RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool == SrcSpanLess (Located RdrName) RdrName patsyn_name) (P () -> P ()) -> P () -> P () forall a b. (a -> b) -> a -> b $ SrcSpan -> HsDecl GhcPs -> P () wrongNameBindingErr SrcSpan loc SrcSpanLess (LHsDecl GhcPs) 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 (NameOrRdrName (IdP p)) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = XCMatch GhcPs (LHsExpr GhcPs) NoExtField noExtField , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs)) m_ctxt = HsMatchContext RdrName HsMatchContext (NameOrRdrName (IdP 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 RdrName ctxt = FunRhs :: forall id. Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id FunRhs { mc_fun :: Located RdrName mc_fun = Located RdrName Located (IdP 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 (NameOrRdrName (IdP p)) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = XCMatch GhcPs (LHsExpr GhcPs) NoExtField noExtField , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs)) m_ctxt = HsMatchContext RdrName HsMatchContext (NameOrRdrName (IdP 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 RdrName ctxt = FunRhs :: forall id. Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id FunRhs { mc_fun :: Located RdrName mc_fun = Located RdrName Located (IdP 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 -> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)) -> LMatch GhcPs (LHsExpr GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)) Match GhcPs (LHsExpr GhcPs) match } fromDecl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (LHsDecl 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 SrcSpanLess (LHsDecl GhcPs) 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 SrcSpanLess (Located RdrName) 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 (SrcSpanLess (Located RdrName) RdrName patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr :: 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 GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs mkConDeclH98 Located RdrName name Maybe [LHsTyVarBndr GhcPs] mb_forall Maybe (LHsContext GhcPs) mb_cxt HsConDeclDetails GhcPs args = ConDeclH98 :: forall pass. XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe LHsDocString -> ConDecl pass ConDeclH98 { con_ext :: XConDeclH98 GhcPs con_ext = XConDeclH98 GhcPs NoExtField noExtField , con_name :: Located (IdP GhcPs) con_name = Located RdrName Located (IdP GhcPs) name , con_forall :: Located Bool con_forall = SrcSpanLess (Located Bool) -> Located Bool forall a. HasSrcSpan a => SrcSpanLess a -> a noLoc (SrcSpanLess (Located Bool) -> Located Bool) -> SrcSpanLess (Located Bool) -> Located Bool forall a b. (a -> b) -> a -> b $ Maybe [LHsTyVarBndr GhcPs] -> Bool forall a. Maybe a -> Bool isJust Maybe [LHsTyVarBndr GhcPs] mb_forall , con_ex_tvs :: [LHsTyVarBndr GhcPs] con_ex_tvs = Maybe [LHsTyVarBndr GhcPs] mb_forall Maybe [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs] forall a. Maybe a -> a -> a `orElse` [] , con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt = Maybe (LHsContext GhcPs) mb_cxt , con_args :: HsConDeclDetails GhcPs con_args = HsConDeclDetails GhcPs args , con_doc :: Maybe LHsDocString con_doc = Maybe LHsDocString forall a. Maybe a Nothing } mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -- Always a HsForAllTy -> (ConDecl GhcPs, [AddAnn]) mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn]) mkGadtDecl [Located RdrName] names LHsType GhcPs ty = (ConDeclGADT :: forall pass. XConDeclGADT pass -> [Located (IdP pass)] -> Located Bool -> LHsQTyVars pass -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> LHsType pass -> Maybe LHsDocString -> ConDecl pass ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs con_g_ext = XConDeclGADT GhcPs NoExtField noExtField , con_names :: [Located (IdP GhcPs)] con_names = [Located RdrName] [Located (IdP GhcPs)] names , con_forall :: Located Bool con_forall = SrcSpan -> SrcSpanLess (Located Bool) -> Located Bool forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (SrcSpanLess (Located Bool) -> Located Bool) -> SrcSpanLess (Located Bool) -> Located Bool forall a b. (a -> b) -> a -> b $ LHsType GhcPs -> Bool forall p. LHsType p -> Bool isLHsForAllTy LHsType GhcPs ty' , con_qvars :: LHsQTyVars GhcPs con_qvars = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs [LHsTyVarBndr GhcPs] tvs , con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt = Maybe (LHsContext GhcPs) mcxt , con_args :: HsConDeclDetails GhcPs con_args = HsConDeclDetails 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] anns1 [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ [AddAnn] anns2) where (ty' :: LHsType GhcPs ty'@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsType GhcPs) _),[AddAnn] anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn]) forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn]) peel_parens LHsType GhcPs ty [] ([LHsTyVarBndr GhcPs] tvs, LHsType GhcPs rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs) forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTyInvis LHsType GhcPs ty' (Maybe (LHsContext GhcPs) mcxt, LHsType GhcPs tau, [AddAnn] anns2) = LHsType GhcPs -> [AddAnn] -> (Maybe (LHsContext GhcPs), LHsType GhcPs, [AddAnn]) forall pass. LHsType pass -> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn]) split_rho LHsType GhcPs rho [] split_rho :: LHsType pass -> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn]) split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) [AddAnn] ann = (LHsContext pass -> Maybe (LHsContext pass) forall a. a -> Maybe a Just LHsContext pass cxt, LHsType pass tau, [AddAnn] ann) split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsParTy _ ty)) [AddAnn] ann = LHsType pass -> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn]) split_rho LHsType pass ty ([AddAnn] ann[AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l) split_rho LHsType pass tau [AddAnn] ann = (Maybe (LHsContext pass) forall a. Maybe a Nothing, LHsType pass tau, [AddAnn] ann) (HsConDeclDetails GhcPs args, LHsType GhcPs res_ty) = LHsType GhcPs -> (HsConDeclDetails GhcPs, LHsType GhcPs) forall rec pass arg. (HasSrcSpan rec, SrcSpanLess rec ~ [LConDeclField pass]) => LHsType pass -> (HsConDetails arg rec, LHsType pass) split_tau LHsType GhcPs tau -- See Note [GADT abstract syntax] in GHC.Hs.Decls split_tau :: LHsType pass -> (HsConDetails arg rec, LHsType pass) split_tau (LHsType pass -> Located (SrcSpanLess (LHsType pass)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) = (rec -> HsConDetails arg rec forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> SrcSpanLess rec -> rec forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc [LConDeclField pass] SrcSpanLess rec rf), LHsType pass res_ty) split_tau LHsType pass tau = ([arg] -> HsConDetails arg rec forall arg rec. [arg] -> HsConDetails arg rec PrefixCon [], LHsType pass tau) peel_parens :: LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn]) peel_parens (LHsType pass -> Located (SrcSpanLess (LHsType pass)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsParTy _ ty)) [AddAnn] ann = LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn]) peel_parens LHsType pass ty ([AddAnn] ann[AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l) peel_parens LHsType pass ty [AddAnn] ann = (LHsType pass ty, [AddAnn] ann) 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 :: 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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsParTy _ 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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) | RdrName -> Bool isRdrTyVar SrcSpanLess (Located RdrName) RdrName tv = LHsTyVarBndr GhcPs -> P (LHsTyVarBndr GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (XKindedTyVar GhcPs -> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs forall pass. XKindedTyVar pass -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass KindedTyVar XKindedTyVar GhcPs NoExtField noExtField (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan lv SrcSpanLess (Located RdrName) tv) LHsType GhcPs k)) chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsTyVar _ _ (dL->L ltv tv))) | RdrName -> Bool isRdrTyVar SrcSpanLess (Located RdrName) RdrName tv = LHsTyVarBndr GhcPs -> P (LHsTyVarBndr GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs forall pass. XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass UserTyVar XUserTyVar GhcPs NoExtField noExtField (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan ltv SrcSpanLess (Located RdrName) tv))) chk t :: LHsType GhcPs t@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (LHsType 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 a. HasSrcSpan a => a -> SrcSpan 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 XCRuleBndr GhcPs NoExtField noExtField Located RdrName Located (IdP GhcPs) v cvt_one (RuleTyTmVar Located RdrName v (Just LHsType GhcPs sig)) = XRuleBndrSig GhcPs -> Located (IdP GhcPs) -> LHsSigWcType GhcPs -> RuleBndr GhcPs forall pass. XRuleBndrSig pass -> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass RuleBndrSig XRuleBndrSig GhcPs NoExtField noExtField Located RdrName Located (IdP GhcPs) v (LHsType GhcPs -> LHsSigWcType GhcPs mkLHsSigWcType 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 pass. XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass UserTyVar XUserTyVar GhcPs NoExtField 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 pass. XKindedTyVar pass -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass KindedTyVar XKindedTyVar GhcPs NoExtField 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 GhcPs] -> P () checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = (LHsTyVarBndr GhcPs -> P ()) -> [LHsTyVarBndr GhcPs] -> P () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Located RdrName -> P () forall a (f :: * -> *). (HasSrcSpan a, MonadP f, SrcSpanLess a ~ RdrName) => a -> f () check (Located RdrName -> P ()) -> (LHsTyVarBndr GhcPs -> Located RdrName) -> LHsTyVarBndr GhcPs -> P () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsTyVarBndr GhcPs -> RdrName) -> LHsTyVarBndr GhcPs -> Located RdrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HsTyVarBndr GhcPs -> RdrName forall (p :: Pass). HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) hsTyVarName) where check :: a -> f () check (a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc (Unqual 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 a _ = String -> f () forall a. String -> a panic String "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax :: Located a -> m (Located a) checkRecordSyntax lr :: Located a lr@(Located a -> Located (SrcSpanLess (Located a)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc SrcSpanLess (Located 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 SrcSpanLess (Located 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@(Located ([AddAnn], [LConDecl GhcPs]) -> Located (SrcSpanLess (Located ([AddAnn], [LConDecl GhcPs]))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan span (_, [])) -- 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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsType 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 SrcSpanLess (LHsType GhcPs) 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 _ (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsStarTy _ 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 -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL 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@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ SrcSpanLess (Located RdrName) tc)) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity fix | RdrName -> Bool isRdrTc SrcSpanLess (Located RdrName) RdrName 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@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ SrcSpanLess (Located RdrName) tc) LHsType GhcPs t2) [LHsTypeArg GhcPs] acc [AddAnn] ann LexicalFixity _fix | RdrName -> Bool isRdrTc SrcSpanLess (Located RdrName) RdrName 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 -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL 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.Types (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 = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs) forall a. HasSrcSpan a => a -> SrcSpanLess a unLoc LHsExpr GhcPs expr of HsDo _ DoExpr _ -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "do block" LHsExpr GhcPs expr HsDo _ MDoExpr _ -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "mdo block" LHsExpr GhcPs expr HsLam {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "lambda expression" LHsExpr GhcPs expr HsCase {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "case expression" LHsExpr GhcPs expr HsLamCase {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "lambda-case expression" LHsExpr GhcPs expr HsLet {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "let expression" LHsExpr GhcPs expr HsIf {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "if expression" LHsExpr GhcPs expr HsProc {} -> String -> LHsExpr GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "proc expression" LHsExpr GhcPs expr SrcSpanLess (LHsExpr 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 -> SrcSpanLess (LHsCmd GhcPs) forall a. HasSrcSpan a => a -> SrcSpanLess a unLoc LHsCmd GhcPs cmd of HsCmdLam {} -> String -> LHsCmd GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "lambda command" LHsCmd GhcPs cmd HsCmdCase {} -> String -> LHsCmd GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "case command" LHsCmd GhcPs cmd HsCmdIf {} -> String -> LHsCmd GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "if command" LHsCmd GhcPs cmd HsCmdLet {} -> String -> LHsCmd GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "let command" LHsCmd GhcPs cmd HsCmdDo {} -> String -> LHsCmd GhcPs -> PV () forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV () check String "do command" LHsCmd GhcPs cmd SrcSpanLess (LHsCmd GhcPs) _ -> () -> PV () forall (m :: * -> *) a. Monad m => a -> m a return () check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () check :: String -> a -> PV () check String element 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 (a -> SrcSpan forall a. HasSrcSpan a => a -> SrcSpan getLoc a a) (SDoc -> PV ()) -> SDoc -> PV () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Unexpected " SDoc -> SDoc -> SDoc <> String -> SDoc text String element SDoc -> SDoc -> SDoc <> String -> SDoc text String " in function application:" SDoc -> SDoc -> SDoc $$ Int -> SDoc -> SDoc nest Int 4 (a -> SDoc forall a. Outputable a => a -> SDoc ppr 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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsType GhcPs) orig_t) = [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) check [] (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsType GhcPs) orig_t) where check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs) check [AddAnn] anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan lp (HsTupleTy _ HsBoxedOrConstraintTuple 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 -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l [LHsType GhcPs] SrcSpanLess (LHsContext GhcPs) ts) -- Ditto () check [AddAnn] anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan lp1 (HsParTy _ 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 = SDoc -> LHsType GhcPs -> P () checkNoDocs SDoc msg LHsType GhcPs t P () -> P ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([],SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l [SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsType GhcPs) orig_t]) msg :: SDoc msg = String -> SDoc text String "data constructor context" -- | Check recursively if there are any 'HsDocTy's in the given type. -- This only works on a subset of types produced by 'btype_no_ops' checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs SDoc msg LHsType GhcPs ty = LHsType GhcPs -> P () go LHsType GhcPs ty where go :: LHsType GhcPs -> P () go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsAppKindTy _ ty ki)) = LHsType GhcPs -> P () go LHsType GhcPs ty P () -> P () -> P () forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> LHsType GhcPs -> P () go LHsType GhcPs ki go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsAppTy _ t1 t2)) = LHsType GhcPs -> P () go LHsType GhcPs t1 P () -> P () -> P () forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> LHsType GhcPs -> P () go LHsType GhcPs t2 go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P () forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m () addError SrcSpan l (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ [SDoc] -> SDoc hsep [ String -> SDoc text String "Unexpected haddock", SDoc -> SDoc quotes (LHsDocString -> SDoc forall a. Outputable a => a -> SDoc ppr LHsDocString ds) , String -> SDoc text String "on", SDoc msg, SDoc -> SDoc quotes (LHsType GhcPs -> SDoc forall a. Outputable a => a -> SDoc ppr LHsType GhcPs t) ] go LHsType GhcPs _ = () -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure () 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 postpostive 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 a. HasSrcSpan a => a -> SrcSpan 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 a. HasSrcSpan a => a -> SrcSpan 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 a. HasSrcSpan a => a -> SrcSpan 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@(Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (Located (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 (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l e :: SrcSpanLess (Located (PatBuilder GhcPs)) e@(PatBuilderVar (dL->L _ c))) [LPat GhcPs] args | RdrName -> Bool isRdrDataCon SrcSpanLess (Located RdrName) RdrName c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs forall p. Located (IdP p) -> HsConPatDetails p -> Pat p ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located RdrName) c) ([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 SrcSpanLess (Located RdrName) 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 SrcSpanLess (Located (PatBuilder GhcPs)) PatBuilder GhcPs e) checkPat SrcSpan loc Located (PatBuilder GhcPs) e [LPat GhcPs] args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid -- non-bang-pattern parse of (C ! e) | Just (Located (PatBuilder GhcPs) e', [Located (PatBuilder GhcPs)] args') <- Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) splitBang Located (PatBuilder GhcPs) e = do { [Located (Pat GhcPs)] args'' <- (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)] args' ; SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat SrcSpan loc Located (PatBuilder GhcPs) e' ([Located (Pat GhcPs)] args'' [Located (Pat GhcPs)] -> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)] forall a. [a] -> [a] -> [a] ++ [Located (Pat GhcPs)] [LPat GhcPs] args) } checkPat SrcSpan loc (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (PatBuilderApp f 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 (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ SrcSpanLess (Located (PatBuilder GhcPs)) e) [] = do Pat GhcPs p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat SrcSpan loc SrcSpanLess (Located (PatBuilder GhcPs)) PatBuilder GhcPs e Located (Pat GhcPs) -> PV (Located (Pat GhcPs)) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess (Located (Pat GhcPs)) 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 XVarPat GhcPs NoExtField 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 -> SrcSpanLess (Located (HsOverLit GhcPs)) -> Located (HsOverLit GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess (Located (HsOverLit GhcPs)) HsOverLit GhcPs pos_lit) Maybe (SyntaxExpr GhcPs) forall a. Maybe a Nothing) PatBuilderBang SrcSpan lb Located (PatBuilder GhcPs) e -- (! x) -> do { SrcSpan -> PatBuilder GhcPs -> PV () hintBangPat SrcSpan loc PatBuilder GhcPs e0 ; Located (Pat GhcPs) e' <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat Located (PatBuilder GhcPs) e ; SrcSpan -> AnnKeywordId -> SrcSpan -> PV () forall (m :: * -> *). MonadP m => SrcSpan -> AnnKeywordId -> SrcSpan -> m () addAnnotation SrcSpan loc AnnKeywordId AnnBang SrcSpan lb ; Pat GhcPs -> PV (Pat GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (XBangPat GhcPs -> LPat GhcPs -> Pat GhcPs forall p. XBangPat p -> LPat p -> Pat p BangPat XBangPat GhcPs NoExtField noExtField Located (Pat GhcPs) LPat GhcPs e') } -- n+k patterns PatBuilderOpApp (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan nloc (PatBuilderVar (dL->L _ n))) (Located RdrName -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ SrcSpanLess (Located RdrName) plus) (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | Bool nPlusKPatterns Bool -> Bool -> Bool && (SrcSpanLess (Located RdrName) 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 -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan nloc SrcSpanLess (Located RdrName) n) (SrcSpan -> SrcSpanLess (Located (HsOverLit GhcPs)) -> Located (HsOverLit GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan lloc SrcSpanLess (Located (HsOverLit GhcPs)) HsOverLit GhcPs lit)) PatBuilderOpApp Located (PatBuilder GhcPs) l (Located RdrName -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan cl SrcSpanLess (Located RdrName) c) Located (PatBuilder GhcPs) r | RdrName -> Bool isRdrDataCon SrcSpanLess (Located RdrName) 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 (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs forall p. Located (IdP p) -> HsConPatDetails p -> Pat p ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan cl SrcSpanLess (Located RdrName) c) (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 XParPat GhcPs NoExtField 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 :: PV (Located b) placeHolderPunRhs = Located RdrName -> PV (Located b) forall b. DisambECP b => Located RdrName -> PV (Located b) mkHsVarPV (SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpanLess a -> a noLoc SrcSpanLess (Located RdrName) 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") isBangRdr, isTildeRdr :: RdrName -> Bool isBangRdr :: RdrName -> Bool isBangRdr (Unqual OccName occ) = OccName -> FastString occNameFS OccName occ FastString -> FastString -> Bool forall a. Eq a => a -> a -> Bool == String -> FastString fsLit String "!" isBangRdr RdrName _ = Bool False isTildeRdr :: RdrName -> Bool isTildeRdr = (RdrName -> RdrName -> Bool forall a. Eq a => a -> a -> Bool ==RdrName eqTyCon_RDR) checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> Located (SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs)))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs))) fld) = do Located (Pat GhcPs) p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat (HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs)) -> Located (PatBuilder GhcPs) forall id arg. HsRecField' id arg -> arg hsRecFieldArg SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs))) HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs)) fld) LHsRecField GhcPs (Located (Pat GhcPs)) -> PV (LHsRecField GhcPs (Located (Pat GhcPs))) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> SrcSpanLess (LHsRecField GhcPs (Located (Pat GhcPs))) -> LHsRecField GhcPs (Located (Pat GhcPs)) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs))) HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs)) fld { hsRecFieldArg :: Located (Pat GhcPs) hsRecFieldArg = Located (Pat GhcPs) p })) patFail :: SrcSpan -> SDoc -> PV a patFail :: 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") --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: SrcStrictness -> Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkValDef :: SrcStrictness -> Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBind GhcPs) checkValDef SrcStrictness _strictness 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. (HasSrcSpan a, HasSrcSpan b) => a -> 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], HsBind GhcPs) forall a. LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBind GhcPs) checkPatBind Located (Pat GhcPs) LPat GhcPs lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs)) grhss checkValDef SrcStrictness strictness Located (PatBuilder GhcPs) lhs Maybe (LHsType GhcPs) Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs)) g@(Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs)))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (_,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], HsBind GhcPs) checkFunBind SrcStrictness strictness [AddAnn] ann (Located (PatBuilder GhcPs) -> SrcSpan forall a. HasSrcSpan a => a -> SrcSpan getLoc Located (PatBuilder GhcPs) lhs) Located RdrName fun LexicalFixity is_infix [Located (PatBuilder GhcPs)] pats (SrcSpan -> SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))) 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], HsBind GhcPs) forall a. LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBind 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], HsBind GhcPs) checkFunBind SrcStrictness strictness [AddAnn] ann SrcSpan lhs_loc Located RdrName fun LexicalFixity is_infix [Located (PatBuilder GhcPs)] pats (Located (GRHSs GhcPs (LHsExpr GhcPs)) -> Located (SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan rhs_span SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))) grhss) = do [Located (Pat GhcPs)] ps <- (Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs))) -> [Located (PatBuilder GhcPs)] -> P [Located (Pat GhcPs)] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs)) Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern [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], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([AddAnn] ann, Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs makeFunBind Located RdrName fun [SrcSpan -> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)) -> LMatch GhcPs (LHsExpr GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan match_span (Match :: forall p body. XCMatch p body -> HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> GRHSs p body -> Match p body Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs) m_ext = XCMatch GhcPs (LHsExpr GhcPs) NoExtField noExtField , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs)) m_ctxt = FunRhs :: forall id. Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id FunRhs { mc_fun :: Located RdrName mc_fun = Located RdrName 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 = SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))) 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. 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)] -> HsBind GhcPs makeFunBind Located RdrName fn [LMatch GhcPs (LHsExpr GhcPs)] ms = FunBind :: forall idL idR. XFunBind idL idR -> Located (IdP idL) -> MatchGroup idR (LHsExpr idR) -> HsWrapper -> [Tickish Id] -> HsBindLR idL idR FunBind { fun_ext :: XFunBind GhcPs GhcPs fun_ext = XFunBind GhcPs GhcPs NoExtField 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_co_fn :: HsWrapper fun_co_fn = HsWrapper idHsWrapper, fun_tick :: [Tickish Id] fun_tick = [] } checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind :: LPat GhcPs -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBind GhcPs) checkPatBind LPat GhcPs lhs (Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs)))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (_,grhss)) = ([AddAnn], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return ([],XPatBind GhcPs GhcPs -> LPat GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) -> ([Tickish Id], [[Tickish Id]]) -> HsBind GhcPs forall idL idR. XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> ([Tickish Id], [[Tickish Id]]) -> HsBindLR idL idR PatBind XPatBind GhcPs GhcPs NoExtField noExtField LPat GhcPs lhs GRHSs GhcPs (LHsExpr GhcPs) grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsVar _ lrdr@(dL->L _ v))) | RdrName -> Bool isUnqual SrcSpanLess (Located RdrName) RdrName v , Bool -> Bool not (OccName -> Bool isDataOcc (RdrName -> OccName rdrNameOcc SrcSpanLess (Located RdrName) RdrName 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@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (LHsExpr 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 (LHsExpr p -> Located (SrcSpanLess (LHsExpr p)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsVar _ (dL->L _ v))) = SrcSpanLess (Located (IdP p)) IdP p v IdP p -> IdP p -> Bool forall a. Eq a => a -> a -> Bool == IdP p s looks_like IdP p s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (HsApp _ lhs _)) = 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 :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) => a -> Bool -> b -> Bool -> c -> PV () checkDoAndIfThenElse :: a -> Bool -> b -> Bool -> c -> PV () checkDoAndIfThenElse a guardExpr Bool semiThen b thenExpr Bool semiElse 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 (a -> c -> SrcSpan forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan combineLocs a guardExpr 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 <+> a -> SDoc forall a. Outputable a => a -> SDoc ppr 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 <+> c -> SDoc forall a. Outputable a => a -> SDoc ppr c elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) -- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) splitBang (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (PatBuilderOpApp l_arg op r_arg)) | RdrName -> Bool isBangRdr (Located RdrName -> SrcSpanLess (Located RdrName) forall a. HasSrcSpan a => a -> SrcSpanLess a unLoc Located RdrName op) = (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) forall a. a -> Maybe a Just (Located (PatBuilder GhcPs) l_arg, SrcSpan -> SrcSpanLess (Located (PatBuilder GhcPs)) -> Located (PatBuilder GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l' (SrcSpan -> Located (PatBuilder GhcPs) -> PatBuilder GhcPs forall p. SrcSpan -> Located (PatBuilder p) -> PatBuilder p PatBuilderBang (Located RdrName -> SrcSpan forall a. HasSrcSpan a => a -> SrcSpan getLoc Located RdrName op) Located (PatBuilder GhcPs) arg1) Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] : [Located (PatBuilder GhcPs)] argns) where l' :: SrcSpan l' = Located RdrName -> Located (PatBuilder GhcPs) -> SrcSpan forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan combineLocs Located RdrName op Located (PatBuilder GhcPs) arg1 (Located (PatBuilder GhcPs) arg1,[Located (PatBuilder GhcPs)] argns) = Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) forall p. Located (PatBuilder p) -> [Located (PatBuilder p)] -> (Located (PatBuilder p), [Located (PatBuilder p)]) split_bang Located (PatBuilder GhcPs) r_arg [] split_bang :: Located (PatBuilder p) -> [Located (PatBuilder p)] -> (Located (PatBuilder p), [Located (PatBuilder p)]) split_bang (Located (PatBuilder p) -> Located (SrcSpanLess (Located (PatBuilder p))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (PatBuilderApp f e)) [Located (PatBuilder p)] es = Located (PatBuilder p) -> [Located (PatBuilder p)] -> (Located (PatBuilder p), [Located (PatBuilder p)]) split_bang 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) split_bang Located (PatBuilder p) e [Located (PatBuilder p)] es = (Located (PatBuilder p) e,[Located (PatBuilder p)] es) splitBang Located (PatBuilder GhcPs) _ = Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) forall a. Maybe a Nothing -- See Note [isFunLhs vs mergeDataCon] 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 -- -- The whole LHS is parsed as a single expression. -- Any infix operators on the LHS will parse left-associatively -- E.g. f !x y !z -- will parse (rather strangely) as -- (f ! x y) ! z -- It's up to isFunLhs to sort out the mess -- -- a .!. !b 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 :: * -> *) a. (HasSrcSpan a, MonadP m, SrcSpanLess a ~ RdrName) => Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go Located (PatBuilder GhcPs) e [] [] where go :: Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc (PatBuilderVar (dL->L _ f))) [Located (PatBuilder GhcPs)] es [AddAnn] ann | Bool -> Bool not (RdrName -> Bool isRdrDataCon SrcSpanLess (Located RdrName) RdrName f) = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc SrcSpanLess a SrcSpanLess (Located RdrName) f, LexicalFixity Prefix, [Located (PatBuilder GhcPs)] es, [AddAnn] ann)) go (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (PatBuilderApp f e)) [Located (PatBuilder GhcPs)] es [AddAnn] ann = Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go Located (PatBuilder GhcPs) f (Located (PatBuilder GhcPs) eLocated (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] :[Located (PatBuilder GhcPs)] es) [AddAnn] ann go (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (PatBuilderPar e)) es :: [Located (PatBuilder GhcPs)] es@(Located (PatBuilder GhcPs) _:[Located (PatBuilder GhcPs)] _) [AddAnn] ann = Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go Located (PatBuilder GhcPs) e [Located (PatBuilder GhcPs)] es ([AddAnn] ann [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ SrcSpan -> [AddAnn] mkParensApiAnn SrcSpan l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] go (Located (PatBuilder GhcPs) -> Located (SrcSpanLess (Located (PatBuilder GhcPs))) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] [AddAnn] ann | Bool -> Bool not (RdrName -> Bool isRdrDataCon SrcSpanLess (Located RdrName) RdrName var) = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess a SrcSpanLess (Located RdrName) var, LexicalFixity Prefix, [], [AddAnn] ann)) -- For infix function defns, there should be only one infix *function* -- (though there may be infix *datacons* involved too). So we don't -- need fixity info to figure out which function is being defined. -- a `K1` b `op` c `K2` d -- must parse as -- (a `K1` b) `op` (c `K2` d) -- The renamer checks later that the precedences would yield such a parse. -- -- There is a complication to deal with bang patterns. -- -- ToDo: what about this? -- x + 1 `op` y = ... go e :: Located (PatBuilder GhcPs) e@(L SrcSpan loc (PatBuilderOpApp Located (PatBuilder GhcPs) l (Located RdrName -> Located (SrcSpanLess (Located RdrName)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan loc' SrcSpanLess (Located RdrName) op) Located (PatBuilder GhcPs) r)) [Located (PatBuilder GhcPs)] es [AddAnn] ann | Just (Located (PatBuilder GhcPs) e',[Located (PatBuilder GhcPs)] es') <- Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) splitBang Located (PatBuilder GhcPs) e = do { Bool bang_on <- ExtBits -> m Bool forall (m :: * -> *). MonadP m => ExtBits -> m Bool getBit ExtBits BangPatBit ; if Bool bang_on then Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go Located (PatBuilder GhcPs) e' ([Located (PatBuilder GhcPs)] es' [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. [a] -> [a] -> [a] ++ [Located (PatBuilder GhcPs)] es) [AddAnn] ann else Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc' SrcSpanLess a SrcSpanLess (Located RdrName) op, LexicalFixity Infix, (Located (PatBuilder GhcPs) lLocated (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] :Located (PatBuilder GhcPs) rLocated (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] :[Located (PatBuilder GhcPs)] es), [AddAnn] ann)) } -- No bangs; behave just like the next case | Bool -> Bool not (RdrName -> Bool isRdrDataCon SrcSpanLess (Located RdrName) RdrName op) -- We have found the function! = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. a -> Maybe a Just (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc' SrcSpanLess a SrcSpanLess (Located RdrName) op, LexicalFixity Infix, (Located (PatBuilder GhcPs) lLocated (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] :Located (PatBuilder GhcPs) rLocated (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] :[Located (PatBuilder GhcPs)] es), [AddAnn] ann)) | Bool otherwise -- Infix data con; keep going = do { Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) mb_l <- Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [AddAnn] -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) go Located (PatBuilder GhcPs) l [Located (PatBuilder GhcPs)] es [AddAnn] ann ; case Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) mb_l of Just (a op', LexicalFixity Infix, Located (PatBuilder GhcPs) j : Located (PatBuilder GhcPs) k : [Located (PatBuilder GhcPs)] es', [AddAnn] ann') -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. a -> Maybe a Just (a op', LexicalFixity Infix, Located (PatBuilder GhcPs) j Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] : Located (PatBuilder GhcPs) op_app Located (PatBuilder GhcPs) -> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)] forall a. a -> [a] -> [a] : [Located (PatBuilder GhcPs)] es', [AddAnn] ann')) where op_app :: Located (PatBuilder GhcPs) op_app = SrcSpan -> SrcSpanLess (Located (PatBuilder GhcPs)) -> Located (PatBuilder GhcPs) forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc (Located (PatBuilder GhcPs) -> Located RdrName -> Located (PatBuilder GhcPs) -> PatBuilder GhcPs forall p. Located (PatBuilder p) -> Located RdrName -> Located (PatBuilder p) -> PatBuilder p PatBuilderOpApp Located (PatBuilder GhcPs) k (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan loc' SrcSpanLess (Located RdrName) op) Located (PatBuilder GhcPs) r) Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) _ -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) forall a. Maybe a Nothing } go Located (PatBuilder GhcPs) _ [Located (PatBuilder GhcPs)] _ [AddAnn] _ = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]) -> m (Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [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] | TyElTilde | TyElBang | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) | TyElDocPrev HsDocString {- 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 TyEl TyElTilde = String -> SDoc text String "~" ppr TyEl TyElBang = String -> SDoc text String "!" ppr (TyElUnpackedness ([AddAnn] _, SourceText _, SrcUnpackedness unpk)) = SrcUnpackedness -> SDoc forall a. Outputable a => a -> SDoc ppr SrcUnpackedness unpk ppr (TyElDocPrev HsDocString doc) = HsDocString -> SDoc forall a. Outputable a => a -> SDoc ppr HsDocString doc tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness TyEl TyElTilde = (AnnKeywordId, SrcStrictness) -> Maybe (AnnKeywordId, SrcStrictness) forall a. a -> Maybe a Just (AnnKeywordId AnnTilde, SrcStrictness SrcLazy) tyElStrictness TyEl TyElBang = (AnnKeywordId, SrcStrictness) -> Maybe (AnnKeywordId, SrcStrictness) forall a. a -> Maybe a Just (AnnKeywordId AnnBang, SrcStrictness SrcStrict) tyElStrictness TyEl _ = Maybe (AnnKeywordId, SrcStrictness) forall a. Maybe a Nothing -- | Extract a strictness/unpackedness annotation from the front of a reversed -- 'TyEl' list. pStrictMark :: [Located TyEl] -- reversed TyEl -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} , [AddAnn] , [Located TyEl] {- remaining TyEl -}) pStrictMark :: [Located TyEl] -> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l1 SrcSpanLess (Located TyEl) x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l2 SrcSpanLess (Located TyEl) x2) : [Located TyEl] xs) | Just (AnnKeywordId strAnnId, SrcStrictness str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness SrcSpanLess (Located TyEl) TyEl x1 , TyElUnpackedness (unpkAnns, prag, unpk) <- SrcSpanLess (Located TyEl) x2 = (Located HsSrcBang, [AddAnn], [Located TyEl]) -> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) forall a. a -> Maybe a Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL (SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan l1 SrcSpan l2) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText prag SrcUnpackedness unpk SrcStrictness str) , [AddAnn] unpkAnns [AddAnn] -> [AddAnn] -> [AddAnn] forall a. [a] -> [a] -> [a] ++ [AnnKeywordId -> SrcSpan -> AddAnn AddAnn AnnKeywordId strAnnId SrcSpan l1] , [Located TyEl] xs ) pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (Located TyEl) x1) : [Located TyEl] xs) | Just (AnnKeywordId strAnnId, SrcStrictness str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness SrcSpanLess (Located TyEl) TyEl x1 = (Located HsSrcBang, [AddAnn], [Located TyEl]) -> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) forall a. a -> Maybe a Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText NoSourceText SrcUnpackedness NoSrcUnpack SrcStrictness str) , [AnnKeywordId -> SrcSpan -> AddAnn AddAnn AnnKeywordId strAnnId SrcSpan l] , [Located TyEl] xs ) pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess (Located TyEl) x1) : [Located TyEl] xs) | TyElUnpackedness (anns, prag, unpk) <- SrcSpanLess (Located TyEl) x1 = (Located HsSrcBang, [AddAnn], [Located TyEl]) -> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) forall a. a -> Maybe a Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang HsSrcBang SourceText prag SrcUnpackedness unpk SrcStrictness NoSrcStrict) , [AddAnn] anns , [Located TyEl] xs ) pStrictMark [Located TyEl] _ = Maybe (Located HsSrcBang, [AddAnn], [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@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l1 SrcSpanLess (LHsType GhcPs) _) [Located TyEl] xs = case [Located TyEl] -> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) pStrictMark [Located TyEl] xs of Maybe (Located HsSrcBang, [AddAnn], [Located TyEl]) Nothing -> (Bool False, LHsType GhcPs lt, () -> P () forall (f :: * -> *) a. Applicative f => a -> f a pure (), [Located TyEl] xs) Just (Located HsSrcBang -> Located (SrcSpanLess (Located HsSrcBang)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l2 SrcSpanLess (Located HsSrcBang) strictMark, [AddAnn] anns, [Located TyEl] xs') -> let bl :: SrcSpan bl = SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans SrcSpan l1 SrcSpan l2 bt :: HsKind GhcPs bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs forall pass. XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass HsBangTy XBangTy GhcPs NoExtField noExtField SrcSpanLess (Located HsSrcBang) HsSrcBang strictMark LHsType GhcPs lt in (Bool True, SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan bl SrcSpanLess (LHsType GhcPs) HsKind GhcPs bt, SrcSpan -> [AddAnn] -> P () forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt SrcSpan bl [AddAnn] anns, [Located TyEl] xs') -- | 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 ((Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l1 (TyElOpd 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 -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l1 SrcSpanLess (LHsType GhcPs) 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 a t. (HasSrcSpan a, Num t, Ord t, SrcSpanLess a ~ TyEl) => t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [a] -> 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) -> [a] -> P (LHsType GhcPs) go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (TyElUnpackedness (anns, unpkSrc, unpk))):[a] xs) = if Bool -> Bool not ([LHsTypeArg GhcPs] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsTypeArg GhcPs] acc) Bool -> Bool -> Bool && [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] 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 a. HasSrcSpan a => a -> SrcSpan 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 XBangTy GhcPs NoExtField 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 -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan bl SrcSpanLess (LHsType GhcPs) 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 ([a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] 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 [doc]: -- we do not expect to encounter any docs go t _ [LHsTypeArg GhcPs] _ LHsType GhcPs -> LHsType GhcPs _ ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (TyElDocPrev _)):[a] _) = SrcSpan -> P (LHsType GhcPs) forall a. SrcSpan -> P a failOpDocPrev SrcSpan l -- to improve error messages, we do a bit of guesswork to determine if the -- user intended a '!' or a '~' as a strictness annotation go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess a x) : [a] xs) | Just (AnnKeywordId _, SrcStrictness str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness SrcSpanLess a TyEl x , let guess :: [a] -> Bool guess [] = Bool True guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElOpd _)):[a] _) = Bool False guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElOpr _)):[a] _) = Bool True guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElKindApp _ _)):[a] _) = Bool False guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (SrcSpanLess a TyElTilde)):[a] _) = Bool True guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (SrcSpanLess a TyElBang)):[a] _) = Bool True guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElUnpackedness _)):[a] _) = Bool True guess ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElDocPrev _)):[a] xs') = [a] -> Bool guess [a] xs' guess [a] _ = String -> Bool forall a. String -> a panic String "mergeOps.go.guess: Impossible Match" -- due to #15884 in [a] -> Bool forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => [a] -> Bool guess [a] xs = if Bool -> Bool not ([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. Ord a => a -> a -> Bool > t 1 Bool -> Bool -> Bool || [LHsTypeArg GhcPs] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [LHsTypeArg GhcPs] acc Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 1) then do { LHsType GhcPs a <- 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) ; Located SrcStrictness -> LHsType GhcPs -> P (LHsType GhcPs) forall a. Located SrcStrictness -> LHsType GhcPs -> P a failOpStrictnessCompound (SrcSpan -> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located SrcStrictness) SrcStrictness str) (LHsType GhcPs -> LHsType GhcPs ops_acc LHsType GhcPs a) } else Located SrcStrictness -> P (LHsType GhcPs) forall a. Located SrcStrictness -> P a failOpStrictnessPosition (SrcSpan -> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located SrcStrictness) SrcStrictness str) -- 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 ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (TyElOpr op)):[a] xs) = if [LHsTypeArg GhcPs] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsTypeArg GhcPs] acc Bool -> Bool -> Bool || [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null ((a -> Bool) -> [a] -> [a] forall a. (a -> Bool) -> [a] -> [a] filter a -> Bool forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => a -> Bool isTyElOpd [a] xs) then Located RdrName -> P (LHsType GhcPs) forall a. Located RdrName -> P a failOpFewArgs (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located RdrName) 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) -> [a] -> 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 -> SrcSpanLess (Located RdrName) -> Located RdrName forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (Located RdrName) RdrName op) (LHsType GhcPs -> LHsType GhcPs ops_acc LHsType GhcPs acc')) [a] xs } where isTyElOpd :: a -> Bool isTyElOpd (a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElOpd _)) = Bool True isTyElOpd a _ = Bool False -- clause [opr.1]: interpret 'TyElTilde' as an operator go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess a TyElTilde):[a] xs) = let op :: RdrName op = RdrName eqTyCon_RDR in t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [a] -> P (LHsType GhcPs) go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (RdrName -> TyEl TyElOpr RdrName op)a -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs) -- clause [opr.2]: interpret 'TyElBang' as an operator go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l SrcSpanLess a TyElBang):[a] xs) = let op :: RdrName op = NameSpace -> FastString -> RdrName mkUnqual NameSpace tcClsName (String -> FastString fsLit String "!") in t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [a] -> P (LHsType GhcPs) go t k [LHsTypeArg GhcPs] acc LHsType GhcPs -> LHsType GhcPs ops_acc (SrcSpan -> SrcSpanLess a -> a forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l (RdrName -> TyEl TyElOpr RdrName op)a -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs) -- 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 ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (TyElOpd a)):[a] xs) = t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [a] -> P (LHsType GhcPs) go t k (LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsType GhcPs) HsKind GhcPs a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs] forall a. a -> [a] -> [a] :[LHsTypeArg GhcPs] acc) LHsType GhcPs -> LHsType GhcPs ops_acc [a] 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 ((a -> Located (SrcSpanLess a) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan _ (TyElKindApp l a)):[a] xs) = t -> [LHsTypeArg GhcPs] -> (LHsType GhcPs -> LHsType GhcPs) -> [a] -> 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 [a] 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') } go t _ [LHsTypeArg GhcPs] _ LHsType GhcPs -> LHsType GhcPs _ [a] _ = String -> P (LHsType GhcPs) forall a. String -> a panic String "mergeOps.go: Impossible Match" -- due to #15884 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 ((Located TyEl -> Located (SrcSpanLess (Located TyEl)) forall a. HasSrcSpan a => a -> Located (SrcSpanLess a) dL->L SrcSpan l (TyElOpd 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 -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL SrcSpan l SrcSpanLess (LHsType GhcPs) 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]