{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

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

-- Functions over HsSyn specialised to RdrName.

module GHC.Parser.PostProcess (
        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkSpliceDecl,
        mkRoleAnnotDecl,
        mkClassDecl,
        mkTyData, mkDataFamInst,
        mkTySynonym, mkTyFamInstEqn,
        mkStandaloneKindSig,
        mkTyFamInst,
        mkFamDecl,
        mkInlinePragma,
        mkPatSynMatchGroup,
        mkRecConstrOrUpdate,
        mkTyClD, mkInstD,
        mkRdrRecordCon, mkRdrRecordUpd,
        setRdrNameSpace,
        fromSpecTyVarBndr, fromSpecTyVarBndrs,
        annBinds,

        cvBindGroup,
        cvBindsAndSigs,
        cvTopDecls,
        placeHolderPunRhs,

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

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

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

        -- Token symbols
        starSym,

        -- Warnings and errors
        warnStarIsType,
        warnPrepositiveQualifiedModule,
        failOpFewArgs,
        failOpNotEnabledImportQualifiedPost,
        failOpImportQualifiedTwice,

        SumOrTuple (..),

        -- Expression/command/pattern ambiguity resolution
        PV,
        runPV,
        ECP(ECP, unECP),
        DisambInfixOp(..),
        DisambECP(..),
        ecpFromExp,
        ecpFromCmd,
        PatBuilder,

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

import GHC.Prelude
import GHC.Hs           -- Lots of it
import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon        ( DataCon, dataConTyCon )
import GHC.Core.ConLike        ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Parser.Types
import GHC.Parser.Lexer
import GHC.Parser.Errors
import GHC.Utils.Lexeme ( isLexCon )
import GHC.Types.TyThing
import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
                          listTyConName, listTyConKey, eqTyCon_RDR )
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Utils.Misc
import Data.Either
import Data.List
import Data.Foldable
import GHC.Driver.Flags ( WarningFlag(..) )
import qualified Data.Semigroup as Semi
import GHC.Utils.Panic

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

#include "HsVersions.h"

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

  Construction functions for Rdr stuff

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

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

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

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

mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: forall (p :: Pass). LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L SrcSpanAnnA
loc TyClDecl (GhcPass p)
d) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField TyClDecl (GhcPass p)
d)

mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: forall (p :: Pass). LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L SrcSpanAnnA
loc InstDecl (GhcPass p)
d) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField InstDecl (GhcPass p)
d)

mkClassDecl :: SrcSpan
            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
            -> Located (a,[LHsFunDep GhcPs])
            -> OrdList (LHsDecl GhcPs)
            -> LayoutInfo
            -> [AddEpAnn]
            -> P (LTyClDecl GhcPs)

mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc' (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls LayoutInfo
layoutInfo [AddEpAnn]
annsIn
  = do { let loc :: SrcSpanAnnA
loc = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
ats, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs, [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
_, [GenLocated SrcSpanAnnA DocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
       ; (GenLocated SrcSpanAnnN RdrName
cls, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
       ; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (String -> SDoc
text String
"class") SDoc
whereDots GenLocated SrcSpanAnnN RdrName
cls [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
       ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) -- Get any remaining comments
       ; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann EpAnnComments
cs
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = (EpAnn [AddEpAnn]
anns', AnnSortKey
NoAnnSortKey, LayoutInfo
layoutInfo)
                                  , tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = Maybe (LHsContext GhcPs)
mcxt
                                  , tcdLName :: LIdP GhcPs
tcdLName = GenLocated SrcSpanAnnN RdrName
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
                                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
                                  , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = forall a b. (a, b) -> b
snd (forall l e. GenLocated l e -> e
unLoc Located (a, [LHsFunDep GhcPs])
fds)
                                  , tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
                                  , tcdMeths :: LHsBinds GhcPs
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds
                                  , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
ats, tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs
                                  , tcdDocs :: [LDocDecl GhcPs]
tcdDocs  = [GenLocated SrcSpanAnnA DocDecl]
docs })) }

mkTyData :: SrcSpan
         -> NewOrData
         -> Maybe (LocatedP CType)
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> Located (HsDeriving GhcPs)
         -> [AddEpAnn]
         -> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc' NewOrData
new_or_data Maybe (LocatedP CType)
cType (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr))
         Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
annsIn
  = do { let loc :: SrcSpanAnnA
loc = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
       ; (GenLocated SrcSpanAnnN RdrName
tc, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots GenLocated SrcSpanAnnN RdrName
tc [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
       ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) -- Get any remaining comments
       ; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann EpAnnComments
cs
       ; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = EpAnn [AddEpAnn]
anns',
                                   tcdLName :: LIdP GhcPs
tcdLName = GenLocated SrcSpanAnnN RdrName
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
                                   tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
                                   tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }

mkDataDefn :: NewOrData
           -> Maybe (LocatedP CType)
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP 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
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
noExtField
                            , dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (LocatedP CType)
cType
                            , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = Maybe (LHsContext GhcPs)
mcxt
                            , 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
            -> [AddEpAnn]
            -> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
annsIn
  = do { (GenLocated SrcSpanAnnN RdrName
tc, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; EpAnnComments
cs1 <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc -- Add any API Annotations to the top SrcSpan [temp]
       ; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (String -> SDoc
text String
"type") SDoc
equalsDots GenLocated SrcSpanAnnN RdrName
tc [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
       ; EpAnnComments
cs2 <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc -- Add any API Annotations to the top SrcSpan [temp]
       ; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann (EpAnnComments
cs1 forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (SynDecl
                                { tcdSExt :: XSynDecl GhcPs
tcdSExt = EpAnn [AddEpAnn]
anns'
                                , tcdLName :: LIdP GhcPs
tcdLName = GenLocated SrcSpanAnnN RdrName
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
                                , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
                                , tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }

mkStandaloneKindSig
  :: SrcSpan
  -> Located [LocatedN RdrName]   -- LHS
  -> LHsSigType GhcPs             -- RHS
  -> [AddEpAnn]
  -> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [GenLocated SrcSpanAnnN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [GenLocated SrcSpanAnnN RdrName]
lhs LHsSigType GhcPs
rhs [AddEpAnn]
anns =
  do { [GenLocated SrcSpanAnnN RdrName]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a}.
MonadP m =>
GenLocated (SrcSpanAnn' a) RdrName
-> m (GenLocated (SrcSpanAnn' a) RdrName)
check_lhs_name (forall l e. GenLocated l e -> e
unLoc Located [GenLocated SrcSpanAnnN RdrName]
lhs)
     ; GenLocated SrcSpanAnnN RdrName
v <- [GenLocated SrcSpanAnnN RdrName]
-> P (GenLocated SrcSpanAnnN RdrName)
check_singular_lhs (forall a. [a] -> [a]
reverse [GenLocated SrcSpanAnnN RdrName]
vs)
     ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
     ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
       forall a b. (a -> b) -> a -> b
$ forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) GenLocated SrcSpanAnnN RdrName
v LHsSigType GhcPs
rhs }
  where
    check_lhs_name :: GenLocated (SrcSpanAnn' a) RdrName
-> m (GenLocated (SrcSpanAnn' a) RdrName)
check_lhs_name v :: GenLocated (SrcSpanAnn' a) RdrName
v@(forall l e. GenLocated l e -> e
unLoc->RdrName
name) =
      if RdrName -> Bool
isUnqual RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc RdrName
name)
      then forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated (SrcSpanAnn' a) RdrName
v
      else forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (RdrName -> PsErrorDesc
PsErrUnexpectedQualifiedConstructor (forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' a) RdrName
v)) [] (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) RdrName
v)
    check_singular_lhs :: [GenLocated SrcSpanAnnN RdrName]
-> P (GenLocated SrcSpanAnnN RdrName)
check_singular_lhs [GenLocated SrcSpanAnnN RdrName]
vs =
      case [GenLocated SrcSpanAnnN RdrName]
vs of
        [] -> forall a. String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
        [GenLocated SrcSpanAnnN RdrName
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnN RdrName
v
        [GenLocated SrcSpanAnnN RdrName]
_ -> forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError ([LIdP GhcPs] -> PsErrorDesc
PsErrMultipleNamesInStandaloneKindSignature [GenLocated SrcSpanAnnN RdrName]
vs) [] (forall l e. GenLocated l e -> l
getLoc Located [GenLocated SrcSpanAnnN RdrName]
lhs)

mkTyFamInstEqn :: SrcSpan
               -> HsOuterFamEqnTyVarBndrs GhcPs
               -> LHsType GhcPs
               -> LHsType GhcPs
               -> [AddEpAnn]
               -> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn :: SrcSpan
-> HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn SrcSpan
loc HsOuterFamEqnTyVarBndrs GhcPs
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs [AddEpAnn]
anns
  = do { (GenLocated SrcSpanAnnN RdrName
tc, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) forall a b. (a -> b) -> a -> b
$ FamEqn
                        { feqn_ext :: XCFamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
feqn_ext    = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
anns forall a. Monoid a => a -> a -> a
`mappend` [AddEpAnn]
ann) EpAnnComments
cs
                        , feqn_tycon :: LIdP GhcPs
feqn_tycon  = GenLocated SrcSpanAnnN RdrName
tc
                        , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcPs
bndrs
                        , feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats   = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
                        , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                        , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcPs)
feqn_rhs    = LHsType GhcPs
rhs })}

mkDataFamInst :: SrcSpan
              -> NewOrData
              -> Maybe (LocatedP CType)
              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
                        , LHsType GhcPs)
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> Located (HsDeriving GhcPs)
              -> [AddEpAnn]
              -> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (LocatedP CType)
-> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs,
    LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (LocatedP CType)
cType (Maybe (LHsContext GhcPs)
mcxt, HsOuterFamEqnTyVarBndrs GhcPs
bndrs, LHsType GhcPs
tycl_hdr)
              Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons (L SrcSpan
_ HsDeriving GhcPs
maybe_deriv) [AddEpAnn]
anns
  = do { (GenLocated SrcSpanAnnN RdrName
tc, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc -- Add any API Annotations to the top SrcSpan
       ; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
ann EpAnnComments
cs) [AddEpAnn]
anns EpAnnComments
emptyComments
       ; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (LocatedP CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (LocatedP CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD EpAnn [AddEpAnn]
anns' (forall pass. FamEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl
                  (FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext    = EpAnn [AddEpAnn]
anns'
                          , feqn_tycon :: LIdP GhcPs
feqn_tycon  = GenLocated SrcSpanAnnN RdrName
tc
                          , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcPs
bndrs
                          , feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats   = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
                          , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                          , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs    = HsDataDefn GhcPs
defn })))) }

mkTyFamInst :: SrcSpan
            -> TyFamInstEqn GhcPs
            -> [AddEpAnn]
            -> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> [AddEpAnn] -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn [AddEpAnn]
anns = do
  EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
noExtField
              (forall pass.
XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) TyFamInstEqn GhcPs
eqn)))

mkFamDecl :: SrcSpan
          -> FamilyInfo GhcPs
          -> TopLevelFlag
          -> LHsType GhcPs                   -- LHS
          -> Located (FamilyResultSig GhcPs) -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> [AddEpAnn]
          -> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> TopLevelFlag
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info TopLevelFlag
topLevel LHsType GhcPs
lhs Located (FamilyResultSig GhcPs)
ksig Maybe (LInjectivityAnn GhcPs)
injAnn [AddEpAnn]
annsIn
  = do { (GenLocated SrcSpanAnnN RdrName
tc, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams, LexicalFixity
fixity, [AddEpAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; EpAnnComments
cs1 <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc -- Add any API Annotations to the top SrcSpan [temp]
       ; LHsQTyVars GhcPs
tyvars <- SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars (forall a. Outputable a => a -> SDoc
ppr FamilyInfo GhcPs
info) SDoc
equals_or_where GenLocated SrcSpanAnnN RdrName
tc [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tparams
       ; EpAnnComments
cs2 <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc -- Add any API Annotations to the top SrcSpan [temp]
       ; let anns' :: EpAnn [AddEpAnn]
anns' = EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
emptyComments) [AddEpAnn]
ann (EpAnnComments
cs1 forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField
                                         (FamilyDecl
                                           { fdExt :: XCFamilyDecl GhcPs
fdExt       = EpAnn [AddEpAnn]
anns'
                                           , fdTopLevel :: TopLevelFlag
fdTopLevel  = TopLevelFlag
topLevel
                                           , fdInfo :: FamilyInfo GhcPs
fdInfo      = FamilyInfo GhcPs
info, fdLName :: LIdP GhcPs
fdLName = GenLocated SrcSpanAnnN RdrName
tc
                                           , fdTyVars :: LHsQTyVars GhcPs
fdTyVars    = LHsQTyVars GhcPs
tyvars
                                           , fdFixity :: LexicalFixity
fdFixity    = LexicalFixity
fixity
                                           , fdResultSig :: LFamilyResultSig 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 -> P (LHsDecl GhcPs)
-- If the user wrote
--      [pads| ... ]   then return a QuasiQuoteD
--      $(e)           then return a SpliceD
-- but if they wrote, say,
--      f x            then behave as if they'd written $(f x)
--                     ie a SpliceD
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(L SrcSpanAnnA
loc HsExpr GhcPs
expr)
  | HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsUntypedSplice {}) <- HsExpr GhcPs
expr = do
    EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) forall a b. (a -> b) -> a -> b
$ forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
noExtField (forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)

  | HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsQuasiQuote {}) <- HsExpr GhcPs
expr = do
    EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) forall a b. (a -> b) -> a -> b
$ forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
noExtField (forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)

  | Bool
otherwise = do
    EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn SrcSpanAnnA
loc EpAnnComments
cs) forall a b. (a -> b) -> a -> b
$ forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
noExtField (forall p.
XSpliceDecl p
-> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
noExtField
                                 (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (EpAnn [AddEpAnn]
-> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice forall a. EpAnn a
noAnn SpliceDecoration
BareSplice LHsExpr GhcPs
lexpr))
                                       SpliceExplicitFlag
ImplicitSplice)

mkRoleAnnotDecl :: SrcSpan
                -> LocatedN RdrName                -- type being annotated
                -> [Located (Maybe FastString)]    -- roles
                -> [AddEpAnn]
                -> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> GenLocated SrcSpanAnnN RdrName
-> [Located (Maybe FastString)]
-> [AddEpAnn]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc GenLocated SrcSpanAnnN RdrName
tycon [Located (Maybe FastString)]
roles [AddEpAnn]
anns
  = do { [GenLocated SrcSpan (Maybe Role)]
roles' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
       ; EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
         forall a b. (a -> b) -> a -> b
$ forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
anns EpAnnComments
cs) GenLocated SrcSpanAnnN RdrName
tycon [GenLocated SrcSpan (Maybe Role)]
roles' }
  where
    role_data_type :: DataType
role_data_type = forall a. Data a => a -> DataType
dataTypeOf (forall a. HasCallStack => a
undefined :: Role)
    all_roles :: [Role]
all_roles = forall a b. (a -> b) -> [a] -> [b]
map forall a. Data a => Constr -> a
fromConstr forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
    possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]

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

-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
-- any of the provided binders has an 'InferredSpec' annotation.
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr

-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without
-- annotations. Only accepts specified variables, and errors if the provided
-- binder has an 'InferredSpec' annotation.
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr LHsTyVarBndr Specificity GhcPs
bndr = case LHsTyVarBndr Specificity GhcPs
bndr of
  (L SrcSpanAnnA
loc (UserTyVar XUserTyVar GhcPs
xtv Specificity
flag LIdP GhcPs
idp))     -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
                                          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
xtv () LIdP GhcPs
idp)
  (L SrcSpanAnnA
loc (KindedTyVar XKindedTyVar GhcPs
xtv Specificity
flag LIdP GhcPs
idp LHsType GhcPs
k)) -> (Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
flag SrcSpanAnnA
loc)
                                          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
xtv () LIdP GhcPs
idp LHsType GhcPs
k)
  where
    check_spec :: Specificity -> SrcSpanAnnA -> P ()
    check_spec :: Specificity -> SrcSpanAnnA -> P ()
check_spec Specificity
SpecifiedSpec SrcSpanAnnA
_   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    check_spec Specificity
InferredSpec  SrcSpanAnnA
loc = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError PsErrorDesc
PsErrInferredTypeVarNotAllowed [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)

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

add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
add_where an :: AddEpAnn
an@(AddEpAnn AnnKeywordId
_ (EpaSpan RealSrcSpan
rs)) (EpAnn Anchor
a (AnnList Maybe Anchor
anc Maybe AddEpAnn
o Maybe AddEpAnn
c [AddEpAnn]
r [TrailingAnn]
t) EpAnnComments
cs) EpAnnComments
cs2
  | RealSrcSpan -> Bool
valid_anchor (Anchor -> RealSrcSpan
anchor Anchor
a)
  = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (Anchor -> [AddEpAnn] -> Anchor
widenAnchor Anchor
a [AddEpAnn
an]) (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList Maybe Anchor
anc Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anforall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
  | Bool
otherwise
  = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
rs Anchor
a)
          (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
rs) Maybe Anchor
anc) Maybe AddEpAnn
o Maybe AddEpAnn
c (AddEpAnn
anforall a. a -> [a] -> [a]
:[AddEpAnn]
r) [TrailingAnn]
t) (EpAnnComments
cs forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs2)
add_where an :: AddEpAnn
an@(AddEpAnn AnnKeywordId
_ (EpaSpan RealSrcSpan
rs)) EpAnn AnnList
EpAnnNotUsed EpAnnComments
cs
  = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
rs AnchorOperation
UnchangedAnchor)
           (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
rs AnchorOperation
UnchangedAnchor) forall a. Maybe a
Nothing forall a. Maybe a
Nothing [AddEpAnn
an] []) EpAnnComments
cs
add_where (AddEpAnn AnnKeywordId
_ (EpaDelta DeltaPos
_ [LEpaComment]
_)) EpAnn AnnList
_ EpAnnComments
_ = forall a. String -> a
panic String
"add_where"
 -- EpaDelta should only be used for transformations

valid_anchor :: RealSrcSpan -> Bool
valid_anchor :: RealSrcSpan -> Bool
valid_anchor RealSrcSpan
r = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r forall a. Ord a => a -> a -> Bool
>= Int
0

-- If the decl list for where binds is empty, the anchor ends up
-- invalid. In this case, use the parent one
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
patch_anchor RealSrcSpan
r1 (Anchor RealSrcSpan
r0 AnchorOperation
op) = RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r AnchorOperation
op
  where
    r :: RealSrcSpan
r = if RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r0 forall a. Ord a => a -> a -> Bool
< Int
0 then RealSrcSpan
r1 else RealSrcSpan
r0

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

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

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

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


--  | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll (forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)

-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBindsLR GhcPs GhcPs)
cvBindGroup OrdList (LHsDecl GhcPs)
binding
  = do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mbs, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fam_ds, [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
tfam_insts
         , [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
dfam_insts, [GenLocated SrcSpanAnnA DocDecl]
_) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds AnnSortKey
NoAnnSortKey Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mbs [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs }

cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
fb = do
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
fb' <- forall {m :: * -> *} {a}.
MonadP m =>
[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls (forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
fb)
  forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsDecl GhcPs]
-> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
    [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
partitionBindsAndSigs ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
fb'))
  where
    -- cvBindsAndSigs is called in several places in the parser,
    -- and its items can be produced by various productions:
    --
    --    * decl       (when parsing a where clause or a let-expression)
    --    * decl_inst  (when parsing an instance declaration)
    --    * decl_cls   (when parsing a class declaration)
    --
    -- partitionBindsAndSigs can handle almost all declaration forms produced
    -- by the aforementioned productions, except for SpliceD, which we filter
    -- out here (in drop_bad_decls).
    --
    -- We're not concerned with every declaration form possible, such as those
    -- produced by the topdecl parser production, because cvBindsAndSigs is not
    -- called on top-level declarations.
    drop_bad_decls :: [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    drop_bad_decls (L SrcSpanAnn' a
l (SpliceD XSpliceD GhcPs
_ SpliceDecl GhcPs
d) : [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds) = do
      forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (SpliceDecl GhcPs -> PsErrorDesc
PsErrDeclSpliceNotAtTopLevel SpliceDecl GhcPs
d) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l)
      [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds
    drop_bad_decls (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)
d:[GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds) = (GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)
dforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
-> m [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
drop_bad_decls [GenLocated (SrcSpanAnn' a) (HsDecl GhcPs)]
ds

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

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

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

getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (L SrcSpanAnnA
loc1 (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = fun_id1 :: LIdP GhcPs
fun_id1@(L SrcSpanAnnN
_ RdrName
f1)
                             , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
                               MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ m1 :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1@[L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1]) } }))
            [LHsDecl GhcPs]
binds
  | [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
m1
  = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [forall l e. l -> e -> GenLocated l e
L (forall ann. SrcAnn ann -> SrcAnn ann
removeCommentsA SrcSpanAnnA
loc1) Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs1] (forall ann. Monoid ann => SrcAnn ann -> SrcAnn ann
commentsOnlyA SrcSpanAnnA
loc1) [LHsDecl GhcPs]
binds []
  where
    go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
       -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
       -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ
    go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc
       ((L SrcSpanAnnA
loc2 (ValD XValD GhcPs
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = (L SrcSpanAnnN
_ RdrName
f2)
                                 , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
                                    MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [L SrcSpanAnnA
lm2 Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2]) } })))
         : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
        | RdrName
f1 forall a. Eq a => a -> a -> Bool
== RdrName
f2 =
          let (SrcSpanAnnA
loc2', SrcSpanAnnA
lm2') = SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsA SrcSpanAnnA
loc2 SrcSpanAnnA
lm2
          in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lm2' Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mtchs2 forall a. a -> [a] -> [a]
: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
                        (forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA SrcSpanAnnA
loc SrcSpanAnnA
loc2') [LHsDecl GhcPs]
binds []
    go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(L SrcSpanAnnA
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
        = let doc_decls' :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls' = LHsDecl GhcPs
doc_decl forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
          in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanAnnA
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA SrcSpanAnnA
loc SrcSpanAnnA
loc2) [LHsDecl GhcPs]
binds [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
doc_decls'
    go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpanAnnA
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
        = ( forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (GenLocated SrcSpanAnnN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LIdP GhcPs
fun_id1 (forall a e2 an.
Semigroup a =>
[GenLocated (SrcAnn a) e2]
-> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
          , (forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
        -- Reverse the final matches, to get it back in the right order
        -- Do the same thing with the trailing doc comments

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

-- Group together adjacent FunBinds for every function.
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [] = []
getMonoBindAll (L SrcSpanAnnA
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
b) : [LHsDecl GhcPs]
ds) =
  let (L SrcSpanAnnA
l' HsBindLR GhcPs GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
b) [LHsDecl GhcPs]
ds
  in forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l' (forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
noExtField HsBindLR GhcPs GhcPs
b') forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds'
getMonoBindAll (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
d forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds

has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args []                                  = forall a. String -> a
panic String
"GHC.Parser.PostProcess.has_args"
has_args (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcPs]
args }) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args)
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).

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

  #PrefixToHS-utils# Utilities for conversion

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

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

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

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

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

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

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

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

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

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

-- | Reinterpret a type constructor, including type operators, as a data
--   constructor.
-- See Note [Parsing data constructors is hard]
tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName)
tyConToDataCon :: GenLocated SrcSpanAnnN RdrName
-> Either PsError (GenLocated SrcSpanAnnN RdrName)
tyConToDataCon (L SrcSpanAnnN
loc RdrName
tc)
  | OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
|| OccName -> Bool
isDataOcc OccName
occ
  , FastString -> Bool
isLexCon (OccName -> FastString
occNameFS OccName
occ)
  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))

  | Bool
otherwise
  = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (RdrName -> PsErrorDesc
PsErrNotADataCon RdrName
tc) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc)
  where
    occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc

mkPatSynMatchGroup :: LocatedN RdrName
                   -> LocatedL (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: GenLocated SrcSpanAnnN RdrName
-> LocatedL (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpanAnnN
loc RdrName
patsyn_name) (L SrcSpanAnnL
ld OrdList (LHsDecl GhcPs)
decls) =
    do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
fromDecl (forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
       ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches) (SrcSpan -> P ()
wrongNumberErr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc))
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
ld [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches) }
  where
    fromDecl :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> P (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
fromDecl (L SrcSpanAnnA
loc decl :: HsDecl GhcPs
decl@(ValD XValD GhcPs
_ (PatBind XPatBind GhcPs GhcPs
_
                                 -- AZ: where should these anns come from?
                         pat :: LPat GhcPs
pat@(L SrcSpanAnnA
_ (ConPat XConPat GhcPs
noAnn ln :: XRec GhcPs (ConLikeP GhcPs)
ln@(L SrcSpanAnnN
_ RdrName
name) HsConPatDetails GhcPs
details))
                               GRHSs GhcPs (LHsExpr GhcPs)
rhs ([CoreTickish], [[CoreTickish]])
_))) =
        do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName
name forall a. Eq a => a -> a -> Bool
== RdrName
patsyn_name) forall a b. (a -> b) -> a -> b
$
               SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl
           ; Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match <- case HsConPatDetails GhcPs
details of
               PrefixCon [HsPatSigType (NoGhcTc GhcPs)]
_ [LPat GhcPs]
pats -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = XConPat GhcPs
noAnn
                                                  , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = HsMatchContext GhcPs
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
                                                  , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
                   where
                     ctxt :: HsMatchContext GhcPs
ctxt = FunRhs { mc_fun :: LIdP GhcPs
mc_fun = XRec GhcPs (ConLikeP GhcPs)
ln
                                   , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                   , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }

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

               RecCon{} -> forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LPat GhcPs
pat
           ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match }
    fromDecl (L SrcSpanAnnA
loc HsDecl GhcPs
decl) = SrcSpan
-> HsDecl GhcPs
-> P (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
extraDeclErr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsDecl GhcPs
decl

    extraDeclErr :: SrcSpan
-> HsDecl GhcPs
-> P (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
extraDeclErr SrcSpan
loc HsDecl GhcPs
decl =
        forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (RdrName -> HsDecl GhcPs -> PsErrorDesc
PsErrNoSingleWhereBindInPatSynDecl RdrName
patsyn_name HsDecl GhcPs
decl) [] SrcSpan
loc

    wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
      forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (RdrName -> HsDecl GhcPs -> PsErrorDesc
PsErrInvalidWhereBindInPatSynDecl RdrName
patsyn_name HsDecl GhcPs
decl) [] SrcSpan
loc

    wrongNumberErr :: SrcSpan -> P ()
wrongNumberErr SrcSpan
loc =
      forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (RdrName -> PsErrorDesc
PsErrEmptyWhereInPatSynDecl RdrName
patsyn_name) [] SrcSpan
loc

recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
    forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LPat GhcPs -> PsErrorDesc
PsErrRecordSyntaxInPatSynDecl LPat GhcPs
pat) [] SrcSpan
loc

mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
                -> ConDecl GhcPs

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

-- | Construct a GADT-style data constructor from the constructor names and
-- their type. Some interesting aspects of this function:
--
-- * This splits up the constructor type into its quantified type variables (if
--   provided), context (if provided), argument types, and result type, and
--   records whether this is a prefix or record GADT constructor. See
--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: SrcSpan
           -> [LocatedN RdrName]
           -> LHsSigType GhcPs
           -> [AddEpAnn]
           -> P (LConDecl GhcPs)
mkGadtDecl :: SrcSpan
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsSigType GhcPs
-> [AddEpAnn]
-> P (LConDecl GhcPs)
mkGadtDecl SrcSpan
loc [GenLocated SrcSpanAnnN RdrName]
names LHsSigType GhcPs
ty [AddEpAnn]
annsIn = do
  EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
  let l :: SrcSpanAnnA
l = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc

  let (HsConDeclGADTDetails GhcPs
args, GenLocated SrcSpanAnnA (HsType GhcPs)
res_ty, [AddEpAnn]
annsa, EpAnnComments
csa)
        | L SrcSpanAnnA
ll (HsFunTy XFunTy GhcPs
af HsArrow GhcPs
_w (L SrcSpanAnnA
loc' (HsRecTy XRecTy GhcPs
an [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) <- LHsType GhcPs
body_ty
        = let
            an' :: EpAnn AnnList
an' = SrcSpan
-> TrailingAnn -> EpAnnComments -> EpAnn AnnList -> EpAnn AnnList
addTrailingAnnToL (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc') (forall ann. EpAnn ann -> ann
anns XFunTy GhcPs
af) (forall ann. EpAnn ann -> EpAnnComments
comments XFunTy GhcPs
af) XRecTy GhcPs
an
          in ( forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT (forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn AnnList
an' (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc')) [LConDeclField GhcPs]
rf), LHsType GhcPs
res_ty
             , [], forall ann. EpAnn ann -> EpAnnComments
epAnnComments (forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnA
ll))
        | Bool
otherwise
        = let ([AddEpAnn]
anns, EpAnnComments
cs, [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type) = forall (p :: Pass).
LHsType (GhcPass p)
-> ([AddEpAnn], EpAnnComments,
    [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
splitHsFunType LHsType GhcPs
body_ty
          in (forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type, [AddEpAnn]
anns, EpAnnComments
cs)

      an :: EpAnn [AddEpAnn]
an = case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
        HsOuterSigTyVarBndrs GhcPs
_                -> forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
annsIn forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
annsa) (EpAnnComments
cs forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csa)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l ConDeclGADT
                     { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = EpAnn [AddEpAnn]
an
                     , con_names :: [LIdP GhcPs]
con_names  = [GenLocated SrcSpanAnnN RdrName]
names
                     , con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs  = forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc LHsSigType GhcPs
ty) HsOuterSigTyVarBndrs GhcPs
outer_bndrs
                     , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
                     , con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args = HsConDeclGADTDetails GhcPs
args
                     , con_res_ty :: LHsType GhcPs
con_res_ty = GenLocated SrcSpanAnnA (HsType GhcPs)
res_ty
                     , con_doc :: Maybe LHsDocString
con_doc    = forall a. Maybe a
Nothing }
  where
    (HsOuterSigTyVarBndrs GhcPs
outer_bndrs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsSigType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs),
    LHsType GhcPs)
splitLHsGadtTy LHsSigType GhcPs
ty

setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
-- > data T a = T | T1 Int
--
-- we parse the data constructors as /types/ because of parser ambiguities,
-- so then we need to change the /type constr/ to a /data constr/
--
-- The exact-name case /can/ occur when parsing:
--
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual OccName
occ) NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual ModuleName
m OccName
occ) NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig Module
m OccName
occ) NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact Name
n)    NameSpace
ns
  | Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
n
  = TyThing -> NameSpace -> RdrName
setWiredInNameSpace TyThing
thing NameSpace
ns
    -- Preserve Exact Names for wired-in things,
    -- notably tuples and lists

  | Name -> Bool
isExternalName Name
n
  = Module -> OccName -> RdrName
Orig (HasDebugCallStack => 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 (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 (forall a. NamedThing a => a -> Name
getName DataCon
dc)      -- No-op

setWiredInNameSpace TyThing
thing NameSpace
ns
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> 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 (forall a. NamedThing a => a -> Name
getName DataCon
dc)

  | TyCon
tc 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 (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 (forall a. NamedThing a => a -> Name
getName TyCon
tc)

  | DataCon
dc 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 (forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))



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

eitherToP :: MonadP m => Either PsError a -> m a
-- Adapts the Either monad to the P monad
eitherToP :: forall (m :: * -> *) a. MonadP m => Either PsError a -> m a
eitherToP (Left PsError
err)    = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError PsError
err
eitherToP (Right a
thing) = forall (m :: * -> *) a. Monad m => a -> m a
return a
thing

checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]
            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
checkTyVars :: SDoc
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVars SDoc
pp_what SDoc
equals_or_where GenLocated SrcSpanAnnN RdrName
tc [LHsTypeArg GhcPs]
tparms
  = do { [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsArg
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
check [LHsTypeArg GhcPs]
tparms
       ; forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs) }
  where
    check :: HsArg
  (GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsType GhcPs))
-> P (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs))
check (HsTypeArg SrcSpan
_ ki :: GenLocated SrcSpanAnnA (HsType GhcPs)
ki@(L SrcSpanAnnA
loc HsType GhcPs
_)) = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LHsType GhcPs -> SDoc -> RdrName -> PsErrorDesc
PsErrUnexpectedTypeAppInDecl GenLocated SrcSpanAnnA (HsType GhcPs)
ki SDoc
pp_what (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tc)) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
    check (HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
ty) = [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens [] [] EpAnnComments
emptyComments GenLocated SrcSpanAnnA (HsType GhcPs)
ty
    check (HsArgPar SrcSpan
sp) = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (SDoc -> RdrName -> PsErrorDesc
PsErrMalformedDecl SDoc
pp_what (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tc)) [] SrcSpan
sp
        -- Keep around an action for adjusting the annotations of extra parens
    chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
              -> P (LHsTyVarBndr () GhcPs)
    chkParens :: [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsParTy XParTy GhcPs
an LHsType GhcPs
ty))
      = let
          (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
        in
          [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chkParens (AddEpAnn
oforall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cforall a. a -> [a] -> [a]
:[AddEpAnn]
cps) (EpAnnComments
cs forall a. Semigroup a => a -> a -> a
Semi.<> forall ann. EpAnn ann -> EpAnnComments
epAnnComments XParTy GhcPs
an) LHsType GhcPs
ty
    chkParens [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs LHsType GhcPs
ty = [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs LHsType GhcPs
ty

        -- Check that the name space is correct!
    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
    chk :: [AddEpAnn]
-> [AddEpAnn]
-> EpAnnComments
-> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsKindSig XKindSig GhcPs
annk (L SrcSpanAnnA
annt (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
lv RdrName
tv))) LHsType GhcPs
k))
        | RdrName -> Bool
isRdrTyVar RdrName
tv
            = let
                an :: [AddEpAnn]
an = (forall a. [a] -> [a]
reverse [AddEpAnn]
ops) forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
              in
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
widenLocatedAn (SrcSpanAnnA
l forall a. Semigroup a => a -> a -> a
Semi.<> SrcSpanAnnA
annt) [AddEpAnn]
an)
                       (forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns (XKindSig GhcPs
annk forall a. Semigroup a => a -> a -> a
Semi.<> XTyVar GhcPs
ann) [AddEpAnn]
an EpAnnComments
cs) () (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
lv RdrName
tv) LHsType GhcPs
k))
    chk [AddEpAnn]
ops [AddEpAnn]
cps EpAnnComments
cs (L SrcSpanAnnA
l (HsTyVar XTyVar GhcPs
ann PromotionFlag
_ (L SrcSpanAnnN
ltv RdrName
tv)))
        | RdrName -> Bool
isRdrTyVar RdrName
tv
            = let
                an :: [AddEpAnn]
an = (forall a. [a] -> [a]
reverse [AddEpAnn]
ops) forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps
              in
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall an. SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
widenLocatedAn SrcSpanAnnA
l [AddEpAnn]
an)
                                     (forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns XTyVar GhcPs
ann [AddEpAnn]
an EpAnnComments
cs) () (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ltv RdrName
tv)))
    chk [AddEpAnn]
_ [AddEpAnn]
_ EpAnnComments
_ t :: LHsType GhcPs
t@(L SrcSpanAnnA
loc HsType GhcPs
_)
        = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LHsType GhcPs
-> SDoc -> RdrName -> [LHsTypeArg GhcPs] -> SDoc -> PsErrorDesc
PsErrUnexpectedTypeInDecl LHsType GhcPs
t SDoc
pp_what (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
tc) [LHsTypeArg GhcPs]
tparms SDoc
equals_or_where) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)


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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just LHsContext GhcPs
c)
    = do Bool
allowed <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DatatypeContextsBit
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LHsContext GhcPs -> PsErrorDesc
PsErrIllegalDataTypeContext LHsContext GhcPs
c) [] (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsContext GhcPs
c)

type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@

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

-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {ann}.
LRuleTyTmVar -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
cvt_one
  where cvt_one :: LRuleTyTmVar -> GenLocated (SrcAnn ann) (HsTyVarBndr () GhcPs)
cvt_one (L SrcSpan
l (RuleTyTmVar EpAnn [AddEpAnn]
ann GenLocated SrcSpanAnnN RdrName
v Maybe (LHsType GhcPs)
Nothing))
          = forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) (forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar EpAnn [AddEpAnn]
ann () (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty GenLocated SrcSpanAnnN RdrName
v))
        cvt_one (L SrcSpan
l (RuleTyTmVar EpAnn [AddEpAnn]
ann GenLocated SrcSpanAnnN RdrName
v (Just LHsType GhcPs
sig)))
          = forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) (forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar EpAnn [AddEpAnn]
ann () (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty GenLocated SrcSpanAnnN RdrName
v) LHsType GhcPs
sig)
    -- takes something in namespace 'varName' to something in namespace 'tvName'
        tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
        tm_to_ty RdrName
_ = forall a. String -> a
panic String
"mkRuleTyVarBndrs"

-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {f :: * -> *} {a}.
MonadP f =>
GenLocated (SrcSpanAnn' a) RdrName -> f ()
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
  where check :: GenLocated (SrcSpanAnn' a) RdrName -> f ()
check (L SrcSpanAnn' a
loc (Unqual OccName
occ)) =
          -- TODO: don't use string here, OccName has a Unique/FastString
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ forall a. Eq a => a -> a -> Bool
==) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String
"forall",String
"family",String
"role"])
            (forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (OccName -> PsErrorDesc
PsErrParseErrorOnInput OccName
occ) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc))
        check GenLocated (SrcSpanAnn' a) RdrName
_ = forall a. String -> a
panic String
"checkRuleTyVarBndrNames"

checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax :: forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
LocatedA a -> m (LocatedA a)
checkRecordSyntax lr :: LocatedA a
lr@(L SrcSpanAnnA
loc a
r)
    = do Bool
allowed <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (SDoc -> PsErrorDesc
PsErrIllegalTraditionalRecordSyntax (forall a. Outputable a => a -> SDoc
ppr a
r)) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
         forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA a
lr

-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
-> P (Located ([AddEpAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddEpAnn], [LConDecl GhcPs])
gadts@(L SrcSpan
span ([AddEpAnn]
_, []))           -- Empty GADT declaration.
    = do Bool
gadtSyntax <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit   -- GADTs implies GADTSyntax
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gadtSyntax forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError PsErrorDesc
PsErrIllegalWhereInDataDecl [] SrcSpan
span
         forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddEpAnn], [LConDecl GhcPs])
gadts
checkEmptyGADTs Located ([AddEpAnn], [LConDecl GhcPs])
gadts = forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddEpAnn], [LConDecl GhcPs])
gadts              -- Ordinary GADT declaration.

checkTyClHdr :: Bool               -- True  <=> class header
                                   -- False <=> type header
             -> LHsType GhcPs
             -> P (LocatedN RdrName,     -- the head symbol (type or class name)
                   [LHsTypeArg GhcPs],   -- parameters of head symbol
                   LexicalFixity,        -- the declaration is in infix format
                   [AddEpAnn])           -- API Annotation for HsParTy
                                         -- when stripping parens
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
--              Int :*: Bool   into    (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
  = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
ty [] [] [] LexicalFixity
Prefix
  where
    goL :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
goL (L SrcSpanAnnA
l HsType GhcPs
ty) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
go (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsType GhcPs
ty [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix

    -- workaround to define '*' despite StarIsType
    go :: SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
go SrcSpan
_ (HsParTy XParTy GhcPs
an (L SrcSpanAnnA
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops' [AddEpAnn]
cps' LexicalFixity
fix
      = do { forall (m :: * -> *). MonadP m => WarningFlag -> PsWarning -> m ()
addWarning WarningFlag
Opt_WarnStarBinder (SrcSpan -> PsWarning
PsWarnStarBinder (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l))
           ; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
           ; let a' :: SrcSpanAnnN
a' = SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns SrcSpanAnnA
l XParTy GhcPs
an
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
a' (OccName -> RdrName
Unqual OccName
name), [LHsTypeArg GhcPs]
acc, LexicalFixity
fix
                    , (forall a. [a] -> [a]
reverse [AddEpAnn]
ops') forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps') }

    go SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: LIdP GhcPs
ltc@(L SrcSpanAnnN
_ RdrName
tc)) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
      | RdrName -> Bool
isRdrTc RdrName
tc               = forall (m :: * -> *) a. Monad m => a -> m a
return (LIdP GhcPs
ltc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, (forall a. [a] -> [a]
reverse [AddEpAnn]
ops) forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)
    go SrcSpan
_ (HsOpTy XOpTy GhcPs
_ LHsType GhcPs
t1 ltc :: LIdP GhcPs
ltc@(L SrcSpanAnnN
_ RdrName
tc) LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
_fix
      | RdrName -> Bool
isRdrTc RdrName
tc               = forall (m :: * -> *) a. Monad m => a -> m a
return (LIdP GhcPs
ltc, forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1forall a. a -> [a] -> [a]
:forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, (forall a. [a] -> [a]
reverse [AddEpAnn]
ops) forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)
    go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)    [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc (AddEpAnn
oforall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cforall a. a -> [a] -> [a]
:[AddEpAnn]
cps) LexicalFixity
fix
      where
        (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l)
    go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
t1 (forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
    go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [LHsTypeArg GhcPs]
acc [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix = GenLocated SrcSpanAnnA (HsType GhcPs)
-> [LHsTypeArg GhcPs]
-> [AddEpAnn]
-> [AddEpAnn]
-> LexicalFixity
-> P (GenLocated SrcSpanAnnN RdrName, [LHsTypeArg GhcPs],
      LexicalFixity, [AddEpAnn])
goL LHsType GhcPs
ty (forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg XAppKindTy GhcPs
l LHsType GhcPs
kiforall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
    go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddEpAnn]
ops [AddEpAnn]
cps LexicalFixity
fix
      = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) (Name -> RdrName
nameRdrName Name
tup_name)
               , forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, (forall a. [a] -> [a]
reverse [AddEpAnn]
ops)forall a. [a] -> [a] -> [a]
++[AddEpAnn]
cps)
      where
        arity :: Int
arity = 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 = forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
    go SrcSpan
l HsType GhcPs
_ [LHsTypeArg GhcPs]
_ [AddEpAnn]
_ [AddEpAnn]
_ LexicalFixity
_
      = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LHsType GhcPs -> PsErrorDesc
PsErrMalformedTyOrClDecl LHsType GhcPs
ty) [] SrcSpan
l

    -- Combine the annotations from the HsParTy and HsStarTy into a
    -- new one for the LocatedN RdrName
    newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
    newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns (SrcSpanAnn EpAnn AnnListItem
EpAnnNotUsed SrcSpan
l) (EpAnn Anchor
as (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs) =
      let
        lr :: RealSrcSpan
lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (Anchor -> RealSrcSpan
anchor Anchor
as)
        -- lr = widenAnchorR as (realSrcSpan l)
        an :: EpAnn NameAnn
an = (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
lr AnchorOperation
UnchangedAnchor) (NameAdornment
-> EpaLocation
-> EpaLocation
-> EpaLocation
-> [TrailingAnn]
-> NameAnn
NameAnn NameAdornment
NameParens EpaLocation
o (RealSrcSpan -> EpaLocation
EpaSpan forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) EpaLocation
c []) EpAnnComments
cs)
      in forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn NameAnn
an (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
lr forall a. Maybe a
Nothing)
    newAnns SrcSpanAnnA
_ EpAnn AnnParen
EpAnnNotUsed = forall a. String -> a
panic String
"missing AnnParen"
    newAnns (SrcSpanAnn (EpAnn Anchor
ap (AnnListItem [TrailingAnn]
ta) EpAnnComments
csp) SrcSpan
l) (EpAnn Anchor
as (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs) =
      let
        lr :: RealSrcSpan
lr = RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans (Anchor -> RealSrcSpan
anchor Anchor
ap) (Anchor -> RealSrcSpan
anchor Anchor
as)
        an :: EpAnn NameAnn
an = (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
lr AnchorOperation
UnchangedAnchor) (NameAdornment
-> EpaLocation
-> EpaLocation
-> EpaLocation
-> [TrailingAnn]
-> NameAnn
NameAnn NameAdornment
NameParens EpaLocation
o (RealSrcSpan -> EpaLocation
EpaSpan forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) EpaLocation
c [TrailingAnn]
ta) (EpAnnComments
csp forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs))
      in forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn NameAnn
an (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
lr forall a. Maybe a
Nothing)

-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PV ()
LHsExpr GhcPs -> PV ()
checkExpBlockArguments, GenLocated SrcSpanAnnA (HsCmd GhcPs) -> PV ()
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 forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
expr of
      HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
m) XRec GhcPs [ExprLStmt GhcPs]
_  -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (Maybe ModuleName -> LHsExpr GhcPs -> PsErrorDesc
PsErrDoInFunAppExpr Maybe ModuleName
m)     LHsExpr GhcPs
expr
      HsDo XDo GhcPs
_ (MDoExpr Maybe ModuleName
m) XRec GhcPs [ExprLStmt GhcPs]
_ -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check (Maybe ModuleName -> LHsExpr GhcPs -> PsErrorDesc
PsErrMDoInFunAppExpr Maybe ModuleName
m)    LHsExpr GhcPs
expr
      HsLam {}             -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrLambdaInFunAppExpr     LHsExpr GhcPs
expr
      HsCase {}            -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrCaseInFunAppExpr       LHsExpr GhcPs
expr
      HsLamCase {}         -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrLambdaCaseInFunAppExpr LHsExpr GhcPs
expr
      HsLet {}             -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrLetInFunAppExpr        LHsExpr GhcPs
expr
      HsIf {}              -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrIfInFunAppExpr         LHsExpr GhcPs
expr
      HsProc {}            -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsExpr GhcPs -> PsErrorDesc
PsErrProcInFunAppExpr       LHsExpr GhcPs
expr
      HsExpr GhcPs
_                    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkCmd :: LHsCmd GhcPs -> PV ()
    checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case forall l e. GenLocated l e -> e
unLoc LHsCmd GhcPs
cmd of
      HsCmdLam {}  -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsErrorDesc
PsErrLambdaCmdInFunAppCmd LHsCmd GhcPs
cmd
      HsCmdCase {} -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsErrorDesc
PsErrCaseCmdInFunAppCmd   LHsCmd GhcPs
cmd
      HsCmdIf {}   -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsErrorDesc
PsErrIfCmdInFunAppCmd     LHsCmd GhcPs
cmd
      HsCmdLet {}  -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsErrorDesc
PsErrLetCmdInFunAppCmd    LHsCmd GhcPs
cmd
      HsCmdDo {}   -> forall {m :: * -> *} {a} {e}.
MonadP m =>
(GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check LHsCmd GhcPs -> PsErrorDesc
PsErrDoCmdInFunAppCmd     LHsCmd GhcPs
cmd
      HsCmd GhcPs
_            -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    check :: (GenLocated (SrcSpanAnn' a) e -> PsErrorDesc)
-> GenLocated (SrcSpanAnn' a) e -> m ()
check GenLocated (SrcSpanAnn' a) e -> PsErrorDesc
err GenLocated (SrcSpanAnn' a) e
a = do
      Bool
blockArguments <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (GenLocated (SrcSpanAnn' a) e -> PsErrorDesc
err GenLocated (SrcSpanAnn' a) e
a) [] (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) e
a)

-- | Validate the context constraints and break up a context into a list
-- of predicates.
--
-- @
--     (Eq a, Ord b)        -->  [Eq a, Ord b]
--     Eq a                 -->  [Eq a]
--     (Eq a)               -->  [Eq a]
--     (((Eq a)))           -->  [Eq a]
-- @
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext orig_t :: LHsType GhcPs
orig_t@(L (SrcSpanAnn EpAnn AnnListItem
_ SrcSpan
l) HsType GhcPs
_orig_t) =
  ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([],[],EpAnnComments
emptyComments) LHsType GhcPs
orig_t
 where
  check :: ([EpaLocation],[EpaLocation],EpAnnComments)
        -> LHsType GhcPs -> P (LHsContext GhcPs)
  check :: ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpaLocation]
oparens,[EpaLocation]
cparens,EpAnnComments
cs) (L SrcSpanAnnA
_l (HsTupleTy XTupleTy GhcPs
ann' HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
    -- be used as context constraints.
    -- Ditto ()
    = do
        let ([EpaLocation]
op,[EpaLocation]
cp,EpAnnComments
cs') = case XTupleTy GhcPs
ann' of
              EpAnn AnnParen
XTupleTy GhcPs
EpAnnNotUsed -> ([],[],EpAnnComments
emptyComments)
              EpAnn Anchor
_ (AnnParen ParenType
_ EpaLocation
o EpaLocation
c) EpAnnComments
cs -> ([EpaLocation
o],[EpaLocation
c],EpAnnComments
cs)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l)
                              -- Append parens so that the original order in the source is maintained
                               (Maybe (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext forall a. Maybe a
Nothing ([EpaLocation]
oparens forall a. [a] -> [a] -> [a]
++ [EpaLocation]
op) ([EpaLocation]
cp forall a. [a] -> [a] -> [a]
++ [EpaLocation]
cparens)) (EpAnnComments
cs forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
cs')) SrcSpan
l) [LHsType GhcPs]
ts)

  check ([EpaLocation]
opi,[EpaLocation]
cpi,EpAnnComments
csi) (L SrcSpanAnnA
_lp1 (HsParTy XParTy GhcPs
ann' LHsType GhcPs
ty))
                                  -- to be sure HsParTy doesn't get into the way
    = do
        let ([EpaLocation]
op,[EpaLocation]
cp,EpAnnComments
cs') = case XParTy GhcPs
ann' of
                    EpAnn AnnParen
XParTy GhcPs
EpAnnNotUsed -> ([],[],EpAnnComments
emptyComments)
                    EpAnn Anchor
_ (AnnParen ParenType
_ EpaLocation
open EpaLocation
close ) EpAnnComments
cs -> ([EpaLocation
open],[EpaLocation
close],EpAnnComments
cs)
        ([EpaLocation], [EpaLocation], EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check ([EpaLocation]
opforall a. [a] -> [a] -> [a]
++[EpaLocation]
opi,[EpaLocation]
cpforall a. [a] -> [a] -> [a]
++[EpaLocation]
cpi,EpAnnComments
cs' forall a. Semigroup a => a -> a -> a
Semi.<> EpAnnComments
csi) LHsType GhcPs
ty

  -- No need for anns, returning original
  check ([EpaLocation]
_opi,[EpaLocation]
_cpi,EpAnnComments
_csi) LHsType GhcPs
_t =
                 forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l) (Maybe (IsUnicodeSyntax, EpaLocation)
-> [EpaLocation] -> [EpaLocation] -> AnnContext
AnnContext forall a. Maybe a
Nothing [] []) EpAnnComments
emptyComments) SrcSpan
l) [LHsType GhcPs
orig_t])

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

  Bool
importQualifiedPostEnabled <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ImportQualifiedPostBit

  -- Error if 'qualified' found in postpositive position and
  -- 'ImportQualifiedPost' is not in effect.
  forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe EpaLocation
mPost forall a b. (a -> b) -> a -> b
$ \EpaLocation
post ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) forall a b. (a -> b) -> a -> b
$
      SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
post) forall a. Maybe a
Nothing)

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

  -- Warn if 'qualified' found in prepositive position and
  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
  forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe EpaLocation
mPre forall a b. (a -> b) -> a -> b
$ \EpaLocation
pre ->
    SrcSpan -> P ()
warnPrepositiveQualifiedModule (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
pre) forall a. Maybe a
Nothing)

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

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

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

checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_hints [Hint]
hints PV (LocatedA (PatBuilder GhcPs))
pp = forall a. [Hint] -> PV a -> P a
runPV_hints [Hint]
hints (PV (LocatedA (PatBuilder GhcPs))
pp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat)

checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: LocatedA (PatBuilder GhcPs)
e@(L SrcSpanAnnA
l PatBuilder GhcPs
_) = SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
l LocatedA (PatBuilder GhcPs)
e [] []

checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]
         -> PV (LPat GhcPs)
checkPat :: SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpanAnnN
ln RdrName
c))) [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
args
  | RdrName -> Bool
isRdrDataCon RdrName
c = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ ConPat
      { pat_con_ext :: XConPat GhcPs
pat_con_ext = forall a. EpAnn a
noAnn -- AZ: where should this come from?
      , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ln RdrName
c
      , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
args
      }
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsPatSigType GhcPs]
tyargs) =
      forall a. Hint -> PV a -> PV a
add_hint Hint
TypeApplicationsInPatternsOnlyDataCons forall a b. (a -> b) -> a -> b
$
      forall a. SrcSpan -> SDoc -> PV a
patFail (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep [String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr HsPatSigType GhcPs
t | HsPatSigType GhcPs
t <- [HsPatSigType GhcPs]
tyargs])
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec RdrName
c =
      forall a. Hint -> PV a -> PV a
add_hint Hint
SuggestRecursiveDo forall a b. (a -> b) -> a -> b
$
      forall a. SrcSpan -> SDoc -> PV a
patFail (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e)
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
_ (PatBuilderAppType LocatedA (PatBuilder GhcPs)
f HsPatSigType GhcPs
t)) [HsPatSigType GhcPs]
tyargs [LPat GhcPs]
args =
  SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
f (HsPatSigType GhcPs
t forall a. a -> [a] -> [a]
: [HsPatSigType GhcPs]
tyargs) [LPat GhcPs]
args
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
_ (PatBuilderApp LocatedA (PatBuilder GhcPs)
f LocatedA (PatBuilder GhcPs)
e)) [] [LPat GhcPs]
args = do
  GenLocated SrcSpanAnnA (Pat GhcPs)
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
  SrcSpanAnnA
-> LocatedA (PatBuilder GhcPs)
-> [HsPatSigType GhcPs]
-> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
f [] (GenLocated SrcSpanAnnA (Pat GhcPs)
p forall a. a -> [a] -> [a]
: [LPat GhcPs]
args)
checkPat SrcSpanAnnA
loc (L SrcSpanAnnA
l PatBuilder GhcPs
e) [] [] = do
  Pat GhcPs
p <- SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpanAnnA
loc PatBuilder GhcPs
e
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcPs
p)
checkPat SrcSpanAnnA
loc LocatedA (PatBuilder GhcPs)
e [HsPatSigType GhcPs]
_ [LPat GhcPs]
_ = forall a. SrcSpan -> SDoc -> PV a
patFail (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (forall a. Outputable a => a -> SDoc
ppr LocatedA (PatBuilder GhcPs)
e)

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

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
   -- NB. Negative *primitive* literals are already handled by the lexer
   PatBuilderOverLit HsOverLit GhcPs
pos_lit -> forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs
mkNPat (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsOverLit GhcPs
pos_lit) forall a. Maybe a
Nothing forall a. EpAnn a
noAnn)

   -- n+k patterns
   PatBuilderOpApp
           (L SrcSpanAnnA
_ (PatBuilderVar (L SrcSpanAnnN
nloc RdrName
n)))
           (L SrcSpanAnnN
l RdrName
plus)
           (L SrcSpanAnnA
lloc (PatBuilderOverLit lit :: HsOverLit GhcPs
lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral {}})))
           (EpAnn Anchor
anc [AddEpAnn]
_ EpAnnComments
cs)
                     | Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (RdrName
plus forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
                     -> forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
-> Located (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs
mkNPlusKPat (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc RdrName
n) (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
lloc) HsOverLit GhcPs
lit)
                                (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc (forall ann. SrcAnn ann -> EpaLocation
epaLocationFromSrcAnn SrcSpanAnnN
l) EpAnnComments
cs))

   -- Improve error messages for the @-operator when the user meant an @-pattern
   PatBuilderOpApp LocatedA (PatBuilder GhcPs)
_ GenLocated SrcSpanAnnN RdrName
op LocatedA (PatBuilder GhcPs)
_ EpAnn [AddEpAnn]
_ | RdrName -> Bool
opIsAt (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
op) -> do
     forall (m :: * -> *). MonadP m => PsError -> m ()
addError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError PsErrorDesc
PsErrAtInPatPos [] (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnN RdrName
op)
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XWildPat p -> Pat p
WildPat NoExtField
noExtField)

   PatBuilderOpApp LocatedA (PatBuilder GhcPs)
l (L SrcSpanAnnN
cl RdrName
c) LocatedA (PatBuilder GhcPs)
r EpAnn [AddEpAnn]
anns
     | RdrName -> Bool
isRdrDataCon RdrName
c -> do
         GenLocated SrcSpanAnnA (Pat GhcPs)
l <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
l
         GenLocated SrcSpanAnnA (Pat GhcPs)
r <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
r
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
           { pat_con_ext :: XConPat GhcPs
pat_con_ext = EpAnn [AddEpAnn]
anns
           , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
cl RdrName
c
           , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnA (Pat GhcPs)
l GenLocated SrcSpanAnnA (Pat GhcPs)
r
           }

   PatBuilderPar LocatedA (PatBuilder GhcPs)
e an :: AnnParen
an@(AnnParen ParenType
pt EpaLocation
o EpaLocation
c) -> do
     (L SrcSpanAnnA
l Pat GhcPs
p) <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat LocatedA (PatBuilder GhcPs)
e
     let aa :: [AddEpAnn]
aa = [AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
ai EpaLocation
o, AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
ac EpaLocation
c]
         (AnnKeywordId
ai,AnnKeywordId
ac) = ParenType -> (AnnKeywordId, AnnKeywordId)
parenTypeKws ParenType
pt
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XParPat p -> LPat p -> Pat p
ParPat (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor forall a b. (a -> b) -> a -> b
$ (SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) [AddEpAnn]
aa)) AnnParen
an EpAnnComments
emptyComments) (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcPs
p))
   PatBuilder GhcPs
_           -> forall a. SrcSpan -> SDoc -> PV a
patFail (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e0)

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

plus_RDR, pun_RDR :: RdrName
plus_RDR :: RdrName
plus_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"+") -- Hack
pun_RDR :: RdrName
pun_RDR  = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pun-right-hand-side")

checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
              -> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (L SrcSpanAnnA
l HsRecField' (FieldOcc GhcPs) (LocatedA (PatBuilder GhcPs))
fld) = do GenLocated SrcSpanAnnA (Pat GhcPs)
p <- LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (FieldOcc GhcPs) (LocatedA (PatBuilder GhcPs))
fld)
                             forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField' (FieldOcc GhcPs) (LocatedA (PatBuilder GhcPs))
fld { hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat GhcPs)
hsRecFieldArg = GenLocated SrcSpanAnnA (Pat GhcPs)
p }))

patFail :: SrcSpan -> SDoc -> PV a
patFail :: forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc SDoc
e = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (SDoc -> PsErrorDesc
PsErrParseErrorInPat SDoc
e) [] SrcSpan
loc

patIsRec :: RdrName -> Bool
patIsRec :: RdrName -> Bool
patIsRec RdrName
e = RdrName
e forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"rec")

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

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

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

checkValDef SrcSpan
loc LocatedA (PatBuilder GhcPs)
lhs Maybe (AddEpAnn, LHsType GhcPs)
Nothing Located (GRHSs GhcPs (LHsExpr GhcPs))
g
  = do  { Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder GhcPs)], [AddEpAnn])
mb_fun <- LocatedA (PatBuilder GhcPs)
-> P (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder GhcPs)], [AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
lhs
        ; case Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder GhcPs)], [AddEpAnn])
mb_fun of
            Just (GenLocated SrcSpanAnnN RdrName
fun, LexicalFixity
is_infix, [LocatedA (PatBuilder GhcPs)]
pats, [AddEpAnn]
ann) ->
              SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> GenLocated SrcSpanAnnN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
NoSrcStrict SrcSpan
loc [AddEpAnn]
ann
                           GenLocated SrcSpanAnnN RdrName
fun LexicalFixity
is_infix [LocatedA (PatBuilder GhcPs)]
pats Located (GRHSs GhcPs (LHsExpr GhcPs))
g
            Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder GhcPs)], [AddEpAnn])
Nothing -> do
              GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' <- LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern LocatedA (PatBuilder GhcPs)
lhs
              SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc [] GenLocated SrcSpanAnnA (Pat GhcPs)
lhs' Located (GRHSs GhcPs (LHsExpr GhcPs))
g }

checkFunBind :: SrcStrictness
             -> SrcSpan
             -> [AddEpAnn]
             -> LocatedN RdrName
             -> LexicalFixity
             -> [LocatedA (PatBuilder GhcPs)]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P (HsBind GhcPs)
checkFunBind :: SrcStrictness
-> SrcSpan
-> [AddEpAnn]
-> GenLocated SrcSpanAnnN RdrName
-> LexicalFixity
-> [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
strictness SrcSpan
locF [AddEpAnn]
ann GenLocated SrcSpanAnnN RdrName
fun LexicalFixity
is_infix [LocatedA (PatBuilder GhcPs)]
pats (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss)
  = do  [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps <- forall a. [Hint] -> PV a -> P a
runPV_hints [Hint]
param_hints (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [LocatedA (PatBuilder GhcPs)]
pats)
        let match_span :: SrcSpanAnnA
match_span = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan forall a b. (a -> b) -> a -> b
$ SrcSpan
locF
        EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
locF
        forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind GenLocated SrcSpanAnnN RdrName
fun (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
match_span)
                 [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
match_span (Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
locF) [AddEpAnn]
ann EpAnnComments
cs
                                      , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs
                                          { mc_fun :: LIdP GhcPs
mc_fun    = GenLocated SrcSpanAnnN RdrName
fun
                                          , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
                                          , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
                                      , m_pats :: [LPat GhcPs]
m_pats = [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps
                                      , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss })]))
        -- The span of the match covers the entire equation.
        -- That isn't quite right, but it'll do for now.
  where
    param_hints :: [Hint]
param_hints
      | LexicalFixity
Infix <- LexicalFixity
is_infix = [RdrName -> Hint
SuggestInfixBindMaybeAtPat (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
fun)]
      | Bool
otherwise         = []

makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
            -> HsBind GhcPs
-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
makeFunBind :: GenLocated SrcSpanAnnN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind GenLocated SrcSpanAnnN RdrName
fn LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
ms
  = FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = NoExtField
noExtField,
              fun_id :: LIdP GhcPs
fun_id = GenLocated SrcSpanAnnN RdrName
fn,
              fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
FromSource LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
ms,
              fun_tick :: [CoreTickish]
fun_tick = [] }

-- See Note [FunBind vs PatBind]
checkPatBind :: SrcSpan
             -> [AddEpAnn]
             -> LPat GhcPs
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P (HsBind GhcPs)
checkPatBind :: SrcSpan
-> [AddEpAnn]
-> LPat GhcPs
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBindLR GhcPs GhcPs)
checkPatBind SrcSpan
loc [AddEpAnn]
annsIn (L SrcSpanAnnA
_ (BangPat (EpAnn Anchor
_ [AddEpAnn]
ans EpAnnComments
cs) (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
v))))
                        (L SrcSpan
_match_span GRHSs GhcPs (LHsExpr GhcPs)
grhss)
      = forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN RdrName
-> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind LIdP GhcPs
v (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
                [forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (EpAnn [AddEpAnn]
-> LIdP GhcPs
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) ([AddEpAnn]
ansforall a. [a] -> [a] -> [a]
++[AddEpAnn]
annsIn) EpAnnComments
cs) LIdP GhcPs
v)]))
  where
    m :: EpAnn [AddEpAnn]
-> LIdP GhcPs
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m EpAnn [AddEpAnn]
a LIdP GhcPs
v = Match { m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = EpAnn [AddEpAnn]
a
                  , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs { mc_fun :: LIdP GhcPs
mc_fun    = LIdP GhcPs
v
                                    , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                    , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict }
                  , m_pats :: [LPat GhcPs]
m_pats = []
                 , m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss }

checkPatBind SrcSpan
loc [AddEpAnn]
annsIn LPat GhcPs
lhs (L SrcSpan
_ GRHSs GhcPs (LHsExpr GhcPs)
grhss) = do
  EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
loc
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([CoreTickish], [[CoreTickish]])
-> HsBindLR idL idR
PatBind (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc) [AddEpAnn]
annsIn EpAnnComments
cs) LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss ([],[]))

checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (GenLocated SrcSpanAnnN RdrName)
checkValSigLhs (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ lrdr :: LIdP GhcPs
lrdr@(L SrcSpanAnnN
_ RdrName
v)))
  | RdrName -> Bool
isUnqual RdrName
v
  , Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc RdrName
v))
  = forall (m :: * -> *) a. Monad m => a -> m a
return LIdP GhcPs
lrdr

checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpanAnnA
l HsExpr GhcPs
_)
  = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError (LHsExpr GhcPs -> PsErrorDesc
PsErrInvalidTypeSignature LHsExpr GhcPs
lhs) [] (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)

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

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadP m => PsError -> m ()
addError (PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError PsErrorDesc
e [] SrcSpan
loc)
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

isFunLhs :: LocatedA (PatBuilder GhcPs)
      -> P (Maybe (LocatedN RdrName, LexicalFixity,
                   [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder GhcPs)], [AddEpAnn]))
isFunLhs LocatedA (PatBuilder GhcPs)
e = forall {m :: * -> *} {p}.
Monad m =>
LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder p)], [AddEpAnn]))
go LocatedA (PatBuilder GhcPs)
e [] [] []
 where
   go :: LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder p)], [AddEpAnn]))
go (L SrcSpanAnnA
_ (PatBuilderVar (L SrcSpanAnnN
loc RdrName
f))) [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps
       | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f)        = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc RdrName
f, LexicalFixity
Prefix, [LocatedA (PatBuilder p)]
es, (forall a. [a] -> [a]
reverse [AddEpAnn]
ops) forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps))
   go (L SrcSpanAnnA
_ (PatBuilderApp LocatedA (PatBuilder p)
f LocatedA (PatBuilder p)
e)) [LocatedA (PatBuilder p)]
es       [AddEpAnn]
ops [AddEpAnn]
cps = LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder p)], [AddEpAnn]))
go LocatedA (PatBuilder p)
f (LocatedA (PatBuilder p)
eforall a. a -> [a] -> [a]
:[LocatedA (PatBuilder p)]
es) [AddEpAnn]
ops [AddEpAnn]
cps
   go (L SrcSpanAnnA
l (PatBuilderPar LocatedA (PatBuilder p)
e AnnParen
_)) es :: [LocatedA (PatBuilder p)]
es@(LocatedA (PatBuilder p)
_:[LocatedA (PatBuilder p)]
_) [AddEpAnn]
ops [AddEpAnn]
cps
                                      = let
                                          (AddEpAnn
o,AddEpAnn
c) = RealSrcSpan -> (AddEpAnn, AddEpAnn)
mkParensEpAnn (SrcSpan -> RealSrcSpan
realSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
                                        in
                                          LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder p)], [AddEpAnn]))
go LocatedA (PatBuilder p)
e [LocatedA (PatBuilder p)]
es (AddEpAnn
oforall a. a -> [a] -> [a]
:[AddEpAnn]
ops) (AddEpAnn
cforall a. a -> [a] -> [a]
:[AddEpAnn]
cps)
   go (L SrcSpanAnnA
loc (PatBuilderOpApp LocatedA (PatBuilder p)
l (L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder p)
r (EpAnn Anchor
loca [AddEpAnn]
anns EpAnnComments
cs))) [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps
        | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)         -- We have found the function!
        = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op, LexicalFixity
Infix, (LocatedA (PatBuilder p)
lforall a. a -> [a] -> [a]
:LocatedA (PatBuilder p)
rforall a. a -> [a] -> [a]
:[LocatedA (PatBuilder p)]
es), ([AddEpAnn]
anns forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [AddEpAnn]
ops forall a. [a] -> [a] -> [a]
++ [AddEpAnn]
cps)))
        | Bool
otherwise                     -- Infix data con; keep going
        = do { Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder p)], [AddEpAnn])
mb_l <- LocatedA (PatBuilder p)
-> [LocatedA (PatBuilder p)]
-> [AddEpAnn]
-> [AddEpAnn]
-> m (Maybe
        (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
         [LocatedA (PatBuilder p)], [AddEpAnn]))
go LocatedA (PatBuilder p)
l [LocatedA (PatBuilder p)]
es [AddEpAnn]
ops [AddEpAnn]
cps
             ; case Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder p)], [AddEpAnn])
mb_l of
                 Just (GenLocated SrcSpanAnnN RdrName
op', LexicalFixity
Infix, LocatedA (PatBuilder p)
j : LocatedA (PatBuilder p)
k : [LocatedA (PatBuilder p)]
es', [AddEpAnn]
anns')
                   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN RdrName
op', LexicalFixity
Infix, LocatedA (PatBuilder p)
j forall a. a -> [a] -> [a]
: LocatedA (PatBuilder p)
op_app forall a. a -> [a] -> [a]
: [LocatedA (PatBuilder p)]
es', [AddEpAnn]
anns'))
                   where
                     op_app :: LocatedA (PatBuilder p)
op_app = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall p.
LocatedA (PatBuilder p)
-> GenLocated SrcSpanAnnN RdrName
-> LocatedA (PatBuilder p)
-> EpAnn [AddEpAnn]
-> PatBuilder p
PatBuilderOpApp LocatedA (PatBuilder p)
k
                               (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
op) LocatedA (PatBuilder p)
r (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
loca (forall a. [a] -> [a]
reverse [AddEpAnn]
opsforall a. [a] -> [a] -> [a]
++[AddEpAnn]
cps) EpAnnComments
cs))
                 Maybe
  (GenLocated SrcSpanAnnN RdrName, LexicalFixity,
   [LocatedA (PatBuilder p)], [AddEpAnn])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
   go LocatedA (PatBuilder p)
_ [LocatedA (PatBuilder p)]
_ [AddEpAnn]
_ [AddEpAnn]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy EpAnn [AddEpAnn]
anns SrcStrictness
strictness =
  forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy EpAnn [AddEpAnn]
anns (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness)

-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
  UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness

-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP :: forall (m :: * -> *).
MonadP m =>
Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP (L SrcSpan
lprag (UnpackednessPragma [AddEpAnn]
anns SourceText
prag SrcUnpackedness
unpk)) LHsType GhcPs
ty = do
    let l' :: SrcSpan
l' = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lprag (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsType GhcPs
ty)
    EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l'
    let an :: EpAnn [AddEpAnn]
an = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l') [AddEpAnn]
anns EpAnnComments
cs
        t' :: HsType GhcPs
t' = EpAnn [AddEpAnn]
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
addUnpackedness EpAnn [AddEpAnn]
an LHsType GhcPs
ty
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l') HsType GhcPs
t')
  where
    -- If we have a HsBangTy that only has a strictness annotation,
    -- such as ~T or !T, then add the pragma to the existing HsBangTy.
    --
    -- Otherwise, wrap the type in a new HsBangTy constructor.
    addUnpackedness :: EpAnn [AddEpAnn]
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
addUnpackedness EpAnn [AddEpAnn]
an (L SrcSpanAnnA
_ (HsBangTy XBangTy GhcPs
x HsSrcBang
bang LHsType GhcPs
t))
      | HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness <- HsSrcBang
bang
      = forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy (EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
addAnns EpAnn [AddEpAnn]
an (EpAnn [AddEpAnn] -> [AddEpAnn]
epAnnAnns XBangTy GhcPs
x) (forall ann. EpAnn ann -> EpAnnComments
epAnnComments XBangTy GhcPs
x)) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
strictness) LHsType GhcPs
t
    addUnpackedness EpAnn [AddEpAnn]
an GenLocated SrcSpanAnnA (HsType GhcPs)
t
      = forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy EpAnn [AddEpAnn]
an (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict) GenLocated SrcSpanAnnA (HsType GhcPs)
t

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

checkMonadComp :: PV (HsStmtContext GhcRn)
checkMonadComp :: PV (HsStmtContext GhcRn)
checkMonadComp = do
    Bool
monadComprehensions <- forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
MonadComprehensionsBit
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
monadComprehensions
                then forall p. HsStmtContext p
MonadComp
                else forall p. HsStmtContext p
ListComp

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

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

ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp LHsExpr GhcPs
a = (forall b. DisambECP b => PV (LocatedA b)) -> ECP
ECP (forall b. DisambECP b => LHsExpr GhcPs -> PV (LocatedA b)
ecpFromExp' LHsExpr GhcPs
a)

ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd LHsCmd GhcPs
a = (forall b. DisambECP b => PV (LocatedA b)) -> ECP
ECP (forall b. DisambECP b => LHsCmd GhcPs -> PV (LocatedA b)
ecpFromCmd' LHsCmd GhcPs
a)

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

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

instance DisambInfixOp (HsExpr GhcPs) where
  mkHsVarOpPV :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsVarOpPV GenLocated SrcSpanAnnN RdrName
v = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnN RdrName
v) (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField GenLocated SrcSpanAnnN RdrName
v)
  mkHsConOpPV :: GenLocated SrcSpanAnnN RdrName -> PV (LocatedN (HsExpr GhcPs))
mkHsConOpPV GenLocated SrcSpanAnnN RdrName
v = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnN RdrName
v) (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField GenLocated SrcSpanAnnN RdrName
v)
  mkHsInfixHolePV :: SrcSpan
-> (EpAnnComments -> EpAnn EpAnnUnboundVar)
-> PV (Located (HsExpr GhcPs))
mkHsInfixHolePV SrcSpan
l EpAnnComments -> EpAnn EpAnnUnboundVar
ann = do
    EpAnnComments
cs <- forall (m :: * -> *). MonadP m => SrcSpan -> m EpAnnComments
getCommentsFor SrcSpan
l
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
l (EpAnn EpAnnUnboundVar -> HsExpr GhcPs
hsHoleExpr (EpAnnComments -> EpAnn EpAnnUnboundVar
ann EpAnnComments
cs))

instance DisambInfixOp RdrName where
  mkHsConOpPV :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
mkHsConOpPV (L SrcSpanAnnN
l RdrName
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
  mkHsVarOpPV :: GenLocated SrcSpanAnnN RdrName
-> PV (GenLocated SrcSpanAnnN RdrName)
mkHsVarOpPV (L SrcSpanAnnN
l RdrName
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v
  mkHsInfixHolePV :: SrcSpan
-> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located RdrName)
mkHsInfixHolePV SrcSpan
l EpAnnComments -> EpAnn EpAnnUnboundVar
_ = forall (m :: * -> *) a. MonadP m => PsError -> m a
addFatalError forall a b. (a -> b) -> a -> b
$ PsErrorDesc -> [Hint] -> SrcSpan -> PsError
PsError PsErrorDesc
PsErrInvalidInfixHole [] SrcSpan
l

type AnnoBody b
  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan
    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL
    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
    , Anno [LocatedA (StmtLR GhcPs GhcPs
                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL
    )

-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
-- parsing an expression, a command, or a pattern.
-- See Note [Ambiguous syntactic categories]
class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
  -- | See Note [Body in DisambECP]
  type Body b :: Type -> Type
  -- | Return a command without ambiguity, or fail in a non-command context.
  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
  -- | Return an expression without ambiguity, or fail in a non-expression context.
  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
  mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]
    -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
  -- | Disambiguate "\... -> ..." (lambda)
  mkHsLamPV
    :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)
  -- | Disambiguate "let ... in ..."
  mkHsLetPV
    :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b)
  -- | Infix operator representation
  type InfixOp b
  -- | Bring superclass constraints on InfixOp into scope.
  -- See Note [UndecidableSuperClasses for associated types]
  superInfixOp
    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)
  -- | Disambiguate "f # x" (infix operator)
  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b
              -> PV (LocatedA b)
  -- | Disambiguate "case ... of ..."
  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
             -> EpAnnHsCase -> PV (LocatedA b)
  mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])
                -> [AddEpAnn]
                -> PV (LocatedA b)
  -- | Function argument representation
  type FunArg b
  -- | Bring superclass constraints on FunArg into scope.
  -- See Note [UndecidableSuperClasses for associated types]
  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)
  -- | Disambiguate "f x" (function application)
  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)
  -- | Disambiguate "f @t" (visible type application)
  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA