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

-- Functions over HsSyn specialised to RdrName.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

module GHC.Parser.PostProcess (
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkSpliceDecl,
        mkRoleAnnotDecl,
        mkClassDecl,
        mkTyData, mkDataFamInst,
        mkTySynonym, mkTyFamInstEqn,
        mkStandaloneKindSig,
        mkTyFamInst,
        mkFamDecl, mkLHsSigType,
        mkInlinePragma,
        mkPatSynMatchGroup,
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
        mkTyClD, mkInstD,
        mkRdrRecordCon, mkRdrRecordUpd,
        setRdrNameSpace,
        filterCTuple,
        fromSpecTyVarBndr, fromSpecTyVarBndrs,

        cvBindGroup,
        cvBindsAndSigs,
        cvTopDecls,
        placeHolderPunRhs,

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

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

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

        -- Token symbols
        forallSym,
        starSym,

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

        SumOrTuple (..),

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

import GHC.Prelude
import GHC.Hs           -- Lots of it
import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon        ( DataCon, dataConTyCon )
import GHC.Core.ConLike        ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Parser.Lexer
import GHC.Utils.Lexeme ( isLexCon )
import GHC.Core.Type    ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
                          listTyConName, listTyConKey, eqTyCon_RDR,
                          tupleTyConName, cTupleTyConNameArity_maybe )
import GHC.Types.ForeignCall
import GHC.Builtin.Names ( allNameStrings )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList ( OrdList, fromOL )
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Parser.Annotation
import Data.List
import GHC.Driver.Session ( WarningFlag(..), DynFlags )
import GHC.Utils.Error ( Messages )

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

#include "HsVersions.h"


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

  Construction functions for Rdr stuff

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

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

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

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

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

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

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

mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls LayoutInfo
layoutInfo
  = do { (LHsBinds GhcPs
binds, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
ats, [LTyFamInstDecl GhcPs]
at_defs, [LDataFamInstDecl GhcPs]
_, [LDocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
       ; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs
forall e. e -> Located e
noLoc []) Maybe (LHsContext GhcPs)
mcxt
       ; (Located RdrName
cls, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (LHsQTyVars GhcPs
tyvars,[AddAnn]
annst) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text String
"class") SDoc
whereDots Located RdrName
cls [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
annst -- Add any API Annotations to the top SrcSpan
       ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = LayoutInfo
XClassDecl GhcPs
layoutInfo
                                  , tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt
                                  , tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
                                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
                                  , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = (a, [Located (FunDep (Located RdrName))])
-> [Located (FunDep (Located RdrName))]
forall a b. (a, b) -> b
snd (GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))])
-> (a, [Located (FunDep (Located RdrName))])
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))])
Located (a, [LHsFunDep GhcPs])
fds)
                                  , tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [LSig GhcPs]
sigs
                                  , tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
binds
                                  , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs
                                  , tcdDocs :: [LDocDecl]
tcdDocs  = [LDocDecl]
docs })) }

mkTyData :: SrcSpan
         -> NewOrData
         -> Maybe (Located CType)
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> HsDeriving GhcPs
         -> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr))
         Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
  = do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (NewOrData -> SDoc
forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns -- Add any API Annotations to the top SrcSpan
       ; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
       ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = NoExtField
XDataDecl GhcPs
noExtField,
                                   tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
                                   tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
                                   tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }

mkDataDefn :: NewOrData
           -> Maybe (Located CType)
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
  = do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
       ; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs
forall e. e -> Located e
noLoc []) Maybe (LHsContext GhcPs)
mcxt
       ; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
                            , dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
                            , dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
cxt
                            , dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
data_cons
                            , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
                            , dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }


mkTySynonym :: SrcSpan
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs
  = do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text String
"type") SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns -- Add any API Annotations to the top SrcSpan
       ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = NoExtField
XSynDecl GhcPs
noExtField
                                , tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
                                , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
                                , tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }

mkStandaloneKindSig
  :: SrcSpan
  -> Located [Located RdrName] -- LHS
  -> LHsKind GhcPs             -- RHS
  -> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [Located RdrName]
-> LHsType GhcPs
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [Located RdrName]
lhs LHsType GhcPs
rhs =
  do { [Located RdrName]
vs <- (Located RdrName -> P (Located RdrName))
-> [Located RdrName] -> P [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located RdrName -> P (Located RdrName)
forall {m :: * -> *}.
MonadP m =>
Located RdrName -> m (Located RdrName)
check_lhs_name (Located [Located RdrName] -> [Located RdrName]
forall l e. GenLocated l e -> e
unLoc Located [Located RdrName]
lhs)
     ; Located RdrName
v <- [Located RdrName] -> P (Located RdrName)
check_singular_lhs ([Located RdrName] -> [Located RdrName]
forall a. [a] -> [a]
reverse [Located RdrName]
vs)
     ; LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs))
-> LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs)
-> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs
forall a b. (a -> b) -> a -> b
$ XStandaloneKindSig GhcPs
-> Located (IdP GhcPs)
-> LHsSigType GhcPs
-> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
XStandaloneKindSig GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
rhs) }
  where
    check_lhs_name :: Located RdrName -> m (Located RdrName)
check_lhs_name v :: Located RdrName
v@(Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc->RdrName
name) =
      if RdrName -> Bool
isUnqual RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc RdrName
name)
      then Located RdrName -> m (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
v
      else SrcSpan -> SDoc -> m (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
v) (SDoc -> m (Located RdrName)) -> SDoc -> m (Located RdrName)
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Expected an unqualified type constructor:") Int
2 (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
v)
    check_singular_lhs :: [Located RdrName] -> P (Located RdrName)
check_singular_lhs [Located RdrName]
vs =
      case [Located RdrName]
vs of
        [] -> String -> P (Located RdrName)
forall a. String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
        [Located RdrName
v] -> Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
v
        [Located RdrName]
_ -> SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located [Located RdrName] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [Located RdrName]
lhs) (SDoc -> P (Located RdrName)) -> SDoc -> P (Located RdrName)
forall a b. (a -> b) -> a -> b
$
             [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Standalone kind signatures do not support multiple names at the moment:")
                       Int
2 ((Located RdrName -> SDoc) -> [Located RdrName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located RdrName]
vs)
                  , String -> SDoc
text String
"See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]

mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
               -> LHsType GhcPs
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs, [AddAnn])
mkTyFamInstEqn Maybe [LHsTyVarBndr () GhcPs]
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs
  = do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                  (FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs)
feqn_ext    = NoExtField
XCFamEqn GhcPs (LHsType GhcPs)
noExtField
                          , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon  = Located RdrName
Located (IdP GhcPs)
tc
                          , feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs  = Maybe [LHsTyVarBndr () GhcPs]
bndrs
                          , feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats   = [LHsTypeArg GhcPs]
tparams
                          , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                          , feqn_rhs :: LHsType GhcPs
feqn_rhs    = LHsType GhcPs
rhs }),
                 [AddAnn]
ann) }

mkDataFamInst :: SrcSpan
              -> NewOrData
              -> Maybe (Located CType)
              -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs]
                        , LHsType GhcPs)
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs],
    LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Maybe (LHsContext GhcPs)
mcxt, Maybe [LHsTyVarBndr () GhcPs]
bndrs, LHsType GhcPs
tycl_hdr)
              Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
  = do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
       ; LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD NoExtField
XDataFamInstD GhcPs
noExtField (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl (FamEqn GhcPs (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                  (FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext    = NoExtField
XCFamEqn GhcPs (HsDataDefn GhcPs)
noExtField
                          , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon  = Located RdrName
Located (IdP GhcPs)
tc
                          , feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs  = Maybe [LHsTyVarBndr () GhcPs]
bndrs
                          , feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats   = [LHsTypeArg GhcPs]
tparams
                          , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                          , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs    = HsDataDefn GhcPs
defn }))))) }

mkTyFamInst :: SrcSpan
            -> TyFamInstEqn GhcPs
            -> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn
  = LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
XTyFamInstD GhcPs
noExtField (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl TyFamInstEqn GhcPs
eqn)))

mkFamDecl :: SrcSpan
          -> FamilyInfo GhcPs
          -> LHsType GhcPs                   -- LHS
          -> Located (FamilyResultSig GhcPs) -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info LHsType GhcPs
lhs Located (FamilyResultSig GhcPs)
ksig Maybe (LInjectivityAnn GhcPs)
injAnn
  = do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (FamilyInfo GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamilyInfo GhcPs
info) SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns -- Add any API Annotations to the top SrcSpan
       ; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcPs
noExtField (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl
                                           { fdExt :: XCFamilyDecl GhcPs
fdExt       = NoExtField
XCFamilyDecl GhcPs
noExtField
                                           , fdInfo :: FamilyInfo GhcPs
fdInfo      = FamilyInfo GhcPs
info, fdLName :: Located (IdP GhcPs)
fdLName = Located RdrName
Located (IdP GhcPs)
tc
                                           , fdTyVars :: LHsQTyVars GhcPs
fdTyVars    = LHsQTyVars GhcPs
tyvars
                                           , fdFixity :: LexicalFixity
fdFixity    = LexicalFixity
fixity
                                           , fdResultSig :: Located (FamilyResultSig GhcPs)
fdResultSig = Located (FamilyResultSig GhcPs)
ksig
                                           , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injAnn }))) }
  where
    equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
                        FamilyInfo GhcPs
DataFamily          -> SDoc
empty
                        FamilyInfo GhcPs
OpenTypeFamily      -> SDoc
empty
                        ClosedTypeFamily {} -> SDoc
whereDots

mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
-- If the user wrote
--      [pads| ... ]   then return a QuasiQuoteD
--      $(e)           then return a SpliceD
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
--                     ie a SpliceD
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(L SrcSpan
loc HsExpr GhcPs
expr)
  | HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsUntypedSplice {}) <- HsExpr GhcPs
expr
  = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)

  | HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsQuasiQuote {}) <- HsExpr GhcPs
expr
  = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)

  | Bool
otherwise
  = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice SpliceDecoration
BareSplice LHsExpr GhcPs
lexpr))
                              SpliceExplicitFlag
ImplicitSplice)

mkRoleAnnotDecl :: SrcSpan
                -> Located RdrName                -- type being annotated
                -> [Located (Maybe FastString)]      -- roles
                -> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc Located RdrName
tycon [Located (Maybe FastString)]
roles
  = do { [GenLocated SrcSpan (Maybe Role)]
roles' <- (Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role)))
-> [Located (Maybe FastString)]
-> P [GenLocated SrcSpan (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
       ; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs))
-> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs)
-> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [GenLocated SrcSpan (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [GenLocated SrcSpan (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
XCRoleAnnotDecl GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
tycon [GenLocated SrcSpan (Maybe Role)]
roles' }
  where
    role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
    all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
    possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]

    parse_role :: Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (Maybe Role)
 -> P (GenLocated SrcSpan (Maybe Role)))
-> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc_role Maybe Role
forall a. Maybe a
Nothing
    parse_role (L SrcSpan
loc_role (Just FastString
role))
      = case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
          Just Role
found_role -> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (Maybe Role)
 -> P (GenLocated SrcSpan (Maybe Role)))
-> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc_role (Maybe Role -> GenLocated SrcSpan (Maybe Role))
-> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
          Maybe Role
Nothing         ->
            let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
                  ((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
            in
            SrcSpan -> SDoc -> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc_role
              (String -> SDoc
text String
"Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
               [Role] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)

    suggestions :: [a] -> SDoc
suggestions []   = SDoc
empty
    suggestions [a
r]  = String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r)
      -- will this last case ever happen??
    suggestions [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Perhaps you meant one of these:")
                       Int
2 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [a]
list)

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

-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without
-- annotations. Only accepts specified variables, and errors if the provided
-- binder has an 'InferredSpec' annotation.
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr LHsTyVarBndr Specificity GhcPs
bndr = case LHsTyVarBndr Specificity GhcPs
bndr of
  (L SrcSpan
loc (UserTyVar XUserTyVar GhcPs
xtv Specificity
flag Located (IdP GhcPs)
idp))     -> (Specificity -> SrcSpan -> P ()
check_spec Specificity
flag SrcSpan
loc)
                                          P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs)
-> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
xtv () Located (IdP GhcPs)
idp)
  (L SrcSpan
loc (KindedTyVar XKindedTyVar GhcPs
xtv Specificity
flag Located (IdP GhcPs)
idp LHsType GhcPs
k)) -> (Specificity -> SrcSpan -> P ()
check_spec Specificity
flag SrcSpan
loc)
                                          P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs)
-> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
xtv () Located (IdP GhcPs)
idp LHsType GhcPs
k)
  where
    check_spec :: Specificity -> SrcSpan -> P ()
    check_spec :: Specificity -> SrcSpan -> P ()
check_spec Specificity
SpecifiedSpec SrcSpan
_   = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    check_spec Specificity
InferredSpec  SrcSpan
loc = SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc
                                   (String -> SDoc
text String
"Inferred type variables are not allowed here")

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

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

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

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


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

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

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

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

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

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

getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (L SrcSpan
loc1 (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = fun_id1 :: Located (IdP GhcPs)
fun_id1@(L SrcSpan
_ IdP GhcPs
f1)
                             , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
                               MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1) } }))
            [LHsDecl GhcPs]
binds
  | [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1
  = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1 SrcSpan
loc1 [LHsDecl GhcPs]
binds []
  where
    go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc
       ((L SrcSpan
loc2 (ValD XValD GhcPs
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = (L SrcSpan
_ IdP GhcPs
f2)
                                 , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
                                    MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs2) } })))
         : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
        | RdrName
IdP GhcPs
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
IdP GhcPs
f2 = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go ([LMatch GhcPs (LHsExpr GhcPs)]
mtchs2 [LMatch GhcPs (LHsExpr GhcPs)]
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
                        (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds []
    go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(L SrcSpan
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
        = let doc_decls' :: [LHsDecl GhcPs]
doc_decls' = LHsDecl GhcPs
doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
          in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls'
    go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
        = ( SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
          , ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
        -- Reverse the final matches, to get it back in the right order
        -- Do the same thing with the trailing doc comments

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

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

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

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

  #PrefixToHS-utils# Utilities for conversion

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

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

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

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

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

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

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

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

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

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

To further complicate matters, the interpretation of (!) and (~) is different
in constructors and types:

  (b1)   type T = C ! D
  (b2)   data T = C ! D
  (b3)   data T = C ! D => E

In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At
the same time, in (b2) it is a strictness annotation: 'C' is a data constructor
with a single strict argument 'D'. For the programmer, these cases are usually
easy to tell apart due to whitespace conventions:

  (b2)   data T = C !D         -- no space after the bang hints that
                               -- it is a strictness annotation

For the parser, on the other hand, this whitespace does not matter. We cannot
tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited
lookahead.

The solution that accounts for all of these issues is to initially parse data
declarations and types as a reversed list of TyEl:

  data TyEl = TyElOpr RdrName
            | TyElOpd (HsType GhcPs)
            | ...

For example, both occurrences of (C ! D) in the following example are parsed
into equal lists of TyEl:

  data T = C ! D => C ! D   results in   [ TyElOpd (HsTyVar "D")
                                         , TyElOpr "!"
                                         , TyElOpd (HsTyVar "C") ]

Note that elements are in reverse order. Also, 'C' is parsed as a type
constructor (HsTyVar) even when it is a data constructor. We fix this in
`tyConToDataCon`.

By the time the list of TyEl is assembled, we have looked ahead enough to
decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for
data constructors). These functions are where the actual job of parsing is
done.

-}

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

  | Bool
otherwise
  = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
msg)
  where
    occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
    msg :: SDoc
msg = String -> SDoc
text String
"Not a data constructor:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
tc)

mkPatSynMatchGroup :: Located RdrName
                   -> Located (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpan
loc RdrName
patsyn_name) (L SrcSpan
_ OrdList (LHsDecl GhcPs)
decls) =
    do { [LMatch GhcPs (LHsExpr GhcPs)]
matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
       ; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
matches) (SrcSpan -> P ()
wrongNumberErr SrcSpan
loc)
       ; MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (LHsExpr GhcPs)
 -> P (MatchGroup GhcPs (LHsExpr GhcPs)))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
matches }
  where
    fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (L SrcSpan
loc decl :: HsDecl GhcPs
decl@(ValD XValD GhcPs
_ (PatBind XPatBind GhcPs GhcPs
_
                         pat :: LPat GhcPs
pat@(L SrcSpan
_ (ConPat NoExtField
XConPat GhcPs
NoExtField ln :: Located (ConLikeP GhcPs)
ln@(L SrcSpan
_ ConLikeP GhcPs
name) HsConPatDetails GhcPs
details))
                               GRHSs GhcPs (LHsExpr GhcPs)
rhs ([Tickish Id], [[Tickish Id]])
_))) =
        do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName
ConLikeP GhcPs
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
               SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl
           ; Match GhcPs (LHsExpr GhcPs)
match <- case HsConPatDetails GhcPs
details of
               PrefixCon [LPat GhcPs]
pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
                                                , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
                                                , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
                   where
                     ctxt :: HsMatchContext GhcPs
ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun = Located (IdP GhcPs)
Located (ConLikeP GhcPs)
ln
                                   , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                   , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }

               InfixCon LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
                                                , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt
                                                , m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs
p1, LPat GhcPs
p2]
                                                , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
                   where
                     ctxt :: HsMatchContext GhcPs
ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun = Located (IdP GhcPs)
Located (ConLikeP GhcPs)
ln
                                   , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
                                   , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }

               RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (LHsExpr GhcPs))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat
           ; LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Match GhcPs (LHsExpr GhcPs)
match }
    fromDecl (L SrcSpan
loc HsDecl GhcPs
decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
forall {m :: * -> *} {a} {a}.
(MonadP m, Outputable a) =>
SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc HsDecl GhcPs
decl

    extraDeclErr :: SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc a
decl =
        SrcSpan -> SDoc -> m a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> m a) -> SDoc -> m a
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text String
"pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc
$$
        a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl

    wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
      SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"pattern synonym 'where' clause must bind the pattern synonym's name"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
patsyn_name) SDoc -> SDoc -> SDoc
$$ HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDecl GhcPs
decl

    wrongNumberErr :: SrcSpan -> P ()
wrongNumberErr SrcSpan
loc =
      SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName
patsyn_name)

recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
    SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
    Located (Pat GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (Pat GhcPs)
LPat GhcPs
pat

mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
                -> ConDecl GhcPs

mkConDeclH98 :: Located RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
name Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
args
  = ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext    = NoExtField
XConDeclH98 GhcPs
noExtField
               , con_name :: Located (IdP GhcPs)
con_name   = Located RdrName
Located (IdP GhcPs)
name
               , con_forall :: Located Bool
con_forall = Bool -> Located Bool
forall e. e -> Located e
noLoc (Bool -> Located Bool) -> Bool -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall
               , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall a. Maybe a -> a -> a
`orElse` []
               , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
               , con_args :: HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
con_args   = HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
args
               , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }

-- | Construct a GADT-style data constructor from the constructor names and
-- their type. Some interesting aspects of this function:
--
-- * This splits up the constructor type into its quantified type variables (if
--   provided), context (if provided), argument types, and result type, and
--   records whether this is a prefix or record GADT constructor. See
--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: [Located RdrName]
           -> LHsType GhcPs
           -> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
names LHsType GhcPs
ty = do
  let (HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
args, LHsType GhcPs
res_ty, [AddAnn]
anns)
        | L SrcSpan
_ (HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
_w (L SrcSpan
loc (HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) <- LHsType GhcPs
body_ty
        = (GenLocated SrcSpan [LConDeclField GhcPs]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> [LConDeclField GhcPs]
-> GenLocated SrcSpan [LConDeclField GhcPs]
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc [LConDeclField GhcPs]
rf), LHsType GhcPs
res_ty, [])
        | Bool
otherwise
        = let ([HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type, [AddAnn]
anns) = LHsType GhcPs
-> ([HsScaled GhcPs (LHsType GhcPs)], LHsType GhcPs, [AddAnn])
forall (p :: Pass).
LHsType (GhcPass p)
-> ([HsScaled (GhcPass p) (LHsType (GhcPass p))],
    LHsType (GhcPass p), [AddAnn])
splitHsFunType LHsType GhcPs
body_ty
          in ([HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type, [AddAnn]
anns)

  (ConDecl GhcPs, [AddAnn]) -> P (ConDecl GhcPs, [AddAnn])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = NoExtField
XConDeclGADT GhcPs
noExtField
                     , con_names :: [Located (IdP GhcPs)]
con_names  = [Located RdrName]
[Located (IdP GhcPs)]
names
                     , con_forall :: Located Bool
con_forall = SrcSpan -> Bool -> Located Bool
forall l e. l -> e -> GenLocated l e
L (LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
ty) (Bool -> Located Bool) -> Bool -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs
                     , con_qvars :: [LHsTyVarBndr Specificity GhcPs]
con_qvars  = [LHsTyVarBndr Specificity GhcPs]
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs
                     , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
                     , con_args :: HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
con_args   = HsConDetails
  (HsScaled GhcPs (LHsType GhcPs))
  (GenLocated SrcSpan [LConDeclField GhcPs])
args
                     , con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
                     , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }
       , [AddAnn]
anns )
  where
    (Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsType GhcPs
-> (Maybe [LHsTyVarBndr Specificity GhcPs],
    Maybe (LHsContext GhcPs), LHsType GhcPs)
forall pass.
LHsType pass
-> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass),
    LHsType pass)
splitLHsGadtTy LHsType GhcPs
ty

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

  | Name -> Bool
isExternalName Name
n
  = Module -> OccName -> RdrName
Orig (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n) OccName
occ

  | Bool
otherwise   -- This can happen when quoting and then
                -- splicing a fixity declaration for a type
  = Name -> RdrName
Exact (Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt (Name -> Unique
nameUnique Name
n) OccName
occ (Name -> SrcSpan
nameSrcSpan Name
n))
  where
    occ :: OccName
occ = NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns (Name -> OccName
nameOccName Name
n)

setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon TyCon
tc) NameSpace
ns
  | NameSpace -> Bool
isDataConNameSpace NameSpace
ns
  = TyCon -> RdrName
ty_con_data_con TyCon
tc
  | NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
  = Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)      -- No-op

setWiredInNameSpace (AConLike (RealDataCon DataCon
dc)) NameSpace
ns
  | NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
  = DataCon -> RdrName
data_con_ty_con DataCon
dc
  | NameSpace -> Bool
isDataConNameSpace NameSpace
ns
  = Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)      -- No-op

setWiredInNameSpace TyThing
thing NameSpace
ns
  = String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)

ty_con_data_con :: TyCon -> RdrName
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con TyCon
tc
  | TyCon -> Bool
isTupleTyCon TyCon
tc
  , Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
  = Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)

  | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
listTyConKey
  = Name -> RdrName
Exact Name
nilDataConName

  | Bool
otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
srcDataName (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc))

data_con_ty_con :: DataCon -> RdrName
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con DataCon
dc
  | let tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
  , TyCon -> Bool
isTupleTyCon TyCon
tc
  = Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)

  | DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey
  = Name -> RdrName
Exact Name
listTyConName

  | Bool
otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tcClsName (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))

-- | Replaces constraint tuple names with corresponding boxed ones.
filterCTuple :: RdrName -> RdrName
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact Name
n)
  | Just Int
arity <- Name -> Maybe Int
cTupleTyConNameArity_maybe Name
n
  = Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ TupleSort -> Int -> Name
tupleTyConName TupleSort
BoxedTuple Int
arity
filterCTuple RdrName
rdr = RdrName
rdr


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

eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP :: forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (SrcSpan
loc, SDoc
doc)) = SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc SDoc
doc
eitherToP (Right a
thing)     = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return a
thing

checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
            -> P ( LHsQTyVars GhcPs  -- the synthesized type variables
                 , [AddAnn] )        -- action which adds annotations
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
checkTyVars :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars SDoc
pp_what SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparms
  = do { ([LHsTyVarBndr () GhcPs]
tvs, [[AddAnn]]
anns) <- ([(LHsTyVarBndr () GhcPs, [AddAnn])]
 -> ([LHsTyVarBndr () GhcPs], [[AddAnn]]))
-> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> P ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall a b. [(a, b)] -> ([a], [b])
unzip (P [(LHsTyVarBndr () GhcPs, [AddAnn])]
 -> P ([LHsTyVarBndr () GhcPs], [[AddAnn]]))
-> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> P ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall a b. (a -> b) -> a -> b
$ (LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> [LHsTypeArg GhcPs] -> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
check [LHsTypeArg GhcPs]
tparms
       ; (LHsQTyVars GhcPs, [AddAnn]) -> P (LHsQTyVars GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr () GhcPs]
tvs, [[AddAnn]] -> [AddAnn]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AddAnn]]
anns) }
  where
    check :: LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
check (HsTypeArg SrcSpan
_ ki :: LHsType GhcPs
ki@(L SrcSpan
loc HsKind GhcPs
_))
                              = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall a b. (a -> b) -> a -> b
$
                                      [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type application" SDoc -> SDoc -> SDoc
<+>
                                            String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
                                          , String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what SDoc -> SDoc -> SDoc
<+>
                                            PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)]
    check (HsValArg LHsType GhcPs
ty) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens [] LHsType GhcPs
ty
    check (HsArgPar SrcSpan
sp) = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
sp (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall a b. (a -> b) -> a -> b
$
                          [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Malformed" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)]
        -- Keep around an action for adjusting the annotations of extra parens
    chkParens :: [AddAnn] -> LHsType GhcPs
              -> P (LHsTyVarBndr () GhcPs, [AddAnn])
    chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens [AddAnn]
acc (L SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens (SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
acc) LHsType GhcPs
ty
    chkParens [AddAnn]
acc LHsType GhcPs
ty = do
      LHsTyVarBndr () GhcPs
tv <- LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk LHsType GhcPs
ty
      (LHsTyVarBndr () GhcPs, [AddAnn])
-> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsTyVarBndr () GhcPs
tv, [AddAnn] -> [AddAnn]
forall a. [a] -> [a]
reverse [AddAnn]
acc)

        -- Check that the name space is correct!
    chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
    chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk (L SrcSpan
l (HsKindSig XKindSig GhcPs
_ (L SrcSpan
lv (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tv))) LHsType GhcPs
k))
        | RdrName -> Bool
isRdrTyVar RdrName
IdP GhcPs
tv    = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar NoExtField
XKindedTyVar GhcPs
noExtField () (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv RdrName
IdP GhcPs
tv) LHsType GhcPs
k))
    chk (L SrcSpan
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
ltv IdP GhcPs
tv)))
        | RdrName -> Bool
isRdrTyVar RdrName
IdP GhcPs
tv    = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar NoExtField
XUserTyVar GhcPs
noExtField () (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
ltv RdrName
IdP GhcPs
tv)))
    chk t :: LHsType GhcPs
t@(L SrcSpan
loc HsKind GhcPs
_)
        = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P (LHsTyVarBndr () GhcPs))
-> SDoc -> P (LHsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
                     , String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                       SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
                     , [SDoc] -> SDoc
vcat[ (String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                              SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration should have form"))
                     , Int -> SDoc -> SDoc
nest Int
2
                       (SDoc
pp_what
                        SDoc -> SDoc -> SDoc
<+> SDoc
tc'
                        SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text ([LHsTypeArg GhcPs] -> [String] -> [String]
forall b a. [b] -> [a] -> [a]
takeList [LHsTypeArg GhcPs]
tparms [String]
allNameStrings))
                        SDoc -> SDoc -> SDoc
<+> SDoc
equals_or_where) ] ]

    -- Avoid printing a constraint tuple in the error message. Print
    -- a plain old tuple instead (since that's what the user probably
    -- wrote). See #14907
    tc' :: SDoc
tc' = Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Located RdrName -> SDoc) -> Located RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ (RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
filterCTuple Located RdrName
tc



whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
whereDots :: SDoc
whereDots  = String -> SDoc
text String
"where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text String
"= ..."

checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
Nothing = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just LHsContext GhcPs
c)
    = do Bool
allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DatatypeContextsBit
         Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
             SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (LHsContext GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsContext GhcPs
c)
                 (String -> SDoc
text String
"Illegal datatype context (use DatatypeContexts):"
                  SDoc -> SDoc -> SDoc
<+> LHsContext GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LHsContext (GhcPass p) -> SDoc
pprLHsContext LHsContext GhcPs
c)

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

-- turns RuleTyTmVars into RuleBnrs - this is straightforward
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> LRuleBndr GhcPs)
-> [LRuleTyTmVar] -> [LRuleBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
  where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing)    = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr    NoExtField
XCRuleBndr GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v
        cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig)) =
          XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig NoExtField
XRuleBndrSig GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType LHsType GhcPs
sig)

-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr () GhcPs)
-> [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> HsTyVarBndr () GhcPs)
-> LRuleTyTmVar -> LHsTyVarBndr () GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> HsTyVarBndr () GhcPs
cvt_one)
  where cvt_one :: RuleTyTmVar -> HsTyVarBndr () GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing)
          = XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar NoExtField
XUserTyVar GhcPs
noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v)
        cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig))
          = XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar NoExtField
XKindedTyVar GhcPs
noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v) LHsType GhcPs
sig
    -- takes something in namespace 'varName' to something in namespace 'tvName'
        tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
        tm_to_ty RdrName
_ = String -> RdrName
forall a. String -> a
panic String
"mkRuleTyVarBndrs"

-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = (GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> P ())
-> [GenLocated SrcSpan (HsTyVarBndr flag GhcPs)] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Located RdrName -> P ()
forall {f :: * -> *}. MonadP f => Located RdrName -> f ()
check (Located RdrName -> P ())
-> (GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName)
-> GenLocated SrcSpan (HsTyVarBndr flag GhcPs)
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr flag GhcPs -> RdrName)
-> GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr flag GhcPs -> RdrName
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
  where check :: Located RdrName -> f ()
check (L SrcSpan
loc (Unqual OccName
occ)) = do
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String
"forall",String
"family",String
"role"])
               (SrcSpan -> SDoc -> f ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"parse error on input "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
        check Located RdrName
_ = String -> f ()
forall a. String -> a
panic String
"checkRuleTyVarBndrNames"

checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax :: forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
Located a -> m (Located a)
checkRecordSyntax lr :: Located a
lr@(L SrcSpan
loc a
r)
    = do Bool
allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
         Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> m ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
loc (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal record syntax (use TraditionalRecordSyntax):" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r
         Located a -> m (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
lr

-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                -> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts@(L SrcSpan
span ([AddAnn]
_, []))           -- Empty GADT declaration.
    = do Bool
gadtSyntax <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit   -- GADTs implies GADTSyntax
         Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gadtSyntax (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
span (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
           [ String -> SDoc
text String
"Illegal keyword 'where' in data declaration"
           , String -> SDoc
text String
"Perhaps you intended to use GADTs or a similar language"
           , String -> SDoc
text String
"extension to enable syntax: data T where"
           ]
         Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
checkEmptyGADTs Located ([AddAnn], [LConDecl GhcPs])
gadts = Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts              -- Ordinary GADT declaration.

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

    -- workaround to define '*' despite StarIsType
    go :: SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
lp (HsParTy XParTy GhcPs
_ (L SrcSpan
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
      = do { SrcSpan -> P ()
warnStarBndr SrcSpan
l
           ; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
           ; (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (OccName -> RdrName
Unqual OccName
name), [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp)) }

    go SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: Located (IdP GhcPs)
ltc@(L SrcSpan
_ IdP GhcPs
tc)) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
      | RdrName -> Bool
isRdrTc RdrName
IdP GhcPs
tc               = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, [AddAnn]
ann)
    go SrcSpan
_ (HsOpTy XOpTy GhcPs
_ LHsType GhcPs
t1 ltc :: Located (IdP GhcPs)
ltc@(L SrcSpan
_ IdP GhcPs
tc) LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
_fix
      | RdrName -> Bool
isRdrTc RdrName
IdP GhcPs
tc               = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, [AddAnn]
ann)
    go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)    [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l) LexicalFixity
fix
    go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
t1 (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
    go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
    go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddAnn]
ann LexicalFixity
fix
      = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Name -> RdrName
nameRdrName Name
tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> [LHsTypeArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, [AddAnn]
ann)
      where
        arity :: Int
arity = [LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts
        tup_name :: Name
tup_name | Bool
is_cls    = Int -> Name
cTupleTyConName Int
arity
                 | Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
    go SrcSpan
l HsKind GhcPs
_ [LHsTypeArg GhcPs]
_ [AddAnn]
_ LexicalFixity
_
      = SrcSpan
-> SDoc
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (String -> SDoc
text String
"Malformed head of type or class declaration:"
                          SDoc -> SDoc -> SDoc
<+> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ty)

-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(LHsExpr GhcPs -> PV ()
checkExpBlockArguments, LHsCmd GhcPs -> PV ()
checkCmdBlockArguments) = (LHsExpr GhcPs -> PV ()
checkExpr, LHsCmd GhcPs -> PV ()
checkCmd)
  where
    checkExpr :: LHsExpr GhcPs -> PV ()
    checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr LHsExpr GhcPs
expr = do
     case LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
expr of
      HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
m) Located [ExprLStmt GhcPs]
_ -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (Maybe ModuleName -> SDoc -> SDoc
prependQualified Maybe ModuleName
m (String -> SDoc
text String
"do block")) LHsExpr GhcPs
expr
      HsDo XDo GhcPs
_ (MDoExpr Maybe ModuleName
m) Located [ExprLStmt GhcPs]
_ -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (Maybe ModuleName -> SDoc -> SDoc
prependQualified Maybe ModuleName
m (String -> SDoc
text String
"mdo block")) LHsExpr GhcPs
expr
      HsLam {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda expression") LHsExpr GhcPs
expr
      HsCase {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"case expression") LHsExpr GhcPs
expr
      HsLamCase {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda-case expression") LHsExpr GhcPs
expr
      HsLet {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"let expression") LHsExpr GhcPs
expr
      HsIf {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"if expression") LHsExpr GhcPs
expr
      HsProc {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"proc expression") LHsExpr GhcPs
expr
      HsExpr GhcPs
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkCmd :: LHsCmd GhcPs -> PV ()
    checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case LHsCmd GhcPs -> HsCmd GhcPs
forall l e. GenLocated l e -> e
unLoc LHsCmd GhcPs
cmd of
      HsCmdLam {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda command") LHsCmd GhcPs
cmd
      HsCmdCase {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"case command") LHsCmd GhcPs
cmd
      HsCmdIf {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"if command") LHsCmd GhcPs
cmd
      HsCmdLet {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"let command") LHsCmd GhcPs
cmd
      HsCmdDo {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"do command") LHsCmd GhcPs
cmd
      HsCmd GhcPs
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    check :: Outputable a => SDoc -> Located a -> PV ()
    check :: forall a. Outputable a => SDoc -> Located a -> PV ()
check SDoc
element Located a
a = do
      Bool
blockArguments <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
      Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$
        SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located a -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located a
a) (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Unexpected " SDoc -> SDoc -> SDoc
<> SDoc
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" in function application:"
           SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (Located a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located a
a)
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"You could write it with parentheses"
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Or perhaps you meant to enable BlockArguments?"

-- | Validate the context constraints and break up a context into a list
-- of predicates.
--
-- @
--     (Eq a, Ord b)        -->  [Eq a, Ord b]
--     Eq a                 -->  [Eq a]
--     (Eq a)               -->  [Eq a]
--     (((Eq a)))           -->  [Eq a]
-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
checkContext (L SrcSpan
l HsKind GhcPs
orig_t)
  = [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [] (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
orig_t)
 where
  check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns (L SrcSpan
lp (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
    -- be used as context constraints.
    = ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp,SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LHsType GhcPs]
ts)                -- Ditto ()

  check [AddAnn]
anns (L SrcSpan
lp1 (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty))
                                  -- to be sure HsParTy doesn't get into the way
       = [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns' LHsType GhcPs
ty
         where anns' :: [AddAnn]
anns' = if SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
lp1 then [AddAnn]
anns
                                   else ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp1)

  -- no need for anns, returning original
  check [AddAnn]
_anns LHsType GhcPs
_t = ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
orig_t])

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

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

  -- Error if 'qualified' found in postpositive position and
  -- 'ImportQualifiedPost' is not in effect.
  Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
post)

  -- Error if 'qualified' occurs in both pre and postpositive
  -- positions.
  Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Located Token) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Located Token)
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> P ()
failOpImportQualifiedTwice (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
post)

  -- Warn if 'qualified' found in prepositive position and
  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
  Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPre ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
pre ->
    SrcSpan -> P ()
warnPrepositiveQualifiedModule (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
pre)

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

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

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

checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg SDoc
msg PV (Located (PatBuilder GhcPs))
pp = SDoc -> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
msg (PV (Located (PatBuilder GhcPs))
pp PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat)

checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: Located (PatBuilder GhcPs)
e@(L SrcSpan
l PatBuilder GhcPs
_) = SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
l Located (PatBuilder GhcPs)
e []

checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
         -> PV (LPat GhcPs)
checkPat :: SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc (L SrcSpan
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpan
_ RdrName
c))) [LPat GhcPs]
args
  | RdrName -> Bool
isRdrDataCon RdrName
c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Pat GhcPs) -> PV (Located (Pat GhcPs)))
-> (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs
-> PV (Located (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Pat GhcPs -> PV (Located (Pat GhcPs)))
-> Pat GhcPs -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
      { pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
      , pat_con :: Located (ConLikeP GhcPs)
pat_con = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
c
      , pat_args :: HsConPatDetails GhcPs
pat_args = [Located (Pat GhcPs)]
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [Located (Pat GhcPs)]
[LPat GhcPs]
args
      }
  | Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec RdrName
c =
      (SDoc -> SDoc)
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a. (SDoc -> SDoc) -> PV a -> PV a
localPV_msg (\SDoc
_ -> String -> SDoc
text String
"Perhaps you intended to use RecursiveDo") (PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e)
checkPat SrcSpan
loc (L SrcSpan
_ (PatBuilderApp Located (PatBuilder GhcPs)
f Located (PatBuilder GhcPs)
e)) [LPat GhcPs]
args
  = do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
       SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
f (Located (Pat GhcPs)
p Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [Located (Pat GhcPs)]
[LPat GhcPs]
args)
checkPat SrcSpan
loc (L SrcSpan
_ PatBuilder GhcPs
e) []
  = do Pat GhcPs
p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc PatBuilder GhcPs
e
       Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Pat GhcPs
p)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
_
  = SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
e)

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

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

   -- n+k patterns
   PatBuilderOpApp
           (L SrcSpan
nloc (PatBuilderVar (L SrcSpan
_ RdrName
n)))
           (L SrcSpan
_ RdrName
plus)
           (L SrcSpan
lloc (PatBuilderOverLit lit :: HsOverLit GhcPs
lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral {}})))
                      | Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
                      -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
mkNPlusKPat (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
nloc RdrName
n) (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
lloc HsOverLit GhcPs
lit))

   -- Improve error messages for the @-operator when the user meant an @-pattern
   PatBuilderOpApp Located (PatBuilder GhcPs)
_ Located RdrName
op Located (PatBuilder GhcPs)
_ | RdrName -> Bool
opIsAt (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
op) -> do
     SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
op) (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
       String -> SDoc
text String
"Found a binding for the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
op) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"operator in a pattern position." SDoc -> SDoc -> SDoc
$$
       SDoc
perhaps_as_pat
     Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField)

   PatBuilderOpApp Located (PatBuilder GhcPs)
l (L SrcSpan
cl RdrName
c) Located (PatBuilder GhcPs)
r
     | RdrName -> Bool
isRdrDataCon RdrName
c -> do
         Located (Pat GhcPs)
l <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
l
         Located (Pat GhcPs)
r <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
r
         Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs)) -> Pat GhcPs -> PV (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
           { pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
           , pat_con :: Located (ConLikeP GhcPs)
pat_con = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
cl RdrName
c
           , pat_args :: HsConPatDetails GhcPs
pat_args = Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcPs)
l Located (Pat GhcPs)
r
           }

   PatBuilderPar Located (PatBuilder GhcPs)
e    -> Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e PV (Located (Pat GhcPs))
-> (Located (Pat GhcPs) -> PV (Pat GhcPs)) -> PV (Pat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs))
-> (Located (Pat GhcPs) -> Pat GhcPs)
-> Located (Pat GhcPs)
-> PV (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat NoExtField
XParPat GhcPs
noExtField))
   PatBuilder GhcPs
_           -> SrcSpan -> SDoc -> PV (Pat GhcPs)
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e0)

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

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

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

patFail :: SrcSpan -> SDoc -> PV a
patFail :: forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc SDoc
e = SrcSpan -> SDoc -> PV a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> PV a) -> SDoc -> PV a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Parse error in pattern:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
e

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

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

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

checkValDef :: Located (PatBuilder GhcPs)
            -> Maybe (LHsType GhcPs)
            -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
            -> P ([AddAnn],HsBind GhcPs)

checkValDef :: forall a.
Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkValDef Located (PatBuilder GhcPs)
lhs (Just LHsType GhcPs
sig) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
        -- x :: ty = rhs  parses as a *pattern* binding
  = do Located (Pat GhcPs)
lhs' <- PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Located (PatBuilder GhcPs)
-> LHsType GhcPs
-> PV (Located (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
mkHsTySigPV (Located (PatBuilder GhcPs) -> LHsType GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig) Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat
       LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss

checkValDef Located (PatBuilder GhcPs)
lhs Maybe (LHsType GhcPs)
Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g@(L SrcSpan
l (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
  = do  { Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
   [AddAnn])
mb_fun <- Located (PatBuilder GhcPs)
-> P (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
         [AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
lhs
        ; case Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
   [AddAnn])
mb_fun of
            Just (Located RdrName
fun, LexicalFixity
is_infix, [Located (PatBuilder GhcPs)]
pats, [AddAnn]
ann) ->
              SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
NoSrcStrict [AddAnn]
ann (Located (PatBuilder GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (PatBuilder GhcPs)
lhs)
                           Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (SrcSpan
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l GRHSs GhcPs (LHsExpr GhcPs)
grhss)
            Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
   [AddAnn])
Nothing -> do
              Located (Pat GhcPs)
lhs' <- Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern Located (PatBuilder GhcPs)
lhs
              LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g }

checkFunBind :: SrcStrictness
             -> [AddAnn]
             -> SrcSpan
             -> Located RdrName
             -> LexicalFixity
             -> [Located (PatBuilder GhcPs)]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
strictness [AddAnn]
ann SrcSpan
lhs_loc Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (L SrcSpan
rhs_span GRHSs GhcPs (LHsExpr GhcPs)
grhss)
  = do  [Located (Pat GhcPs)]
ps <- SDoc -> PV [Located (Pat GhcPs)] -> P [Located (Pat GhcPs)]
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
param_hint ((Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [Located (PatBuilder GhcPs)]
pats)
        let match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lhs_loc SrcSpan
rhs_span
        -- Add back the annotations stripped from any HsPar values in the lhs
        -- mapM_ (\a -> a match_span) ann
        ([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
ann, Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
fun
                  [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
match_span (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
                                       , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs
                                           { mc_fun :: Located (IdP GhcPs)
mc_fun    = Located RdrName
Located (IdP GhcPs)
fun
                                           , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
                                           , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
                                       , m_pats :: [LPat GhcPs]
m_pats = [Located (Pat GhcPs)]
[LPat GhcPs]
ps
                                       , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss })])
        -- The span of the match covers the entire equation.
        -- That isn't quite right, but it'll do for now.
  where
    param_hint :: SDoc
param_hint
      | LexicalFixity
Infix <- LexicalFixity
is_infix
      = String -> SDoc
text String
"In a function binding for the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
fun) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"operator." SDoc -> SDoc -> SDoc
$$
        if RdrName -> Bool
opIsAt (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
fun) then SDoc
perhaps_as_pat else SDoc
empty
      | Bool
otherwise = SDoc
empty

perhaps_as_pat :: SDoc
perhaps_as_pat :: SDoc
perhaps_as_pat = String -> SDoc
text String
"Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
            -> HsBind GhcPs
-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
makeFunBind :: Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
fn [LMatch GhcPs (LHsExpr GhcPs)]
ms
  = FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = NoExtField
XFunBind GhcPs GhcPs
noExtField,
              fun_id :: Located (IdP GhcPs)
fun_id = Located RdrName
Located (IdP GhcPs)
fn,
              fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms,
              fun_tick :: [Tickish Id]
fun_tick = [] }

-- See Note [FunBind vs PatBind]
checkPatBind :: LPat GhcPs
             -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
checkPatBind :: forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind LPat GhcPs
lhs (L SrcSpan
rhs_span (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
    | BangPat XBangPat GhcPs
_ LPat GhcPs
p <- Located (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcPs)
LPat GhcPs
lhs
    , VarPat XVarPat GhcPs
_ Located (IdP GhcPs)
v <- Located (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcPs)
LPat GhcPs
p
    = ([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
v [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
match_span (Located RdrName -> Match GhcPs (LHsExpr GhcPs)
m Located RdrName
Located (IdP GhcPs)
v)])
  where
    match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located (Pat GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (Pat GhcPs)
LPat GhcPs
lhs) SrcSpan
rhs_span
    m :: Located RdrName -> Match GhcPs (LHsExpr GhcPs)
m Located RdrName
v = Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
                , m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun    = Located RdrName
Located (IdP GhcPs)
v
                                  , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
                                  , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict }
                , m_pats :: [LPat GhcPs]
m_pats = []
                , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss }

checkPatBind LPat GhcPs
lhs (L SrcSpan
_ (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
  = ([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind NoExtField
XPatBind GhcPs GhcPs
noExtField LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss ([],[]))

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

checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpan
l HsExpr GhcPs
_)
  = SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l ((String -> SDoc
text String
"Invalid type signature:" SDoc -> SDoc -> SDoc
<+>
                       LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":: ...")
                      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
hint)
  where
    hint :: String
hint | RdrName
IdP GhcPs
foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
         = String
"Perhaps you meant to use ForeignFunctionInterface?"
         | RdrName
IdP GhcPs
default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
         = String
"Perhaps you meant to use DefaultSignatures?"
         | RdrName
IdP GhcPs
pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
         = String
"Perhaps you meant to use PatternSynonyms?"
         | Bool
otherwise
         = String
"Should be of form <variable> :: <type>"

    -- A common error is to forget the ForeignFunctionInterface flag
    -- so check for that, and suggest.  cf #3805
    -- Sadly 'foreign import' still barfs 'parse error' because
    --  'import' is a keyword
    looks_like :: IdP p -> LHsExpr p -> Bool
looks_like IdP p
s (L SrcSpan
_ (HsVar XVar p
_ (L SrcSpan
_ IdP p
v))) = IdP p
v IdP p -> IdP p -> Bool
forall a. Eq a => a -> a -> Bool
== IdP p
s
    looks_like IdP p
s (L SrcSpan
_ (HsApp XApp p
_ LHsExpr p
lhs LHsExpr p
_))   = IdP p -> LHsExpr p -> Bool
looks_like IdP p
s LHsExpr p
lhs
    looks_like IdP p
_ LHsExpr p
_                       = Bool
False

    foreign_RDR :: RdrName
foreign_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"foreign")
    default_RDR :: RdrName
default_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"default")
    pattern_RDR :: RdrName
pattern_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pattern")

checkDoAndIfThenElse
  :: (Outputable a, Outputable b, Outputable c)
  => Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse :: forall a b c.
(Outputable a, Outputable b, Outputable c) =>
Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse Located a
guardExpr Bool
semiThen b
thenExpr Bool
semiElse Located c
elseExpr
 | Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse
    = do Bool
doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
         Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$ do
             SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located a -> Located c -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located a
guardExpr Located c
elseExpr)
                            (String -> SDoc
text String
"Unexpected semi-colons in conditional:"
                          SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
expr
                          SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Perhaps you meant to use DoAndIfThenElse?")
 | Bool
otherwise            = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where pprOptSemi :: Bool -> SDoc
pprOptSemi Bool
True  = SDoc
semi
          pprOptSemi Bool
False = SDoc
empty
          expr :: SDoc
expr = String -> SDoc
text String
"if"   SDoc -> SDoc -> SDoc
<+> Located a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located a
guardExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiThen SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text String
"then" SDoc -> SDoc -> SDoc
<+> b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
thenExpr  SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiElse SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text String
"else" SDoc -> SDoc -> SDoc
<+> Located c -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located c
elseExpr

isFunLhs :: Located (PatBuilder GhcPs)
      -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
         [AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
e = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> P (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
         [AddAnn]))
forall {m :: * -> *} {p}.
Monad m =>
Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
go Located (PatBuilder GhcPs)
e [] []
 where
   go :: Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
go (L SrcSpan
loc (PatBuilderVar (L SrcSpan
_ RdrName
f))) [Located (PatBuilder p)]
es [AddAnn]
ann
       | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f)        = Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
 [AddAnn])
-> Maybe
     (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
      [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
f, LexicalFixity
Prefix, [Located (PatBuilder p)]
es, [AddAnn]
ann))
   go (L SrcSpan
_ (PatBuilderApp Located (PatBuilder p)
f Located (PatBuilder p)
e)) [Located (PatBuilder p)]
es       [AddAnn]
ann = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
go Located (PatBuilder p)
f (Located (PatBuilder p)
eLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es) [AddAnn]
ann
   go (L SrcSpan
l (PatBuilderPar Located (PatBuilder p)
e))   es :: [Located (PatBuilder p)]
es@(Located (PatBuilder p)
_:[Located (PatBuilder p)]
_) [AddAnn]
ann = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
go Located (PatBuilder p)
e [Located (PatBuilder p)]
es ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
   go (L SrcSpan
loc (PatBuilderOpApp Located (PatBuilder p)
l (L SrcSpan
loc' RdrName
op) Located (PatBuilder p)
r)) [Located (PatBuilder p)]
es [AddAnn]
ann
        | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)         -- We have found the function!
        = Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
 [AddAnn])
-> Maybe
     (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
      [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' RdrName
op, LexicalFixity
Infix, (Located (PatBuilder p)
lLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:Located (PatBuilder p)
rLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es), [AddAnn]
ann))
        | Bool
otherwise                     -- Infix data con; keep going
        = do { Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
mb_l <- Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
go Located (PatBuilder p)
l [Located (PatBuilder p)]
es [AddAnn]
ann
             ; case Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
mb_l of
                 Just (Located RdrName
op', LexicalFixity
Infix, Located (PatBuilder p)
j : Located (PatBuilder p)
k : [Located (PatBuilder p)]
es', [AddAnn]
ann')
                   -> Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
 [AddAnn])
-> Maybe
     (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
      [AddAnn])
forall a. a -> Maybe a
Just (Located RdrName
op', LexicalFixity
Infix, Located (PatBuilder p)
j Located (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
: Located (PatBuilder p)
op_app Located (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder p)]
es', [AddAnn]
ann'))
                   where
                     op_app :: Located (PatBuilder p)
op_app = SrcSpan -> PatBuilder p -> Located (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
forall p.
Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
PatBuilderOpApp Located (PatBuilder p)
k
                               (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' RdrName
op) Located (PatBuilder p)
r)
                 Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
_ -> Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
forall a. Maybe a
Nothing }
   go Located (PatBuilder p)
_ [Located (PatBuilder p)]
_ [AddAnn]
_ = Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
-> m (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
         [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (Located RdrName, LexicalFixity, [Located (PatBuilder p)],
   [AddAnn])
forall a. Maybe a
Nothing

-- | Either an operator or an operand.
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
          | TyElKindApp SrcSpan (LHsType GhcPs)
          -- See Note [TyElKindApp SrcSpan interpretation]
          | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)


{- Note [TyElKindApp SrcSpan interpretation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A TyElKindApp captures type application written in haskell as

    @ Foo

where Foo is some type.

The SrcSpan reflects both elements, and there are AnnAt and AnnVal API
Annotations attached to this SrcSpan for the specific locations of
each within it.
-}

instance Outputable TyEl where
  ppr :: TyEl -> SDoc
ppr (TyElOpr RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
  ppr (TyElOpd HsKind GhcPs
ty) = HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ty
  ppr (TyElKindApp SrcSpan
_ LHsType GhcPs
ki) = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
  ppr (TyElUnpackedness ([AddAnn]
_, SourceText
_, SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk

-- | Extract a strictness/unpackedness annotation from the front of a reversed
-- 'TyEl' list.
pUnpackedness
  :: [Located TyEl] -- reversed TyEl
  -> Maybe ( SrcSpan
           , [AddAnn]
           , SourceText
           , SrcUnpackedness
           , [Located TyEl] {- remaining TyEl -})
pUnpackedness :: [Located TyEl]
-> Maybe
     (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
pUnpackedness (L SrcSpan
l TyEl
x1 : [Located TyEl]
xs)
  | TyElUnpackedness ([AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk) <- TyEl
x1
  = (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
-> Maybe
     (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
forall a. a -> Maybe a
Just (SrcSpan
l, [AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk, [Located TyEl]
xs)
pUnpackedness [Located TyEl]
_ = Maybe
  (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
forall a. Maybe a
Nothing

pBangTy
  :: LHsType GhcPs  -- a type to be wrapped inside HsBangTy
  -> [Located TyEl] -- reversed TyEl
  -> ( Bool           {- has a strict mark been consumed? -}
     , LHsType GhcPs  {- the resulting BangTy -}
     , P ()           {- add annotations -}
     , [Located TyEl] {- remaining TyEl -})
pBangTy :: LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy lt :: LHsType GhcPs
lt@(L SrcSpan
l1 HsKind GhcPs
_) [Located TyEl]
xs =
  case [Located TyEl]
-> Maybe
     (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
pUnpackedness [Located TyEl]
xs of
    Maybe
  (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
    Just (SrcSpan
l2, [AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk, [Located TyEl]
xs') ->
      let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
          ([AddAnn]
anns2, HsKind GhcPs
bt) = (SourceText, SrcUnpackedness)
-> LHsType GhcPs -> ([AddAnn], HsKind GhcPs)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) LHsType GhcPs
lt
      in (Bool
True, SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
bl HsKind GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
anns2), [Located TyEl]
xs')

mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsKind GhcPs
mkBangTy SrcStrictness
strictness =
  XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness)

addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs)
addUnpackedness :: (SourceText, SrcUnpackedness)
-> LHsType GhcPs -> ([AddAnn], HsKind GhcPs)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) (L SrcSpan
l (HsBangTy XBangTy GhcPs
x HsSrcBang
bang LHsType GhcPs
t))
  | HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness <- HsSrcBang
bang
  = let
      anns :: [AddAnn]
anns = case SrcStrictness
strictness of
        SrcStrictness
SrcLazy     -> [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnTilde (SrcSpan -> SrcSpan
srcSpanFirstCharacter SrcSpan
l)]
        SrcStrictness
SrcStrict   -> [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnBang  (SrcSpan -> SrcSpan
srcSpanFirstCharacter SrcSpan
l)]
        SrcStrictness
NoSrcStrict -> []
    in ([AddAnn]
anns, XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
x (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
strictness) LHsType GhcPs
t)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) LHsType GhcPs
t
  = ([], XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict) LHsType GhcPs
t)

-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
--   into a type.
--
-- User input: @F x y + G a b * X@
-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
-- Output corresponds to what the user wrote assuming all operators are of the
-- same fixity and right-associative.
--
-- It's a bit silly that we're doing it at all, as the renamer will have to
-- rearrange this, and it'd be easier to keep things separate.
--
-- See Note [Parsing data constructors is hard]
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((L SrcSpan
l1 (TyElOpd HsKind GhcPs
t)) : [Located TyEl]
xs)
  | (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l1 HsKind GhcPs
t) [Located TyEl]
xs
  , [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs' -- We accept a BangTy only when there are no preceding TyEl.
  = P ()
addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
t'
mergeOps [Located TyEl]
all_xs = Int
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
forall {t}.
(Eq t, Num t) =>
t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go (Int
0 :: Int) [] LHsType GhcPs -> LHsType GhcPs
forall a. a -> a
id [Located TyEl]
all_xs
  where
    -- NB. When modifying clauses in 'go', make sure that the reasoning in
    -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct.

    -- clause [unpk]:
    -- handle (NO)UNPACK pragmas
    go :: t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElUnpackedness ([AddAnn]
anns, SourceText
unpkSrc, SrcUnpackedness
unpk))):[Located TyEl]
xs) =
      if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs
      then do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs))
-> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc
              ; let a :: LHsType GhcPs
a = LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc'
                    strictMark :: HsSrcBang
strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
unpkSrc SrcUnpackedness
unpk SrcStrictness
NoSrcStrict
                    bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l (LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
a)
                    bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField HsSrcBang
strictMark LHsType GhcPs
a
              ; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl [AddAnn]
anns
              ; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
bl HsKind GhcPs
bt) }
      else SrcSpan -> SDoc -> P (LHsType GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l SDoc
unpkError
      where
        unpkSDoc :: SDoc
unpkSDoc = case SourceText
unpkSrc of
          SourceText
NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
          SourceText String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" #-}"
        unpkError :: SDoc
unpkError
          | Bool -> Bool
not ([Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs) = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot appear inside a type."
          | [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
&& t
k t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be applied to a type."
          | Bool
otherwise =
              -- See Note [Impossible case in mergeOps clause [unpk]]
              String -> SDoc
forall a. String -> a
panic String
"mergeOps.UNPACK: impossible position"

    -- clause [opr]:
    -- when we encounter an operator, we must have accumulated
    -- something for its rhs, and there must be something left
    -- to build its lhs.
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElOpr RdrName
op)):[Located TyEl]
xs) =
      if [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
|| [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Located TyEl -> Bool) -> [Located TyEl] -> [Located TyEl]
forall a. (a -> Bool) -> [a] -> [a]
filter Located TyEl -> Bool
forall {l}. GenLocated l TyEl -> Bool
isTyElOpd [Located TyEl]
xs)
        then Located RdrName -> P (LHsType GhcPs)
forall a. Located RdrName -> P a
failOpFewArgs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
op)
        else do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
                ; t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [] (\LHsType GhcPs
c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
c (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
op) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc')) [Located TyEl]
xs }
      where
        isTyElOpd :: GenLocated l TyEl -> Bool
isTyElOpd (L l
_ (TyElOpd HsKind GhcPs
_)) = Bool
True
        isTyElOpd GenLocated l TyEl
_ = Bool
False

    -- clause [opd]:
    -- whenever an operand is encountered, it is added to the accumulator
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElOpd HsKind GhcPs
a)):[Located TyEl]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [Located TyEl]
xs

    -- clause [tyapp]:
    -- whenever a type application is encountered, it is added to the accumulator
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
_ (TyElKindApp SrcSpan
l LHsType GhcPs
a)):[Located TyEl]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [Located TyEl]
xs

    -- clause [end]
    -- See Note [Non-empty 'acc' in mergeOps clause [end]]
    go t
_ [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc [] = do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
                             ; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc') }

mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
         -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = String -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg SrcSpan
_ (L SrcSpan
loc HsKind GhcPs
ki):[LHsTypeArg GhcPs]
_)
  = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc, String -> SDoc
text String
"Unexpected type application:" SDoc -> SDoc -> SDoc
<+> HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ki)
mergeOpsAcc (HsValArg LHsType GhcPs
ty : [LHsTypeArg GhcPs]
xs) = LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
  where
    go1 :: LHsType GhcPs
        -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
        -> Either (SrcSpan, SDoc) (LHsType GhcPs)
    go1 :: LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs []     = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. b -> Either a b
Right LHsType GhcPs
lhs
    go1 LHsType GhcPs
lhs (LHsTypeArg GhcPs
x:[LHsTypeArg GhcPs]
xs) = case LHsTypeArg GhcPs
x of
        HsValArg LHsType GhcPs
ty -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcPs
lhs LHsType GhcPs
ty) [LHsTypeArg GhcPs]
xs
        HsTypeArg SrcSpan
loc LHsType GhcPs
ki -> let ty :: LHsType GhcPs
ty = XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
XAppKindTy GhcPs
loc LHsType GhcPs
lhs LHsType GhcPs
ki
                            in LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
        HsArgPar SrcSpan
_ -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [LHsTypeArg GhcPs]
xs
mergeOpsAcc (HsArgPar SrcSpan
_: [LHsTypeArg GhcPs]
xs) = [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
xs

{- Note [Impossible case in mergeOps clause [unpk]]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This case should never occur. Let us consider all possible
variations of 'acc', 'xs', and 'k':

  acc          xs        k
==============================
  null   |    null       0      -- "must be applied to a type"
  null   |  not null     0      -- "must be applied to a type"
not null |    null       0      -- successful parse
not null |  not null     0      -- "cannot appear inside a type"
  null   |    null      >0      -- handled in clause [opr]
  null   |  not null    >0      -- "cannot appear inside a type"
not null |    null      >0      -- successful parse
not null |  not null    >0      -- "cannot appear inside a type"

The (null acc && null xs && k>0) case is handled in clause [opr]
by the following check:

    if ... || null (filter isTyElOpd xs)
     then failOpFewArgs (L l op)

We know that this check has been performed because k>0, and by
the time we reach the end of the list (null xs), the only way
for (null acc) to hold is that there was not a single TyElOpd
between the operator and the end of the list. But this case is
caught by the check and reported as 'failOpFewArgs'.
-}

{- Note [Non-empty 'acc' in mergeOps clause [end]]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc'
without a check.

Running 'mergeOps' with an empty input list is forbidden, so we do not consider
this possibility. This means we'll hit at least one other clause before we
reach clause [end].

* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit
  clause [end] from there.
* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc'
  will be non-empty.
* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going
  to hit clause [opd] at least once before we reach clause [end], making 'acc'
  non-empty.
* There are no other clauses.

Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
[end].

-}

pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
  | (Bool
True, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
  = (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs')
pInfixSide (Located TyEl
el:[Located TyEl]
xs1)
  | Just LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
  = [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1] [Located TyEl]
xs1
   where
     go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
        -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
     go :: [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs]
acc (Located TyEl
el:[Located TyEl]
xs)
       | Just LHsTypeArg GhcPs
t <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
       = [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go (LHsTypeArg GhcPs
tLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [Located TyEl]
xs
     go [LHsTypeArg GhcPs]
acc [Located TyEl]
xs = case [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc of
       Left (SrcSpan, SDoc)
_ -> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
       Right LHsType GhcPs
acc' -> (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
acc', () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
pInfixSide [Located TyEl]
_ = Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing

pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg :: Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg (L SrcSpan
l (TyElOpd HsKind GhcPs
a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs)
forall a. a -> Maybe a
Just (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
a))
pLHsTypeArg (L SrcSpan
_ (TyElKindApp SrcSpan
l LHsType GhcPs
a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs)
forall a. a -> Maybe a
Just (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
a)
pLHsTypeArg Located TyEl
_ = Maybe (LHsTypeArg GhcPs)
forall a. Maybe a
Nothing

orErr :: Maybe a -> b -> Either b a
orErr :: forall a b. Maybe a -> b -> Either b a
orErr (Just a
a) b
_ = a -> Either b a
forall a b. b -> Either a b
Right a
a
orErr Maybe a
Nothing b
b = b -> Either b a
forall a b. a -> Either a b
Left b
b

-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
--   into a data constructor.
--
-- User input: @C !A B -- ^ doc@
-- Input to 'mergeDataCon': ["doc", B, !A, C]
-- Output: (C, PrefixCon [!A, B], "doc")
--
-- See Note [Parsing data constructors is hard]
mergeDataCon
      :: [Located TyEl]
      -> P ( Located RdrName         -- constructor name
           , HsConDeclDetails GhcPs  -- constructor field information
           )
mergeDataCon :: [Located TyEl]
-> P (Located RdrName,
      HsConDetails
        (HsScaled GhcPs (LHsType GhcPs))
        (GenLocated SrcSpan [LConDeclField GhcPs]))
mergeDataCon [Located TyEl]
all_xs =
  do { (P ()
addAnns, (Located RdrName,
 HsConDetails
   (HsScaled GhcPs (LHsType GhcPs))
   (GenLocated SrcSpan [LConDeclField GhcPs]))
a) <- Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
-> P (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
res
     ; P ()
addAnns
     ; (Located RdrName,
 HsConDetails
   (HsScaled GhcPs (LHsType GhcPs))
   (GenLocated SrcSpan [LConDeclField GhcPs]))
-> P (Located RdrName,
      HsConDetails
        (HsScaled GhcPs (LHsType GhcPs))
        (GenLocated SrcSpan [LConDeclField GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName,
 HsConDetails
   (HsScaled GhcPs (LHsType GhcPs))
   (GenLocated SrcSpan [LConDeclField GhcPs]))
a }
  where
    -- The result of merging the list of reversed TyEl into a
    -- data constructor, along with [AddAnn].
    res :: Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
res = [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
goFirst [Located TyEl]
all_xs

    goFirst :: [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
goFirst [ L SrcSpan
l (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ]
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
IdP GhcPs
tc
           ; (P (),
 (Located RdrName,
  HsConDetails
    (HsScaled GhcPs (LHsType GhcPs))
    (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [])) }
    goFirst ((L SrcSpan
l (TyElOpd (HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
fields))):[Located TyEl]
xs)
      | [ L SrcSpan
l' (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ] <- [Located TyEl]
xs
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l' RdrName
IdP GhcPs
tc
           ; (P (),
 (Located RdrName,
  HsConDetails
    (HsScaled GhcPs (LHsType GhcPs))
    (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, GenLocated SrcSpan [LConDeclField GhcPs]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> [LConDeclField GhcPs]
-> GenLocated SrcSpan [LConDeclField GhcPs]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LConDeclField GhcPs]
fields))) }
    goFirst [L SrcSpan
l (TyElOpd (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))]
      = (P (),
 (Located RdrName,
  HsConDetails
    (HsScaled GhcPs (LHsType GhcPs))
    (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return ( () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
               , ( SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts)))
                 , [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
ts) ) )
    goFirst ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
      | (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
      = P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
go P ()
addAnns [LHsType GhcPs
t'] [Located TyEl]
xs'
    goFirst (L SrcSpan
l (TyElKindApp SrcSpan
_ LHsType GhcPs
_):[Located TyEl]
_)
      = Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a. Semigroup a => a -> a -> a
Monoid.<> (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a b. a -> Either a b
Left (SrcSpan
l, SDoc
kindAppErr)
    goFirst [Located TyEl]
xs
      = P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
go (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) [] [Located TyEl]
xs

    go :: P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
go P ()
addAnns [LHsType GhcPs]
ts [ L SrcSpan
l (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ]
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
IdP GhcPs
tc
           ; (P (),
 (Located RdrName,
  HsConDetails
    (HsScaled GhcPs (LHsType GhcPs))
    (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (P ()
addAnns, (Located RdrName
data_con, [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
ts))) }
    go P ()
addAnns [LHsType GhcPs]
ts ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
      | (Bool
_, LHsType GhcPs
t', P ()
addAnns', [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
      = P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
go (P ()
addAnns P () -> P () -> P ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P ()
addAnns') (LHsType GhcPs
t'LHsType GhcPs -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. a -> [a] -> [a]
:[LHsType GhcPs]
ts) [Located TyEl]
xs'
    go P ()
_ [LHsType GhcPs]
_ ((L SrcSpan
_ (TyElOpr RdrName
_)):[Located TyEl]
_) =
      -- Encountered an operator: backtrack to the beginning and attempt
      -- to parse as an infix definition.
      Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix
    go P ()
_ [LHsType GhcPs]
_ (L SrcSpan
l (TyElKindApp SrcSpan
_ LHsType GhcPs
_):[Located TyEl]
_) =  Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a. Semigroup a => a -> a -> a
Monoid.<> (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a b. a -> Either a b
Left (SrcSpan
l, SDoc
kindAppErr)
    go P ()
_ [LHsType GhcPs]
_ [Located TyEl]
_ = (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
malformedErr
      where
        malformedErr :: (SrcSpan, SDoc)
malformedErr =
          ( (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
noSrcSpan ((Located TyEl -> SrcSpan) -> [Located TyEl] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [Located TyEl]
all_xs)
          , String -> SDoc
text String
"Cannot parse data constructor" SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
            Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs))

    goInfix :: Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName,
    HsConDetails
      (HsScaled GhcPs (LHsType GhcPs))
      (GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix =
      do { let xs0 :: [Located TyEl]
xs0 = [Located TyEl]
all_xs
         ; (LHsType GhcPs
rhs, P ()
rhs_addAnns, [Located TyEl]
xs1) <- [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide [Located TyEl]
xs0 Maybe (LHsType GhcPs, P (), [Located TyEl])
-> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsType GhcPs, P (), [Located TyEl])
forall a b. Maybe a -> b -> Either b a
`orErr` (SrcSpan, SDoc)
malformedErr
         ; (Located RdrName
op, [Located TyEl]
xs3) <- case [Located TyEl]
xs1 of
              (L SrcSpan
l (TyElOpr RdrName
op)) : [Located TyEl]
xs3 ->
                do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
op
                   ; (Located RdrName, [Located TyEl])
-> Either (SrcSpan, SDoc) (Located RdrName, [Located TyEl])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
data_con, [Located TyEl]
xs3) }
              [Located TyEl]
_ -> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (Located RdrName, [Located TyEl])
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
malformedErr
         ; (LHsType GhcPs
lhs, P ()
lhs_addAnns, [Located TyEl]
xs5) <- [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide [Located TyEl]
xs3 Maybe (LHsType GhcPs, P (), [Located TyEl])
-> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsType GhcPs, P (), [Located TyEl])
forall a b. Maybe a -> b -> Either b a
`orErr` (SrcSpan, SDoc)
malformedErr
         ; Bool -> Either (SrcSpan, SDoc) () -> Either (SrcSpan, SDoc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs5) ((SrcSpan, SDoc) -> Either (SrcSpan, SDoc) ()
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
malformedErr)
         ; let addAnns :: P ()
addAnns = P ()
lhs_addAnns P () -> P () -> P ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P ()
rhs_addAnns
         ; (P (),
 (Located RdrName,
  HsConDetails
    (HsScaled GhcPs (LHsType GhcPs))
    (GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName,
       HsConDetails
         (HsScaled GhcPs (LHsType GhcPs))
         (GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (P ()
addAnns, (Located RdrName
op, HsScaled GhcPs (LHsType GhcPs)
-> HsScaled GhcPs (LHsType GhcPs)
-> HsConDetails
     (HsScaled GhcPs (LHsType GhcPs))
     (GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear LHsType GhcPs
lhs) (LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear LHsType GhcPs
rhs))) }
      where
        malformedErr :: (SrcSpan, SDoc)
malformedErr =
          ( (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
noSrcSpan ((Located TyEl -> SrcSpan) -> [Located TyEl] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [Located TyEl]
all_xs)
          , String -> SDoc
text String
"Cannot parse an infix data constructor" SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
            Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs))

    kindAppErr :: SDoc
kindAppErr =
      String -> SDoc
text String
"Unexpected kind application" SDoc -> SDoc -> SDoc
<+>
      String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
      Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs)

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

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

-- See Note [Parser-Validator]
-- 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 (Located b)
runECP_PV :: forall b. DisambECP b => PV (Located b) }

runECP_P :: DisambECP b => ECP -> P (Located b)
runECP_P :: forall b. DisambECP b => ECP -> P (Located b)
runECP_P ECP
p = PV (Located b) -> P (Located b)
forall a. PV a -> P a
runPV (ECP -> forall b. DisambECP b => PV (Located b)
runECP_PV ECP
p)

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

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

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

instance DisambInfixOp (HsExpr GhcPs) where
  mkHsVarOpPV :: Located RdrName -> PV (LHsExpr GhcPs)
mkHsVarOpPV Located RdrName
v = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
v) (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v)
  mkHsConOpPV :: Located RdrName -> PV (LHsExpr GhcPs)
mkHsConOpPV Located RdrName
v = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
v) (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v)
  mkHsInfixHolePV :: SrcSpan -> PV (LHsExpr GhcPs)
mkHsInfixHolePV SrcSpan
l = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
forall (id :: Pass). HsExpr (GhcPass id)
hsHoleExpr

instance DisambInfixOp RdrName where
  mkHsConOpPV :: Located RdrName -> PV (Located RdrName)
mkHsConOpPV (L SrcSpan
l RdrName
v) = Located RdrName -> PV (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> PV (Located RdrName))
-> Located RdrName -> PV (Located RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
v
  mkHsVarOpPV :: Located RdrName -> PV (Located RdrName)
mkHsVarOpPV (L SrcSpan
l RdrName
v) = Located RdrName -> PV (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> PV (Located RdrName))
-> Located RdrName -> PV (Located RdrName)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
v
  mkHsInfixHolePV :: SrcSpan -> PV (Located RdrName)
mkHsInfixHolePV SrcSpan
l =
    SrcSpan -> SDoc -> PV (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located RdrName)) -> SDoc -> PV (Located RdrName)
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Invalid infix hole, expected an infix operator"

-- | 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 => 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 (Located b)
  -- | Return an expression without ambiguity, or fail in a non-expression context.
  ecpFromExp' :: LHsExpr GhcPs -> PV (Located b)
  -- | Disambiguate "\... -> ..." (lambda)
  mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
  -- | Disambiguate "let ... in ..."
  mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located 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 (Located b )) -> PV (Located b)
  -- | Disambiguate "f # x" (infix operator)
  mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b)
  -- | Disambiguate "case ... of ..."
  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b)
  -- | Disambiguate @\\case ...@ (lambda case)
  mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located 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 (Located b)) -> PV (Located b)
  -- | Disambiguate "f x" (function application)
  mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)
  -- | Disambiguate "f @t" (visible type application)
  mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
  -- | Disambiguate "if ... then ... else ..."
  mkHsIfPV :: SrcSpan
         -> LHsExpr GhcPs
         -> Bool  -- semicolon?
         -> Located b
         -> Bool  -- semicolon?
         -> Located b
         -> PV (Located b)
  -- | Disambiguate "do { ... }" (do notation)
  mkHsDoPV ::
    SrcSpan ->
    Maybe ModuleName ->
    Located [LStmt GhcPs (Located b)] ->
    PV (Located b)
  -- | Disambiguate "( ... )" (parentheses)
  mkHsParPV :: SrcSpan -> Located b -> PV (Located b)
  -- | Disambiguate a variable "f" or a data constructor "MkF".
  mkHsVarPV :: Located RdrName -> PV (Located b)
  -- | Disambiguate a monomorphic literal
  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
  -- | Disambiguate an overloaded literal
  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)
  -- | Disambiguate a wildcard
  mkHsWildCardPV :: SrcSpan -> PV (Located b)
  -- | Disambiguate "a :: t" (type annotation)
  mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
  -- | Disambiguate "[a,b,c]" (list syntax)
  mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b)
  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
  mkHsRecordPV ::
    SrcSpan ->
    SrcSpan ->
    Located b ->
    ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) ->
    PV (Located b)
  -- | Disambiguate "-a" (negation)
  mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b)
  -- | Disambiguate "(# a)" (right operator section)
  mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)
  -- | Disambiguate "(a -> b)" (view pattern)
  mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b)
  -- | Disambiguate "a@b" (as-pattern)
  mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)
  -- | Disambiguate "~a" (lazy pattern)
  mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b)
  -- | Disambiguate "!a" (bang pattern)
  mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)
  -- | Disambiguate tuple sections and unboxed sums
  mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)
  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
  rejectPragmaPV :: Located b -> PV ()


{- Note [UndecidableSuperClasses for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(This Note is about the code in GHC, not about the user code that we are parsing)

Assume we have a class C with an associated type T:

  class C a where
    type T a
    ...

If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:

  {-# LANGUAGE UndecidableSuperClasses #-}
  class C (T a) => C a where
    type T a
    ...

Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes
making GHC loop. The workaround is to bring this constraint into scope
manually with a helper method:

  class C a where
    type T a
    superT :: (C (T a) => r) -> r

In order to avoid ambiguous types, 'r' must mention 'a'.

For consistency, we use this approach for all constraints on associated types,
even when -XUndecidableSuperClasses are not required.
-}

{- Note [Body in DisambECP]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that
require their argument to take a form of (body GhcPs) for some (body :: Type ->
*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the
superclass constraints of DisambECP.

The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop
this requirement. It is possible and would allow removing the type index of
PatBuilder, but leads to worse type inference, breaking some code in the
typechecker.
-}

instance DisambECP (HsCmd GhcPs) where
  type Body (HsCmd GhcPs) = HsCmd
  ecpFromCmd' :: LHsCmd GhcPs -> PV (LHsCmd GhcPs)
ecpFromCmd' = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return
  ecpFromExp' :: LHsExpr GhcPs -> PV (LHsCmd GhcPs)
ecpFromExp' (L SrcSpan
l HsExpr GhcPs
e) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
  mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (LHsCmd GhcPs) -> PV (LHsCmd GhcPs)
mkHsLamPV SrcSpan
l MatchGroup GhcPs (LHsCmd GhcPs)
mg = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdLam GhcPs -> MatchGroup GhcPs (LHsCmd GhcPs) -> HsCmd GhcPs
forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam NoExtField
XCmdLam GhcPs
noExtField MatchGroup GhcPs (LHsCmd GhcPs)
mg)
  mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsLetPV SrcSpan
l LHsLocalBinds GhcPs
bs LHsCmd GhcPs
e = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdLet GhcPs -> LHsLocalBinds GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet NoExtField
XCmdLet GhcPs
noExtField LHsLocalBinds GhcPs
bs LHsCmd GhcPs
e)
  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
  superInfixOp :: (DisambInfixOp (InfixOp (HsCmd GhcPs)) => PV (LHsCmd GhcPs))
-> PV (LHsCmd GhcPs)
superInfixOp DisambInfixOp (InfixOp (HsCmd GhcPs)) => PV (LHsCmd GhcPs)
m = PV (LHsCmd GhcPs)
DisambInfixOp (InfixOp (HsCmd GhcPs)) => PV (LHsCmd GhcPs)
m
  mkHsOpAppPV :: SrcSpan
-> LHsCmd GhcPs
-> Located (InfixOp (HsCmd GhcPs))
-> LHsCmd GhcPs
-> PV (LHsCmd GhcPs)
mkHsOpAppPV SrcSpan
l LHsCmd GhcPs
c1 Located (InfixOp (HsCmd GhcPs))
op LHsCmd GhcPs
c2 = do
    let cmdArg :: GenLocated SrcSpan (HsCmd p) -> GenLocated SrcSpan (HsCmdTop p)
cmdArg GenLocated SrcSpan (HsCmd p)
c = SrcSpan -> HsCmdTop p -> GenLocated SrcSpan (HsCmdTop p)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpan (HsCmd p) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan (HsCmd p)
c) (HsCmdTop p -> GenLocated SrcSpan (HsCmdTop p))
-> HsCmdTop p -> GenLocated SrcSpan (HsCmdTop p)
forall a b. (a -> b) -> a -> b
$ XCmdTop p -> GenLocated SrcSpan (HsCmd p) -> HsCmdTop p
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop NoExtField
XCmdTop p
noExtField GenLocated SrcSpan (HsCmd p)
c
    LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsCmd GhcPs -> LHsCmd GhcPs) -> HsCmd GhcPs -> LHsCmd GhcPs
forall a b. (a -> b) -> a -> b
$ XCmdArrForm GhcPs
-> LHsExpr GhcPs
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcPs]
-> HsCmd GhcPs
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExtField
XCmdArrForm GhcPs
noExtField LHsExpr GhcPs
Located (InfixOp (HsCmd GhcPs))
op LexicalFixity
Infix Maybe Fixity
forall a. Maybe a
Nothing [LHsCmd GhcPs -> LHsCmdTop GhcPs
forall {p}.
(XCmdTop p ~ NoExtField) =>
GenLocated SrcSpan (HsCmd p) -> GenLocated SrcSpan (HsCmdTop p)
cmdArg LHsCmd GhcPs
c1, LHsCmd GhcPs -> LHsCmdTop GhcPs
forall {p}.
(XCmdTop p ~ NoExtField) =>
GenLocated SrcSpan (HsCmd p) -> GenLocated SrcSpan (HsCmdTop p)
cmdArg LHsCmd GhcPs
c2]
  mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> PV (LHsCmd GhcPs)
mkHsCasePV SrcSpan
l LHsExpr GhcPs
c MatchGroup GhcPs (LHsCmd GhcPs)
mg = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdCase GhcPs
-> LHsExpr GhcPs -> MatchGroup GhcPs (LHsCmd GhcPs) -> HsCmd GhcPs
forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase NoExtField
XCmdCase GhcPs
noExtField LHsExpr GhcPs
c MatchGroup GhcPs (LHsCmd GhcPs)
mg)
  mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (LHsCmd GhcPs) -> PV (LHsCmd GhcPs)
mkHsLamCasePV SrcSpan
l MatchGroup GhcPs (LHsCmd GhcPs)
mg = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdLamCase GhcPs -> MatchGroup GhcPs (LHsCmd GhcPs) -> HsCmd GhcPs
forall id. XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLamCase NoExtField
XCmdLamCase GhcPs
noExtField MatchGroup GhcPs (LHsCmd GhcPs)
mg)
  type FunArg (HsCmd GhcPs) = HsExpr GhcPs
  superFunArg :: (DisambECP (FunArg (HsCmd GhcPs)) => PV (LHsCmd GhcPs))
-> PV (LHsCmd GhcPs)
superFunArg DisambECP (FunArg (HsCmd GhcPs)) => PV (LHsCmd GhcPs)
m = PV (LHsCmd GhcPs)
DisambECP (FunArg (HsCmd GhcPs)) => PV (LHsCmd GhcPs)
m
  mkHsAppPV :: SrcSpan
-> LHsCmd GhcPs
-> Located (FunArg (HsCmd GhcPs))
-> PV (LHsCmd GhcPs)
mkHsAppPV SrcSpan
l LHsCmd GhcPs
c Located (FunArg (HsCmd GhcPs))
e = do
    LHsCmd GhcPs -> PV ()
checkCmdBlockArguments LHsCmd GhcPs
c
    LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
Located (FunArg (HsCmd GhcPs))
e
    LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdApp GhcPs -> LHsCmd GhcPs -> LHsExpr GhcPs -> HsCmd GhcPs
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp NoExtField
XCmdApp GhcPs
noExtField LHsCmd GhcPs
c LHsExpr GhcPs
Located (FunArg (HsCmd GhcPs))
e)
  mkHsAppTypePV :: SrcSpan -> LHsCmd GhcPs -> LHsType GhcPs -> PV (LHsCmd GhcPs)
mkHsAppTypePV SrcSpan
l LHsCmd GhcPs
c LHsType GhcPs
t = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
c SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
  mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> LHsCmd GhcPs
-> Bool
-> LHsCmd GhcPs
-> PV (LHsCmd GhcPs)
mkHsIfPV SrcSpan
l LHsExpr GhcPs
c Bool
semi1 LHsCmd GhcPs
a Bool
semi2 LHsCmd GhcPs
b = do
    LHsExpr GhcPs
-> Bool -> LHsCmd GhcPs -> Bool -> LHsCmd GhcPs -> PV ()
forall a b c.
(Outputable a, Outputable b, Outputable c) =>
Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse LHsExpr GhcPs
c Bool
semi1 LHsCmd GhcPs
a Bool
semi2 LHsCmd GhcPs
b
    LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
mkHsCmdIf LHsExpr GhcPs
c LHsCmd GhcPs
a LHsCmd GhcPs
b)
  mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> Located [LStmt GhcPs (LHsCmd GhcPs)]
-> PV (LHsCmd GhcPs)
mkHsDoPV SrcSpan
l Maybe ModuleName
Nothing Located [LStmt GhcPs (LHsCmd GhcPs)]
stmts = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdDo GhcPs -> Located [LStmt GhcPs (LHsCmd GhcPs)] -> HsCmd GhcPs
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo NoExtField
XCmdDo GhcPs
noExtField Located [LStmt GhcPs (LHsCmd GhcPs)]
stmts)
  mkHsDoPV SrcSpan
l (Just ModuleName
m)    Located [LStmt GhcPs (LHsCmd GhcPs)]
_ =
    SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"Found a qualified" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
".do block in a command, but"
      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"qualified 'do' is not supported in commands."
  mkHsParPV :: SrcSpan -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsParPV SrcSpan
l LHsCmd GhcPs
c = LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcPs -> PV (LHsCmd GhcPs))
-> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsCmd GhcPs -> LHsCmd GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCmdPar GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar NoExtField
XCmdPar GhcPs
noExtField LHsCmd GhcPs
c)
  mkHsVarPV :: Located RdrName -> PV (LHsCmd GhcPs)
mkHsVarPV (L SrcSpan
l RdrName
v) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
v)
  mkHsLitPV :: Located (HsLit GhcPs) -> PV (LHsCmd GhcPs)
mkHsLitPV (L SrcSpan
l HsLit GhcPs
a) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (HsLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit GhcPs
a)
  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (LHsCmd GhcPs)
mkHsOverLitPV (L SrcSpan
l HsOverLit GhcPs
a) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (HsOverLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcPs
a)
  mkHsWildCardPV :: SrcSpan -> PV (LHsCmd GhcPs)
mkHsWildCardPV SrcSpan
l = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (String -> SDoc
text String
"_")
  mkHsTySigPV :: SrcSpan -> LHsCmd GhcPs -> LHsType GhcPs -> PV (LHsCmd GhcPs)
mkHsTySigPV SrcSpan
l LHsCmd GhcPs
a LHsType GhcPs
sig = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
a SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
sig)
  mkHsExplicitListPV :: SrcSpan -> [LHsCmd GhcPs] -> PV (LHsCmd GhcPs)
mkHsExplicitListPV SrcSpan
l [LHsCmd GhcPs]
xs = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    SDoc -> SDoc
brackets ([SDoc] -> SDoc
fsep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((LHsCmd GhcPs -> SDoc) -> [LHsCmd GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsCmd GhcPs]
xs)))
  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (LHsCmd GhcPs)
mkHsSplicePV (L SrcSpan
l HsSplice GhcPs
sp) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (HsSplice GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSplice GhcPs
sp)
  mkHsRecordPV :: SrcSpan
-> SrcSpan
-> LHsCmd GhcPs
-> ([LHsRecField GhcPs (LHsCmd GhcPs)], Maybe SrcSpan)
-> PV (LHsCmd GhcPs)
mkHsRecordPV SrcSpan
l SrcSpan
_ LHsCmd GhcPs
a ([LHsRecField GhcPs (LHsCmd GhcPs)]
fbinds, Maybe SrcSpan
ddLoc) = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
a SDoc -> SDoc -> SDoc
<+> HsRecFields GhcPs (LHsCmd GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([LHsRecField GhcPs (LHsCmd GhcPs)]
-> Maybe SrcSpan -> HsRecFields GhcPs (LHsCmd GhcPs)
forall id arg.
[LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields [LHsRecField GhcPs (LHsCmd GhcPs)]
fbinds Maybe SrcSpan
ddLoc)
  mkHsNegAppPV :: SrcSpan -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsNegAppPV SrcSpan
l LHsCmd GhcPs
a = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (String -> SDoc
text String
"-" SDoc -> SDoc -> SDoc
<> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
a)
  mkHsSectionR_PV :: SrcSpan
-> Located (InfixOp (HsCmd GhcPs))
-> LHsCmd GhcPs
-> PV (LHsCmd GhcPs)
mkHsSectionR_PV SrcSpan
l Located (InfixOp (HsCmd GhcPs))
op LHsCmd GhcPs
c = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    let pp_op :: SDoc
pp_op = SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe (String -> SDoc
forall a. String -> a
panic String
"cannot print infix operator")
                          (HsExpr GhcPs -> Maybe SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
Located (InfixOp (HsCmd GhcPs))
op))
    in SDoc
pp_op SDoc -> SDoc -> SDoc
<> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
c
  mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsViewPatPV SrcSpan
l LHsExpr GhcPs
a LHsCmd GhcPs
b = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
a SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"->" SDoc -> SDoc -> SDoc
<+> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
b
  mkHsAsPatPV :: SrcSpan -> Located RdrName -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsAsPatPV SrcSpan
l Located RdrName
v LHsCmd GhcPs
c = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    RdrName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
v) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
c
  mkHsLazyPatPV :: SrcSpan -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsLazyPatPV SrcSpan
l LHsCmd GhcPs
c = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"~" SDoc -> SDoc -> SDoc
<> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
c
  mkHsBangPatPV :: SrcSpan -> LHsCmd GhcPs -> PV (LHsCmd GhcPs)
mkHsBangPatPV SrcSpan
l LHsCmd GhcPs
c = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (SDoc -> PV (LHsCmd GhcPs)) -> SDoc -> PV (LHsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"!" SDoc -> SDoc -> SDoc
<> LHsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsCmd GhcPs
c
  mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple (HsCmd GhcPs) -> PV (LHsCmd GhcPs)
mkSumOrTuplePV SrcSpan
l Boxity
boxity SumOrTuple (HsCmd GhcPs)
a = SrcSpan -> SDoc -> PV (LHsCmd GhcPs)
forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
l (Boxity -> SumOrTuple (HsCmd GhcPs) -> SDoc
forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
boxity SumOrTuple (HsCmd GhcPs)
a)
  rejectPragmaPV :: LHsCmd GhcPs -> PV ()
rejectPragmaPV LHsCmd GhcPs
_ = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

cmdFail :: SrcSpan -> SDoc -> PV a
cmdFail :: forall a. SrcSpan -> SDoc -> PV a
cmdFail SrcSpan
loc SDoc
e = SrcSpan -> SDoc -> PV a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> PV a) -> SDoc -> PV a
forall a b. (a -> b) -> a -> b
$
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Parse error in command:") Int
2 (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
e)

instance DisambECP (HsExpr GhcPs) where
  type Body (HsExpr GhcPs) = HsExpr
  ecpFromCmd' :: LHsCmd GhcPs -> PV (LHsExpr GhcPs)
ecpFromCmd' (L SrcSpan
l HsCmd GhcPs
c) = do
    SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
      [ String -> SDoc
text String
"Arrow command found where an expression was expected:",
        Int -> SDoc -> SDoc
nest Int
2 (HsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsCmd GhcPs
c) ]
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
forall (id :: Pass). HsExpr (GhcPass id)
hsHoleExpr)
  ecpFromExp' :: LHsExpr GhcPs -> PV (LHsExpr GhcPs)
ecpFromExp' = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return
  mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkHsLamPV SrcSpan
l MatchGroup GhcPs (LHsExpr GhcPs)
mg = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
mg)
  mkHsLetPV :: SrcSpan
-> LHsLocalBinds GhcPs -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsLetPV SrcSpan
l LHsLocalBinds GhcPs
bs LHsExpr GhcPs
c = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XLet GhcPs -> LHsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet NoExtField
XLet GhcPs
noExtField LHsLocalBinds GhcPs
bs LHsExpr GhcPs
c)
  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
  superInfixOp :: (DisambInfixOp (InfixOp (HsExpr GhcPs)) => PV (LHsExpr GhcPs))
-> PV (LHsExpr GhcPs)
superInfixOp DisambInfixOp (InfixOp (HsExpr GhcPs)) => PV (LHsExpr GhcPs)
m = PV (LHsExpr GhcPs)
DisambInfixOp (InfixOp (HsExpr GhcPs)) => PV (LHsExpr GhcPs)
m
  mkHsOpAppPV :: SrcSpan
-> LHsExpr GhcPs
-> Located (InfixOp (HsExpr GhcPs))
-> LHsExpr GhcPs
-> PV (LHsExpr GhcPs)
mkHsOpAppPV SrcSpan
l LHsExpr GhcPs
e1 Located (InfixOp (HsExpr GhcPs))
op LHsExpr GhcPs
e2 = do
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
e1 LHsExpr GhcPs
Located (InfixOp (HsExpr GhcPs))
op LHsExpr GhcPs
e2
  mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> PV (LHsExpr GhcPs)
mkHsCasePV SrcSpan
l LHsExpr GhcPs
e MatchGroup GhcPs (LHsExpr GhcPs)
mg = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCase GhcPs
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase NoExtField
XCase GhcPs
noExtField LHsExpr GhcPs
e MatchGroup GhcPs (LHsExpr GhcPs)
mg)
  mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkHsLamCasePV SrcSpan
l MatchGroup GhcPs (LHsExpr GhcPs)
mg = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XLamCase GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase NoExtField
XLamCase GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
mg)
  type FunArg (HsExpr GhcPs) = HsExpr GhcPs
  superFunArg :: (DisambECP (FunArg (HsExpr GhcPs)) => PV (LHsExpr GhcPs))
-> PV (LHsExpr GhcPs)
superFunArg DisambECP (FunArg (HsExpr GhcPs)) => PV (LHsExpr GhcPs)
m = PV (LHsExpr GhcPs)
DisambECP (FunArg (HsExpr GhcPs)) => PV (LHsExpr GhcPs)
m
  mkHsAppPV :: SrcSpan
-> LHsExpr GhcPs
-> Located (FunArg (HsExpr GhcPs))
-> PV (LHsExpr GhcPs)
mkHsAppPV SrcSpan
l LHsExpr GhcPs
e1 Located (FunArg (HsExpr GhcPs))
e2 = do
    LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
e1
    LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
Located (FunArg (HsExpr GhcPs))
e2
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
e1 LHsExpr GhcPs
Located (FunArg (HsExpr GhcPs))
e2)
  mkHsAppTypePV :: SrcSpan -> LHsExpr GhcPs -> LHsType GhcPs -> PV (LHsExpr GhcPs)
mkHsAppTypePV SrcSpan
l LHsExpr GhcPs
e LHsType GhcPs
t = do
    LHsExpr GhcPs -> PV ()
checkExpBlockArguments LHsExpr GhcPs
e
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcPs
noExtField LHsExpr GhcPs
e (LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsType GhcPs)
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
t))
  mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> PV (LHsExpr GhcPs)
mkHsIfPV SrcSpan
l LHsExpr GhcPs
c Bool
semi1 LHsExpr GhcPs
a Bool
semi2 LHsExpr GhcPs
b = do
    LHsExpr GhcPs
-> Bool -> LHsExpr GhcPs -> Bool -> LHsExpr GhcPs -> PV ()
forall a b c.
(Outputable a, Outputable b, Outputable c) =>
Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse LHsExpr GhcPs
c Bool
semi1 LHsExpr GhcPs
a Bool
semi2 LHsExpr GhcPs
b
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsIf LHsExpr GhcPs
c LHsExpr GhcPs
a LHsExpr GhcPs
b)
  mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> Located [ExprLStmt GhcPs]
-> PV (LHsExpr GhcPs)
mkHsDoPV SrcSpan
l Maybe ModuleName
mod Located [ExprLStmt GhcPs]
stmts = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XDo GhcPs
-> HsStmtContext GhcRn -> Located [ExprLStmt GhcPs] -> HsExpr GhcPs
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo NoExtField
XDo GhcPs
noExtField (Maybe ModuleName -> HsStmtContext GhcRn
forall p. Maybe ModuleName -> HsStmtContext p
DoExpr Maybe ModuleName
mod) Located [ExprLStmt GhcPs]
stmts)
  mkHsParPV :: SrcSpan -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsParPV SrcSpan
l LHsExpr GhcPs
e = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
e)
  mkHsVarPV :: Located RdrName -> PV (LHsExpr GhcPs)
mkHsVarPV v :: Located RdrName
v@(Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc -> SrcSpan
l) = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v)
  mkHsLitPV :: Located (HsLit GhcPs) -> PV (LHsExpr GhcPs)
mkHsLitPV (L SrcSpan
l HsLit GhcPs
a) = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcPs
noExtField HsLit GhcPs
a)
  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (LHsExpr GhcPs)
mkHsOverLitPV (L SrcSpan
l HsOverLit GhcPs
a) = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit NoExtField
XOverLitE GhcPs
noExtField HsOverLit GhcPs
a)
  mkHsWildCardPV :: SrcSpan -> PV (LHsExpr GhcPs)
mkHsWildCardPV SrcSpan
l = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
forall (id :: Pass). HsExpr (GhcPass id)
hsHoleExpr
  mkHsTySigPV :: SrcSpan -> LHsExpr GhcPs -> LHsType GhcPs -> PV (LHsExpr GhcPs)
mkHsTySigPV SrcSpan
l LHsExpr GhcPs
a LHsType GhcPs
sig = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noExtField LHsExpr GhcPs
a (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig))
  mkHsExplicitListPV :: SrcSpan -> [LHsExpr GhcPs] -> PV (LHsExpr GhcPs)
mkHsExplicitListPV SrcSpan
l [LHsExpr GhcPs]
xs = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XExplicitList GhcPs
-> Maybe (SyntaxExpr GhcPs) -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
XExplicitList GhcPs
noExtField Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing [LHsExpr GhcPs]
xs)
  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (LHsExpr GhcPs)
mkHsSplicePV Located (HsSplice GhcPs)
sp = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (HsSplice GhcPs -> HsExpr GhcPs)
-> Located (HsSplice GhcPs) -> LHsExpr GhcPs
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (XSpliceE GhcPs -> HsSplice GhcPs -> HsExpr GhcPs
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE NoExtField
XSpliceE GhcPs
noExtField) Located (HsSplice GhcPs)
sp
  mkHsRecordPV :: SrcSpan
-> SrcSpan
-> LHsExpr GhcPs
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (LHsExpr GhcPs)
mkHsRecordPV SrcSpan
l SrcSpan
lrec LHsExpr GhcPs
a ([LHsRecField GhcPs (LHsExpr GhcPs)]
fbinds, Maybe SrcSpan
ddLoc) = do
    HsExpr GhcPs
r <- LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate LHsExpr GhcPs
a SrcSpan
lrec ([LHsRecField GhcPs (LHsExpr GhcPs)]
fbinds, Maybe SrcSpan
ddLoc)
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
Located a -> m (Located a)
checkRecordSyntax (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
r)
  mkHsNegAppPV :: SrcSpan -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsNegAppPV SrcSpan
l LHsExpr GhcPs
a = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XNegApp GhcPs -> LHsExpr GhcPs -> SyntaxExpr GhcPs -> HsExpr GhcPs
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp NoExtField
XNegApp GhcPs
noExtField LHsExpr GhcPs
a SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr)
  mkHsSectionR_PV :: SrcSpan
-> Located (InfixOp (HsExpr GhcPs))
-> LHsExpr GhcPs
-> PV (LHsExpr GhcPs)
mkHsSectionR_PV SrcSpan
l Located (InfixOp (HsExpr GhcPs))
op LHsExpr GhcPs
e = LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
Located (InfixOp (HsExpr GhcPs))
op LHsExpr GhcPs
e)
  mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsViewPatPV SrcSpan
l LHsExpr GhcPs
a LHsExpr GhcPs
b = String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr String
"View pattern" SrcSpan
l (LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
a SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"->" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
b) SDoc
empty
  mkHsAsPatPV :: SrcSpan -> Located RdrName -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsAsPatPV SrcSpan
l Located RdrName
v LHsExpr GhcPs
e =
    String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr String
"@-pattern" SrcSpan
l (RdrName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
v) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
e) (SDoc -> PV (LHsExpr GhcPs)) -> SDoc -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Type application syntax requires a space before '@'"
  mkHsLazyPatPV :: SrcSpan -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsLazyPatPV SrcSpan
l LHsExpr GhcPs
e = String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr String
"Lazy pattern" SrcSpan
l (String -> SDoc
text String
"~" SDoc -> SDoc -> SDoc
<> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
e) (SDoc -> PV (LHsExpr GhcPs)) -> SDoc -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Did you mean to add a space after the '~'?"
  mkHsBangPatPV :: SrcSpan -> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
mkHsBangPatPV SrcSpan
l LHsExpr GhcPs
e = String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr String
"Bang pattern" SrcSpan
l (String -> SDoc
text String
"!" SDoc -> SDoc -> SDoc
<> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
e) (SDoc -> PV (LHsExpr GhcPs)) -> SDoc -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Did you mean to add a space after the '!'?"
  mkSumOrTuplePV :: SrcSpan
-> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkSumOrTuplePV = SrcSpan
-> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkSumOrTupleExpr
  rejectPragmaPV :: LHsExpr GhcPs -> PV ()
rejectPragmaPV (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
e)) =
    -- assuming left-associative parsing of operators
    LHsExpr GhcPs -> PV ()
forall b. DisambECP b => Located b -> PV ()
rejectPragmaPV LHsExpr GhcPs
e
  rejectPragmaPV (L SrcSpan
l (HsPragE XPragE GhcPs
_ HsPragE GhcPs
prag LHsExpr GhcPs
_)) =
    SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A pragma is not allowed in this position:") Int
2 (HsPragE GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE GhcPs
prag)
  rejectPragmaPV LHsExpr GhcPs
_ = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr String
item SrcSpan
l SDoc
e SDoc
explanation =
  do { SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
        [SDoc] -> SDoc
sep [String -> SDoc
text String
item SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in expression context:",
             Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
e)] SDoc -> SDoc -> SDoc
$$
        SDoc
explanation
     ; LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
forall (id :: Pass). HsExpr (GhcPass id)
hsHoleExpr) }

hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr :: forall (id :: Pass). HsExpr (GhcPass id)
hsHoleExpr = XUnboundVar (GhcPass id) -> OccName -> HsExpr (GhcPass id)
forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar NoExtField
XUnboundVar (GhcPass id)
noExtField (String -> OccName
mkVarOcc String
"_")

-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
data PatBuilder p
  = PatBuilderPat (Pat p)
  | PatBuilderPar (Located (PatBuilder p))
  | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
  | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
  | PatBuilderVar (Located RdrName)
  | PatBuilderOverLit (HsOverLit GhcPs)

instance Outputable (PatBuilder GhcPs) where
  ppr :: PatBuilder GhcPs -> SDoc
ppr (PatBuilderPat Pat GhcPs
p) = Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
p
  ppr (PatBuilderPar (L SrcSpan
_ PatBuilder GhcPs
p)) = SDoc -> SDoc
parens (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p)
  ppr (PatBuilderApp (L SrcSpan
_ PatBuilder GhcPs
p1) (L SrcSpan
_ PatBuilder GhcPs
p2)) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p1 SDoc -> SDoc -> SDoc
<+> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p2
  ppr (PatBuilderOpApp (L SrcSpan
_ PatBuilder GhcPs
p1) Located RdrName
op (L SrcSpan
_ PatBuilder GhcPs
p2)) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p1 SDoc -> SDoc -> SDoc
<+> Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
op SDoc -> SDoc -> SDoc
<+> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p2
  ppr (PatBuilderVar Located RdrName
v) = Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
v
  ppr (PatBuilderOverLit HsOverLit GhcPs
l) = HsOverLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcPs
l

instance DisambECP (PatBuilder GhcPs) where
  type Body (PatBuilder GhcPs) = PatBuilder
  ecpFromCmd' :: LHsCmd GhcPs -> PV (Located (PatBuilder GhcPs))
ecpFromCmd' (L SrcSpan
l HsCmd GhcPs
c) =
    SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"Command syntax in pattern:" SDoc -> SDoc -> SDoc
<+> HsCmd GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsCmd GhcPs
c
  ecpFromExp' :: LHsExpr GhcPs -> PV (Located (PatBuilder GhcPs))
ecpFromExp' (L SrcSpan
l HsExpr GhcPs
e) =
    SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"Expression syntax in pattern:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
  mkHsLamPV :: SrcSpan
-> MatchGroup GhcPs (Located (PatBuilder GhcPs))
-> PV (Located (PatBuilder GhcPs))
mkHsLamPV SrcSpan
l MatchGroup GhcPs (Located (PatBuilder GhcPs))
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Lambda-syntax in pattern." SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Pattern matching on functions is not possible."
  mkHsLetPV :: SrcSpan
-> LHsLocalBinds GhcPs
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsLetPV SrcSpan
l LHsLocalBinds GhcPs
_ Located (PatBuilder GhcPs)
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"(let ... in ...)-syntax in pattern"
  type InfixOp (PatBuilder GhcPs) = RdrName
  superInfixOp :: (DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
 PV (Located (PatBuilder GhcPs)))
-> PV (Located (PatBuilder GhcPs))
superInfixOp DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
PV (Located (PatBuilder GhcPs))
m = PV (Located (PatBuilder GhcPs))
DisambInfixOp (InfixOp (PatBuilder GhcPs)) =>
PV (Located (PatBuilder GhcPs))
m
  mkHsOpAppPV :: SrcSpan
-> Located (PatBuilder GhcPs)
-> Located (InfixOp (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsOpAppPV SrcSpan
l Located (PatBuilder GhcPs)
p1 Located (InfixOp (PatBuilder GhcPs))
op Located (PatBuilder GhcPs)
p2 = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (PatBuilder GhcPs -> Located (PatBuilder GhcPs))
-> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$ Located (PatBuilder GhcPs)
-> Located RdrName
-> Located (PatBuilder GhcPs)
-> PatBuilder GhcPs
forall p.
Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
PatBuilderOpApp Located (PatBuilder GhcPs)
p1 Located RdrName
Located (InfixOp (PatBuilder GhcPs))
op Located (PatBuilder GhcPs)
p2
  mkHsCasePV :: SrcSpan
-> LHsExpr GhcPs
-> MatchGroup GhcPs (Located (PatBuilder GhcPs))
-> PV (Located (PatBuilder GhcPs))
mkHsCasePV SrcSpan
l LHsExpr GhcPs
_ MatchGroup GhcPs (Located (PatBuilder GhcPs))
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"(case ... of ...)-syntax in pattern"
  mkHsLamCasePV :: SrcSpan
-> MatchGroup GhcPs (Located (PatBuilder GhcPs))
-> PV (Located (PatBuilder GhcPs))
mkHsLamCasePV SrcSpan
l MatchGroup GhcPs (Located (PatBuilder GhcPs))
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"(\\case ...)-syntax in pattern"
  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
  superFunArg :: (DisambECP (FunArg (PatBuilder GhcPs)) =>
 PV (Located (PatBuilder GhcPs)))
-> PV (Located (PatBuilder GhcPs))
superFunArg DisambECP (FunArg (PatBuilder GhcPs)) =>
PV (Located (PatBuilder GhcPs))
m = PV (Located (PatBuilder GhcPs))
DisambECP (FunArg (PatBuilder GhcPs)) =>
PV (Located (PatBuilder GhcPs))
m
  mkHsAppPV :: SrcSpan
-> Located (PatBuilder GhcPs)
-> Located (FunArg (PatBuilder GhcPs))
-> PV (Located (PatBuilder GhcPs))
mkHsAppPV SrcSpan
l Located (PatBuilder GhcPs)
p1 Located (FunArg (PatBuilder GhcPs))
p2 = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located (PatBuilder GhcPs)
-> Located (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p.
Located (PatBuilder p) -> Located (PatBuilder p) -> PatBuilder p
PatBuilderApp Located (PatBuilder GhcPs)
p1 Located (FunArg (PatBuilder GhcPs))
Located (PatBuilder GhcPs)
p2)
  mkHsAppTypePV :: SrcSpan
-> Located (PatBuilder GhcPs)
-> LHsType GhcPs
-> PV (Located (PatBuilder GhcPs))
mkHsAppTypePV SrcSpan
l Located (PatBuilder GhcPs)
_ LHsType GhcPs
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Type applications in patterns are not yet supported"
  mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> Located (PatBuilder GhcPs)
-> Bool
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsIfPV SrcSpan
l LHsExpr GhcPs
_ Bool
_ Located (PatBuilder GhcPs)
_ Bool
_ Located (PatBuilder GhcPs)
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"(if ... then ... else ...)-syntax in pattern"
  mkHsDoPV :: SrcSpan
-> Maybe ModuleName
-> Located [LStmt GhcPs (Located (PatBuilder GhcPs))]
-> PV (Located (PatBuilder GhcPs))
mkHsDoPV SrcSpan
l Maybe ModuleName
_ Located [LStmt GhcPs (Located (PatBuilder GhcPs))]
_ = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> PV (Located (PatBuilder GhcPs)))
-> SDoc -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"do-notation in pattern"
  mkHsParPV :: SrcSpan
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsParPV SrcSpan
l Located (PatBuilder GhcPs)
p = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p. Located (PatBuilder p) -> PatBuilder p
PatBuilderPar Located (PatBuilder GhcPs)
p)
  mkHsVarPV :: Located RdrName -> PV (Located (PatBuilder GhcPs))
mkHsVarPV v :: Located RdrName
v@(Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc -> SrcSpan
l) = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located RdrName -> PatBuilder GhcPs
forall p. Located RdrName -> PatBuilder p
PatBuilderVar Located RdrName
v)
  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsLitPV lit :: Located (HsLit GhcPs)
lit@(L SrcSpan
l HsLit GhcPs
a) = do
    Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat Located (HsLit GhcPs)
lit
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XLitPat GhcPs -> HsLit GhcPs -> Pat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
LitPat NoExtField
XLitPat GhcPs
noExtField HsLit GhcPs
a))
  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsOverLitPV (L SrcSpan
l HsOverLit GhcPs
a) = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsOverLit GhcPs -> PatBuilder GhcPs
forall p. HsOverLit GhcPs -> PatBuilder p
PatBuilderOverLit HsOverLit GhcPs
a)
  mkHsWildCardPV :: SrcSpan -> PV (Located (PatBuilder GhcPs))
mkHsWildCardPV SrcSpan
l = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField))
  mkHsTySigPV :: SrcSpan
-> Located (PatBuilder GhcPs)
-> LHsType GhcPs
-> PV (Located (PatBuilder GhcPs))
mkHsTySigPV SrcSpan
l Located (PatBuilder GhcPs)
b LHsType GhcPs
sig = do
    Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
b
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat NoExtField
XSigPat GhcPs
noExtField Located (Pat GhcPs)
LPat GhcPs
p (LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType LHsType GhcPs
sig)))
  mkHsExplicitListPV :: SrcSpan
-> [Located (PatBuilder GhcPs)] -> PV (Located (PatBuilder GhcPs))
mkHsExplicitListPV SrcSpan
l [Located (PatBuilder GhcPs)]
xs = do
    [Located (Pat GhcPs)]
ps <- (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [Located (PatBuilder GhcPs)]
xs
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XListPat GhcPs -> [LPat GhcPs] -> Pat GhcPs
forall p. XListPat p -> [LPat p] -> Pat p
ListPat NoExtField
XListPat GhcPs
noExtField [Located (Pat GhcPs)]
[LPat GhcPs]
ps)))
  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsSplicePV (L SrcSpan
l HsSplice GhcPs
sp) = Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XSplicePat GhcPs -> HsSplice GhcPs -> Pat GhcPs
forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat NoExtField
XSplicePat GhcPs
noExtField HsSplice GhcPs
sp))
  mkHsRecordPV :: SrcSpan
-> SrcSpan
-> Located (PatBuilder GhcPs)
-> ([LHsRecField GhcPs (Located (PatBuilder GhcPs))],
    Maybe SrcSpan)
-> PV (Located (PatBuilder GhcPs))
mkHsRecordPV SrcSpan
l SrcSpan
_ Located (PatBuilder GhcPs)
a ([LHsRecField GhcPs (Located (PatBuilder GhcPs))]
fbinds, Maybe SrcSpan
ddLoc) = do
    PatBuilder GhcPs
r <- Located (PatBuilder GhcPs)
-> HsRecFields GhcPs (Located (PatBuilder GhcPs))
-> PV (PatBuilder GhcPs)
mkPatRec Located (PatBuilder GhcPs)
a ([LHsRecField GhcPs (Located (PatBuilder GhcPs))]
-> Maybe SrcSpan -> HsRecFields GhcPs (Located (PatBuilder GhcPs))
forall id arg.
[LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields [LHsRecField GhcPs (Located (PatBuilder GhcPs))]
fbinds Maybe SrcSpan
ddLoc)
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
Located a -> m (Located a)
checkRecordSyntax (SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l PatBuilder GhcPs
r)
  mkHsNegAppPV :: SrcSpan
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsNegAppPV SrcSpan
l (L SrcSpan
lp PatBuilder GhcPs
p) = do
    Located (HsOverLit GhcPs)
lit <- case PatBuilder GhcPs
p of
      PatBuilderOverLit HsOverLit GhcPs
pos_lit -> Located (HsOverLit GhcPs) -> PV (Located (HsOverLit GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
lp HsOverLit GhcPs
pos_lit)
      PatBuilder GhcPs
_ -> SrcSpan -> SDoc -> PV (Located (HsOverLit GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (String -> SDoc
text String
"-" SDoc -> SDoc -> SDoc
<> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p)
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs
mkNPat Located (HsOverLit GhcPs)
lit (NoExtField -> Maybe NoExtField
forall a. a -> Maybe a
Just NoExtField
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr)))
  mkHsSectionR_PV :: SrcSpan
-> Located (InfixOp (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsSectionR_PV SrcSpan
l Located (InfixOp (PatBuilder GhcPs))
op Located (PatBuilder GhcPs)
p = SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (RdrName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
Located (InfixOp (PatBuilder GhcPs))
op) SDoc -> SDoc -> SDoc
<> Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
p)
  mkHsViewPatPV :: SrcSpan
-> LHsExpr GhcPs
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsViewPatPV SrcSpan
l LHsExpr GhcPs
a Located (PatBuilder GhcPs)
b = do
    Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
b
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat NoExtField
XViewPat GhcPs
noExtField LHsExpr GhcPs
a Located (Pat GhcPs)
LPat GhcPs
p))
  mkHsAsPatPV :: SrcSpan
-> Located RdrName
-> Located (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkHsAsPatPV SrcSpan
l Located RdrName
v Located (PatBuilder GhcPs)
e = do
    Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XAsPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs -> Pat GhcPs
forall p. XAsPat p -> Located (IdP p) -> LPat p -> Pat p
AsPat NoExtField
XAsPat GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v Located (Pat GhcPs)
LPat GhcPs
p))
  mkHsLazyPatPV :: SrcSpan
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsLazyPatPV SrcSpan
l Located (PatBuilder GhcPs)
e = do
    Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XLazyPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat NoExtField
XLazyPat GhcPs
noExtField Located (Pat GhcPs)
LPat GhcPs
p))
  mkHsBangPatPV :: SrcSpan
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
mkHsBangPatPV SrcSpan
l Located (PatBuilder GhcPs)
e = do
    Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
    let pb :: Pat GhcPs
pb = XBangPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
XBangPat GhcPs
noExtField Located (Pat GhcPs)
LPat GhcPs
p
    SrcSpan -> Pat GhcPs -> PV ()
hintBangPat SrcSpan
l Pat GhcPs
pb
    Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat Pat GhcPs
pb)
  mkSumOrTuplePV :: SrcSpan
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkSumOrTuplePV = SrcSpan
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkSumOrTuplePat
  rejectPragmaPV :: Located (PatBuilder GhcPs) -> PV ()
rejectPragmaPV Located (PatBuilder GhcPs)
_ = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat (L SrcSpan
loc HsLit GhcPs
lit) =
  case HsLit GhcPs
lit of
    HsStringPrim XHsStringPrim GhcPs
_ ByteString
_  -- Trac #13260
      -> SrcSpan -> SDoc -> PV ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (String -> SDoc
text String
"Illegal unboxed string literal in pattern:" SDoc -> SDoc -> SDoc
$$ HsLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit GhcPs
lit)
    HsLit GhcPs
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

mkPatRec ::
  Located (PatBuilder GhcPs) ->
  HsRecFields GhcPs (Located (PatBuilder GhcPs)) ->
  PV (PatBuilder GhcPs)
mkPatRec :: Located (PatBuilder GhcPs)
-> HsRecFields GhcPs (Located (PatBuilder GhcPs))
-> PV (PatBuilder GhcPs)
mkPatRec (Located (PatBuilder GhcPs) -> PatBuilder GhcPs
forall l e. GenLocated l e -> e
unLoc -> PatBuilderVar Located RdrName
c) (HsRecFields [LHsRecField GhcPs (Located (PatBuilder GhcPs))]
fs Maybe (Located Int)
dd)
  | RdrName -> Bool
isRdrDataCon (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
c)
  = do [GenLocated
   SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))]
fs <- (LHsRecField GhcPs (Located (PatBuilder GhcPs))
 -> PV
      (GenLocated
         SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))))
-> [LHsRecField GhcPs (Located (PatBuilder GhcPs))]
-> PV
     [GenLocated
        SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV
     (GenLocated
        SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))))
LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField [LHsRecField GhcPs (Located (PatBuilder GhcPs))]
fs
       PatBuilder GhcPs -> PV (PatBuilder GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (PatBuilder GhcPs -> PV (PatBuilder GhcPs))
-> PatBuilder GhcPs -> PV (PatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$ Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (Pat GhcPs -> PatBuilder GhcPs) -> Pat GhcPs -> PatBuilder GhcPs
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
         { pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
         , pat_con :: Located (ConLikeP GhcPs)
pat_con = Located RdrName
Located (ConLikeP GhcPs)
c
         , pat_args :: HsConPatDetails GhcPs
pat_args = HsRecFields GhcPs (Located (Pat GhcPs))
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. rec -> HsConDetails arg rec
RecCon ([GenLocated
   SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))]
-> Maybe (Located Int) -> HsRecFields GhcPs (Located (Pat GhcPs))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))]
fs Maybe (Located Int)
dd)
         }
mkPatRec Located (PatBuilder GhcPs)
p HsRecFields GhcPs (Located (PatBuilder GhcPs))
_ =
  SrcSpan -> SDoc -> PV (PatBuilder GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located (PatBuilder GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (PatBuilder GhcPs)
p) (SDoc -> PV (PatBuilder GhcPs)) -> SDoc -> PV (PatBuilder GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Not a record constructor:" SDoc -> SDoc -> SDoc
<+> Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
p

{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

There are places in the grammar where we do not know whether we are parsing an
expression or a pattern without unlimited lookahead (which we do not have in
'happy'):

View patterns:

    f (Con a b     ) = ...  -- 'Con a b' is a pattern
    f (Con a b -> x) = ...  -- 'Con a b' is an expression

do-notation:

    do { Con a b <- x } -- 'Con a b' is a pattern
    do { Con a b }      -- 'Con a b' is an expression

Guards:

    x | True <- p && q = ...  -- 'True' is a pattern
    x | True           = ...  -- 'True' is an expression

Top-level value/function declarations (FunBind/PatBind):

    f ! a         -- TH splice
    f ! a = ...   -- function declaration

    Until we encounter the = sign, we don't know if it's a top-level
    TemplateHaskell splice where ! is used, or if it's a function declaration
    where ! is bound.

There are also places in the grammar where we do not know whether we are
parsing an expression or a command:

    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression
    proc x -> do { (stuff) }        -- 'stuff' is a command

    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'
    as an expression or a command.

In fact, do-notation is subject to both ambiguities:

    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression
    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern
    proc x -> do { (stuff) }             -- 'stuff' is a command

There are many possible solutions to this problem. For an overview of the ones
we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]

The solution that keeps basic definitions (such as HsExpr) clean, keeps the
concerns local to the parser, and does not require duplication of hsSyn types,
or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):

    class DisambECP b where ...
    instance DisambECP (HsCmd GhcPs) where ...
    instance DisambECP (HsExp GhcPs) where ...
    instance DisambECP (PatBuilder GhcPs) where ...

The 'DisambECP' class contains functions to build and validate 'b'. For example,
to add parentheses we have:

  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for
expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,
see Note [PatBuilder]).

Consider the 'alts' production used to parse case-of alternatives:

  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

We abstract over LHsExpr GhcPs, and it becomes:

  alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }
    : alts1     { $1 >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { $2 >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Compared to the initial definition, the added bits are:

    forall b. DisambECP b => PV ( ... ) -- in the type signature
    $1 >>= \ $1 -> return $             -- in one reduction rule
    $2 >>= \ $2 -> return $             -- in another reduction rule

The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions.

Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding
position and shadows the previous $1. We can do this because internally
'happy' desugars $n to happy_var_n, and the rationale behind this idiom
is to be able to write (sLL $1 $>) later on. The alternative would be to
write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
to the last fresh name as $>.
-}


{- Note [Resolving parsing ambiguities: non-taken alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Alternative I, extra constructors in GHC.Hs.Expr
------------------------------------------------
We could add extra constructors to HsExpr to represent command-specific and
pattern-specific syntactic constructs. Under this scheme, we parse patterns
and commands as expressions and rejig later.  This is what GHC used to do, and
it polluted 'HsExpr' with irrelevant constructors:

  * for commands: 'HsArrForm', 'HsArrApp'
  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'

(As of now, we still do that for patterns, but we plan to fix it).

There are several issues with this:

  * The implementation details of parsing are leaking into hsSyn definitions.

  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.

  * HsExpr is arbitrarily selected as the extension basis. Why not extend
    HsCmd or HsPat with extra constructors instead?

Alternative II, extra constructors in GHC.Hs.Expr for GhcPs
-----------------------------------------------------------
We could address some of the problems with Alternative I by using Trees That
Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to
the output of parsing, not to its intermediate results, so we wouldn't want
them there either.

Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs
---------------------------------------------------------------
We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.
Unfortunately, creating a new pass would significantly bloat conversion code
and slow down the compiler by adding another linear-time pass over the entire
AST. For example, in order to build HsExpr GhcPrePs, we would need to build
HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds
GhcPrePs.


Alternative IV, sum type and bottom-up data flow
------------------------------------------------
Expressions and commands are disjoint. There are no user inputs that could be
interpreted as either an expression or a command depending on outer context:

  5        -- definitely an expression
  x -< y   -- definitely a command

Even though we have both 'HsLam' and 'HsCmdLam', we can look at
the body to disambiguate:

  \p -> 5        -- definitely an expression
  \p -> x -< y   -- definitely a command

This means we could use a bottom-up flow of information to determine
whether we are parsing an expression or a command, using a sum type
for intermediate results:

  Either (LHsExpr GhcPs) (LHsCmd GhcPs)

There are two problems with this:

  * We cannot handle the ambiguity between expressions and
    patterns, which are not disjoint.

  * Bottom-up flow of information leads to poor error messages. Consider

        if ... then 5 else (x -< y)

    Do we report that '5' is not a valid command or that (x -< y) is not a
    valid expression?  It depends on whether we want the entire node to be
    'HsIf' or 'HsCmdIf', and this information flows top-down, from the
    surrounding parsing context (are we in 'proc'?)

Alternative V, backtracking with parser combinators
---------------------------------------------------
One might think we could sidestep the issue entirely by using a backtracking
parser and doing something along the lines of (try pExpr <|> pPat).

Turns out, this wouldn't work very well, as there can be patterns inside
expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns
(e.g. view patterns). To handle this, we would need to backtrack while
backtracking, and unbound levels of backtracking lead to very fragile
performance.

Alternative VI, an intermediate data type
-----------------------------------------
There are common syntactic elements of expressions, commands, and patterns
(e.g. all of them must have balanced parentheses), and we can capture this
common structure in an intermediate data type, Frame:

data Frame
  = FrameVar RdrName
    -- ^ Identifier: Just, map, BS.length
  | FrameTuple [LTupArgFrame] Boxity
    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)
  | FrameTySig LFrame (LHsSigWcType GhcPs)
    -- ^ Type signature: x :: ty
  | FramePar (SrcSpan, SrcSpan) LFrame
    -- ^ Parentheses
  | FrameIf LFrame LFrame LFrame
    -- ^ If-expression: if p then x else y
  | FrameCase LFrame [LFrameMatch]
    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
  | FrameDo (HsStmtContext GhcRn) [LFrameStmt]
    -- ^ Do-expression: do { s1; a <- s2; s3 }
  ...
  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression
  | FramePat (HsPat GhcPs)     -- unambiguously a pattern
  | FrameCommand (HsCmd GhcPs) -- unambiguously a command

To determine which constructors 'Frame' needs to have, we take the union of
intersections between HsExpr, HsCmd, and HsPat.

The intersection between HsPat and HsExpr:

  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...
  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...
  -------------------------------------------------------------------
  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...

The intersection between HsCmd and HsExpr:

  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar
  HsExpr = HsIf    | HsCase    | HsDo    | HsPar
  ------------------------------------------------
  Frame = FrameIf  | FrameCase | FrameDo | FramePar

The intersection between HsCmd and HsPat:

  HsPat  = ParPat   | ...
  HsCmd  = HsCmdPar | ...
  -----------------------
  Frame  = FramePar | ...

Take the union of each intersection and this yields the final 'Frame' data
type. The problem with this approach is that we end up duplicating a good
portion of hsSyn:

    Frame         for  HsExpr, HsPat, HsCmd
    TupArgFrame   for  HsTupArg
    FrameMatch    for  Match
    FrameStmt     for  StmtLR
    FrameGRHS     for  GRHS
    FrameGRHSs    for  GRHSs
    ...

Alternative VII, a product type
-------------------------------
We could avoid the intermediate representation of Alternative VI by parsing
into a product of interpretations directly:

    -- See Note [Parser-Validator]
    type ExpCmdPat = ( PV (LHsExpr GhcPs)
                     , PV (LHsCmd GhcPs)
                     , PV (LHsPat GhcPs) )

This means that in positions where we do not know whether to produce
expression, a pattern, or a command, we instead produce a parser-validator for
each possible option.

Then, as soon as we have parsed far enough to resolve the ambiguity, we pick
the appropriate component of the product, discarding the rest:

    checkExpOf3 (e, _, _) = e  -- interpret as an expression
    checkCmdOf3 (_, c, _) = c  -- interpret as a command
    checkPatOf3 (_, _, p) = p  -- interpret as a pattern

We can easily define ambiguities between arbitrary subsets of interpretations.
For example, when we know ahead of type that only an expression or a command is
possible, but not a pattern, we can use a smaller type:

    -- See Note [Parser-Validator]
    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))

    checkExpOf2 (e, _) = e  -- interpret as an expression
    checkCmdOf2 (_, c) = c  -- interpret as a command

However, there is a slight problem with this approach, namely code duplication
in parser productions. Consider the 'alts' production used to parse case-of
alternatives:

  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Under the new scheme, we have to completely duplicate its type signature and
each reduction rule:

  alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression
            , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command
            ) }
    : alts1
        { ( checkExpOf2 $1 >>= \ $1 ->
            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
          , checkCmdOf2 $1 >>= \ $1 ->
            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
          ) }
    | ';' alts
        { ( checkExpOf2 $2 >>= \ $2 ->
            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
          , checkCmdOf2 $2 >>= \ $2 ->
            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
          ) }

And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!

Alternative VIII, a function from a GADT
----------------------------------------
We could avoid code duplication of the Alternative VII by representing the product
as a function from a GADT:

    data ExpCmdG b where
      ExpG :: ExpCmdG HsExpr
      CmdG :: ExpCmdG HsCmd

    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))

    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
    checkExp f = f ExpG  -- interpret as an expression
    checkCmd f = f CmdG  -- interpret as a command

Consider the 'alts' production used to parse case-of alternatives:

  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

We abstract over LHsExpr, and it becomes:

  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
    : alts1
        { \tag -> $1 tag >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts
        { \tag -> $2 tag >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

Note that 'ExpCmdG' is a singleton type, the value is completely
determined by the type:

  when (b~HsExpr),  tag = ExpG
  when (b~HsCmd),   tag = CmdG

This is a clear indication that we can use a class to pass this value behind
the scenes:

  class    ExpCmdI b      where expCmdG :: ExpCmdG b
  instance ExpCmdI HsExpr where expCmdG = ExpG
  instance ExpCmdI HsCmd  where expCmdG = CmdG

And now the 'alts' production is simplified, as we no longer need to
thread 'tag' explicitly:

  alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
    : alts1     { $1 >>= \ $1 ->
                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
    | ';' alts  { $2 >>= \ $2 ->
                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }

This encoding works well enough, but introduces an extra GADT unlike the
tagless final encoding, and there's no need for this complexity.

-}

{- Note [PatBuilder]
~~~~~~~~~~~~~~~~~~~~
Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,
so we introduce the notion of a PatBuilder.

Consider a pattern like this:

  Con a b c

We parse arguments to "Con" one at a time in the  fexp aexp  parser production,
building the result with mkHsAppPV, so the intermediate forms are:

  1. Con
  2. Con a
  3. Con a b
  4. Con a b c

In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like
this (pseudocode):

  1. "Con"
  2. HsApp "Con" "a"
  3. HsApp (HsApp "Con" "a") "b"
  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"

Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have
instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for
the intermediate forms.

We also need an intermediate representation to postpone disambiguation between
FunBind and PatBind. Consider:

  a `Con` b = ...
  a `fun` b = ...

How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We
learn this by inspecting an intermediate representation in 'isFunLhs' and
seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate
representation capable of representing both a FunBind and a PatBind, so Pat is
insufficient.

PatBuilder is an extension of Pat that is capable of representing intermediate
parsing results for patterns and function bindings:

  data PatBuilder p
    = PatBuilderPat (Pat p)
    | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
    | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
    ...

It can represent any pattern via 'PatBuilderPat', but it also has a variety of
other constructors which were added by following a simple principle: we never
pattern match on the pattern stored inside 'PatBuilderPat'.
-}

---------------------------------------------------------------------------
-- Miscellaneous utilities

-- | Check if a fixity is valid. We support bypassing the usual bound checks
-- for some special operators.
checkPrecP
        :: Located (SourceText,Int)             -- ^ precedence
        -> Located (OrdList (Located RdrName))  -- ^ operators
        -> P ()
checkPrecP :: Located (SourceText, Int)
-> Located (OrdList (Located RdrName)) -> P ()
checkPrecP (L SrcSpan
l (SourceText
_,Int
i)) (L SrcSpan
_ OrdList (Located RdrName)
ol)
 | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPrecedence = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 | (Located RdrName -> Bool) -> OrdList (Located RdrName) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Located RdrName -> Bool
forall {l}. GenLocated l RdrName -> Bool
specialOp OrdList (Located RdrName)
ol = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 | Bool
otherwise = SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (String -> SDoc
text (String
"Precedence out of range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i))
  where
    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
    specialOp :: GenLocated l RdrName -> Bool
specialOp GenLocated l RdrName
op = GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated l RdrName
op RdrName -> [RdrName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ RdrName
eqTyCon_RDR
                                   , TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon ]

mkRecConstrOrUpdate
        :: LHsExpr GhcPs
        -> SrcSpan
        -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
        -> PV (HsExpr GhcPs)

mkRecConstrOrUpdate :: LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate (L SrcSpan
l (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
c))) SrcSpan
_ ([LHsRecField GhcPs (LHsExpr GhcPs)]
fs,Maybe SrcSpan
dd)
  | RdrName -> Bool
isRdrDataCon RdrName
IdP GhcPs
c
  = HsExpr GhcPs -> PV (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
IdP GhcPs
c) ([LHsRecField GhcPs (LHsExpr GhcPs)]
-> Maybe SrcSpan -> HsRecordBinds GhcPs
forall id arg.
[LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields [LHsRecField GhcPs (LHsExpr GhcPs)]
fs Maybe SrcSpan
dd))
mkRecConstrOrUpdate LHsExpr GhcPs
exp SrcSpan
_ ([LHsRecField GhcPs (LHsExpr GhcPs)]
fs,Maybe SrcSpan
dd)
  | Just SrcSpan
dd_loc <- Maybe SrcSpan
dd = SrcSpan -> SDoc -> PV (HsExpr GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
dd_loc (String -> SDoc
text String
"You cannot use `..' in a record update")
  | Bool
otherwise = HsExpr GhcPs -> PV (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd LHsExpr GhcPs
exp ((LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdField GhcPs)
-> [LHsRecField GhcPs (LHsExpr GhcPs)] -> [LHsRecUpdField GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map ((HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs)
-> LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdField GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field) [LHsRecField GhcPs (LHsExpr GhcPs)]
fs))

mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd LHsExpr GhcPs
exp [LHsRecUpdField GhcPs]
flds
  = RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_ext :: XRecordUpd GhcPs
rupd_ext  = NoExtField
XRecordUpd GhcPs
noExtField
              , rupd_expr :: LHsExpr GhcPs
rupd_expr = LHsExpr GhcPs
exp
              , rupd_flds :: [LHsRecUpdField GhcPs]
rupd_flds = [LHsRecUpdField GhcPs]
flds }

mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon Located RdrName
con HsRecordBinds GhcPs
flds
  = RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcPs
rcon_ext = NoExtField
XRecordCon GhcPs
noExtField, rcon_con_name :: Located (IdP GhcPs)
rcon_con_name = Located RdrName
Located (IdP GhcPs)
con, rcon_flds :: HsRecordBinds GhcPs
rcon_flds = HsRecordBinds GhcPs
flds }

mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields :: forall id arg.
[LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields [LHsRecField id arg]
fs Maybe SrcSpan
Nothing = HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField id arg]
rec_flds = [LHsRecField id arg]
fs, rec_dotdot :: Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
forall a. Maybe a
Nothing }
mk_rec_fields [LHsRecField id arg]
fs (Just SrcSpan
s)  = HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField id arg]
rec_flds = [LHsRecField id arg]
fs
                                     , rec_dotdot :: Maybe (Located Int)
rec_dotdot = Located Int -> Maybe (Located Int)
forall a. a -> Maybe a
Just (SrcSpan -> Int -> Located Int
forall l e. l -> e -> GenLocated l e
L SrcSpan
s ([LHsRecField id arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsRecField id arg]
fs)) }

mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field (HsRecField (L SrcSpan
loc (FieldOcc XCFieldOcc GhcPs
_ Located RdrName
rdr)) LHsExpr GhcPs
arg Bool
pun)
  = Located (AmbiguousFieldOcc GhcPs)
-> LHsExpr GhcPs -> Bool -> HsRecUpdField GhcPs
forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField (SrcSpan
-> AmbiguousFieldOcc GhcPs -> Located (AmbiguousFieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcPs -> Located RdrName -> AmbiguousFieldOcc GhcPs
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous NoExtField
XUnambiguous GhcPs
noExtField Located RdrName
rdr)) LHsExpr GhcPs
arg Bool
pun

mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
               -> InlinePragma
-- The (Maybe Activation) is because the user can omit
-- the activation spec (and usually does)
mkInlinePragma :: SourceText
-> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
mkInlinePragma SourceText
src (InlineSpec
inl, RuleMatchInfo
match_info) Maybe Activation
mb_act
  = InlinePragma :: SourceText
-> InlineSpec
-> Maybe Int
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src = SourceText
src -- Note [Pragma source text] in GHC.Types.Basic
                 , inl_inline :: InlineSpec
inl_inline = InlineSpec
inl
                 , inl_sat :: Maybe Int
inl_sat    = Maybe Int
forall a. Maybe a
Nothing
                 , inl_act :: Activation
inl_act    = Activation
act
                 , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
match_info }
  where
    act :: Activation
act = case Maybe Activation
mb_act of
            Just Activation
act -> Activation
act
            Maybe Activation
Nothing  -> -- No phase specified
                        case InlineSpec
inl of
                          InlineSpec
NoInline -> Activation
NeverActive
                          InlineSpec
_other   -> Activation
AlwaysActive

-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- construct a foreign import declaration
--
mkImport :: Located CCallConv
         -> Located Safety
         -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
         -> P (HsDecl GhcPs)
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkImport Located CCallConv
cconv Located Safety
safety (L SrcSpan
loc (StringLiteral SourceText
esrc FastString
entity), Located RdrName
v, LHsSigType GhcPs
ty) =
    case Located CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc Located CCallConv
cconv of
      CCallConv
CCallConv          -> P (HsDecl GhcPs)
mkCImport
      CCallConv
CApiConv           -> P (HsDecl GhcPs)
mkCImport
      CCallConv
StdCallConv        -> P (HsDecl GhcPs)
mkCImport
      CCallConv
PrimCallConv       -> P (HsDecl GhcPs)
mkOtherImport
      CCallConv
JavaScriptCallConv -> P (HsDecl GhcPs)
mkOtherImport
  where
    -- Parse a C-like entity string of the following form:
    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
    -- If 'cid' is missing, the function name 'v' is used instead as symbol
    -- name (cf section 8.5.1 in Haskell 2010 report).
    mkCImport :: P (HsDecl GhcPs)
mkCImport = do
      let e :: String
e = FastString -> String
unpackFS FastString
entity
      case Located CCallConv
-> Located Safety
-> FastString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport Located CCallConv
cconv Located Safety
safety (RdrName -> FastString
mkExtName (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
v)) String
e (SrcSpan -> SourceText -> Located SourceText
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc SourceText
esrc) of
        Maybe ForeignImport
Nothing         -> SrcSpan -> SDoc -> P (HsDecl GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (String -> SDoc
text String
"Malformed entity string")
        Just ForeignImport
importSpec -> ForeignImport -> P (HsDecl GhcPs)
returnSpec ForeignImport
importSpec

    -- currently, all the other import conventions only support a symbol name in
    -- the entity string. If it is missing, we use the function name instead.
    mkOtherImport :: P (HsDecl GhcPs)
mkOtherImport = ForeignImport -> P (HsDecl GhcPs)
returnSpec ForeignImport
importSpec
      where
        entity' :: FastString
entity'    = if FastString -> Bool
nullFS FastString
entity
                        then RdrName -> FastString
mkExtName (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
v)
                        else FastString
entity
        funcTarget :: CImportSpec
funcTarget = CCallTarget -> CImportSpec
CFunction (SourceText -> FastString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
esrc FastString
entity' Maybe Unit
forall a. Maybe a
Nothing Bool
True)
        importSpec :: ForeignImport
importSpec = Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
forall a. Maybe a
Nothing CImportSpec
funcTarget (SrcSpan -> SourceText -> Located SourceText
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc SourceText
esrc)

    returnSpec :: ForeignImport -> P (HsDecl GhcPs)
returnSpec ForeignImport
spec = HsDecl GhcPs -> P (HsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDecl GhcPs -> P (HsDecl GhcPs))
-> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD NoExtField
XForD GhcPs
noExtField (ForeignDecl GhcPs -> HsDecl GhcPs)
-> ForeignDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ForeignImport :: forall pass.
XForeignImport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignImport
-> ForeignDecl pass
ForeignImport
          { fd_i_ext :: XForeignImport GhcPs
fd_i_ext  = NoExtField
XForeignImport GhcPs
noExtField
          , fd_name :: Located (IdP GhcPs)
fd_name   = Located RdrName
Located (IdP GhcPs)
v
          , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsSigType GhcPs
ty
          , fd_fi :: ForeignImport
fd_fi     = ForeignImport
spec
          }



-- the string "foo" is ambiguous: either a header or a C identifier.  The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
             -> Located SourceText
             -> Maybe ForeignImport
parseCImport :: Located CCallConv
-> Located Safety
-> FastString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport Located CCallConv
cconv Located Safety
safety FastString
nm String
str Located SourceText
sourceText =
 [ForeignImport] -> Maybe ForeignImport
forall a. [a] -> Maybe a
listToMaybe ([ForeignImport] -> Maybe ForeignImport)
-> [ForeignImport] -> Maybe ForeignImport
forall a b. (a -> b) -> a -> b
$ ((ForeignImport, String) -> ForeignImport)
-> [(ForeignImport, String)] -> [ForeignImport]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignImport, String) -> ForeignImport
forall a b. (a, b) -> a
fst ([(ForeignImport, String)] -> [ForeignImport])
-> [(ForeignImport, String)] -> [ForeignImport]
forall a b. (a -> b) -> a -> b
$ ((ForeignImport, String) -> Bool)
-> [(ForeignImport, String)] -> [(ForeignImport, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null(String -> Bool)
-> ((ForeignImport, String) -> String)
-> (ForeignImport, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ForeignImport, String) -> String
forall a b. (a, b) -> b
snd) ([(ForeignImport, String)] -> [(ForeignImport, String)])
-> [(ForeignImport, String)] -> [(ForeignImport, String)]
forall a b. (a -> b) -> a -> b
$
     ReadP ForeignImport -> ReadS ForeignImport
forall a. ReadP a -> ReadS a
readP_to_S ReadP ForeignImport
parse String
str
 where
   parse :: ReadP ForeignImport
parse = do
       ReadP ()
skipSpaces
       ForeignImport
r <- [ReadP ForeignImport] -> ReadP ForeignImport
forall a. [ReadP a] -> ReadP a
choice [
          String -> ReadP String
string String
"dynamic" ReadP String -> ReadP ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing (CCallTarget -> CImportSpec
CFunction CCallTarget
DynamicTarget)),
          String -> ReadP String
string String
"wrapper" ReadP String -> ReadP ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing CImportSpec
CWrapper),
          do ReadP () -> ReadP ()
forall a. ReadP a -> ReadP ()
optional (String -> ReadP ()
token String
"static" ReadP () -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces)
             ((Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing (CImportSpec -> ForeignImport)
-> ReadP CImportSpec -> ReadP ForeignImport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP CImportSpec
cimp FastString
nm) ReadP ForeignImport -> ReadP ForeignImport -> ReadP ForeignImport
forall a. ReadP a -> ReadP a -> ReadP a
+++
              (do String
h <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
hdr_char
                  ReadP ()
skipSpaces
                  Maybe Header -> CImportSpec -> ForeignImport
mk (Header -> Maybe Header
forall a. a -> Maybe a
Just (SourceText -> FastString -> Header
Header (String -> SourceText
SourceText String
h) (String -> FastString
mkFastString String
h)))
                      (CImportSpec -> ForeignImport)
-> ReadP CImportSpec -> ReadP ForeignImport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP CImportSpec
cimp FastString
nm))
         ]
       ReadP ()
skipSpaces
       ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignImport
r

   token :: String -> ReadP ()
token String
str = do String
_ <- String -> ReadP String
string String
str
                  String
toks <- ReadP String
look
                  case String
toks of
                      Char
c : String
_
                       | Char -> Bool
id_char Char
c -> ReadP ()
forall a. ReadP a
pfail
                      String
_            -> () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

   mk :: Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
h CImportSpec
n = Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
h CImportSpec
n Located SourceText
sourceText

   hdr_char :: Char -> Bool
hdr_char Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
   -- header files are filenames, which can contain
   -- pretty much any char (depending on the platform),
   -- so just accept any non-space character
   id_first_char :: Char -> Bool
id_first_char Char
c = Char -> Bool
isAlpha    Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
   id_char :: Char -> Bool
id_char       Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

   cimp :: FastString -> ReadP CImportSpec
cimp FastString
nm = (Char -> ReadP Char
ReadP.char Char
'&' ReadP Char -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces ReadP () -> ReadP CImportSpec -> ReadP CImportSpec
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FastString -> CImportSpec
CLabel (FastString -> CImportSpec)
-> ReadP FastString -> ReadP CImportSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP FastString
cid)
             ReadP CImportSpec -> ReadP CImportSpec -> ReadP CImportSpec
forall a. ReadP a -> ReadP a -> ReadP a
+++ (do Bool
isFun <- case Located CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc Located CCallConv
cconv of
                               CCallConv
CApiConv ->
                                  Bool -> ReadP Bool -> ReadP Bool
forall a. a -> ReadP a -> ReadP a
option Bool
True
                                         (do String -> ReadP ()
token String
"value"
                                             ReadP ()
skipSpaces
                                             Bool -> ReadP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
                               CCallConv
_ -> Bool -> ReadP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                     FastString
cid' <- ReadP FastString
cid
                     CImportSpec -> ReadP CImportSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (CCallTarget -> CImportSpec
CFunction (SourceText -> FastString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText FastString
cid'
                                        Maybe Unit
forall a. Maybe a
Nothing Bool
isFun)))
          where
            cid :: ReadP FastString
cid = FastString -> ReadP FastString
forall (m :: * -> *) a. Monad m => a -> m a
return FastString
nm ReadP FastString -> ReadP FastString -> ReadP FastString
forall a. ReadP a -> ReadP a -> ReadP a
+++
                  (do Char
c  <- (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
id_first_char
                      String
cs <-  ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
id_char)
                      FastString -> ReadP FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> FastString
mkFastString (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)))


-- construct a foreign export declaration
--
mkExport :: Located CCallConv
         -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
         -> P (HsDecl GhcPs)
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkExport (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
le (StringLiteral SourceText
esrc FastString
entity), Located RdrName
v, LHsSigType GhcPs
ty)
 = HsDecl GhcPs -> P (HsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDecl GhcPs -> P (HsDecl GhcPs))
-> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD NoExtField
XForD GhcPs
noExtField (ForeignDecl GhcPs -> HsDecl GhcPs)
-> ForeignDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
   ForeignExport :: forall pass.
XForeignExport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignExport
-> ForeignDecl pass
ForeignExport { fd_e_ext :: XForeignExport GhcPs
fd_e_ext = NoExtField
XForeignExport GhcPs
noExtField, fd_name :: Located (IdP GhcPs)
fd_name = Located RdrName
Located (IdP GhcPs)
v, fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsSigType GhcPs
ty
                 , fd_fe :: ForeignExport
fd_fe = Located CExportSpec -> Located SourceText -> ForeignExport
CExport (SrcSpan -> CExportSpec -> Located CExportSpec
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc (SourceText -> FastString -> CCallConv -> CExportSpec
CExportStatic SourceText
esrc FastString
entity' CCallConv
cconv))
                                   (SrcSpan -> SourceText -> Located SourceText
forall l e. l -> e -> GenLocated l e
L SrcSpan
le SourceText
esrc) }
  where
    entity' :: FastString
entity' | FastString -> Bool
nullFS FastString
entity = RdrName -> FastString
mkExtName (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
v)
            | Bool
otherwise     = FastString
entity

-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--
mkExtName :: RdrName -> CLabelString
mkExtName :: RdrName -> FastString
mkExtName RdrName
rdrNm = String -> FastString
mkFastString (OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
rdrNm))

--------------------------------------------------------------------------------
-- Help with module system imports/exports

data ImpExpSubSpec = ImpExpAbs
                   | ImpExpAll
                   | ImpExpList [Located ImpExpQcSpec]
                   | ImpExpAllWith [Located ImpExpQcSpec]

data ImpExpQcSpec = ImpExpQcName (Located RdrName)
                  | ImpExpQcType (Located RdrName)
                  | ImpExpQcWildcard

mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp (L SrcSpan
l ImpExpQcSpec
specname) ImpExpSubSpec
subs =
  case ImpExpSubSpec
subs of
    ImpExpSubSpec
ImpExpAbs
      | NameSpace -> Bool
isVarNameSpace (RdrName -> NameSpace
rdrNameSpace RdrName
name)
                       -> IE GhcPs -> P (IE GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (IE GhcPs -> P (IE GhcPs)) -> IE GhcPs -> P (IE GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcPs
noExtField (SrcSpan
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec ImpExpQcSpec
specname))
      | Bool
otherwise      -> XIEThingAbs GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAbs pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAbs NoExtField
XIEThingAbs GhcPs
noExtField (GenLocated SrcSpan (IEWrappedName RdrName) -> IE GhcPs)
-> (IEWrappedName RdrName
    -> GenLocated SrcSpan (IEWrappedName RdrName))
-> IEWrappedName RdrName
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (IEWrappedName RdrName -> IE GhcPs)
-> P (IEWrappedName RdrName) -> P (IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName RdrName)
nameT
    ImpExpSubSpec
ImpExpAll          -> XIEThingAll GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAll pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAll NoExtField
XIEThingAll GhcPs
noExtField (GenLocated SrcSpan (IEWrappedName RdrName) -> IE GhcPs)
-> (IEWrappedName RdrName
    -> GenLocated SrcSpan (IEWrappedName RdrName))
-> IEWrappedName RdrName
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (IEWrappedName RdrName -> IE GhcPs)
-> P (IEWrappedName RdrName) -> P (IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName RdrName)
nameT
    ImpExpList [Located ImpExpQcSpec]
xs      ->
      (\IEWrappedName RdrName
newName -> XIEThingWith GhcPs
-> LIEWrappedName (IdP GhcPs)
-> IEWildcard
-> [LIEWrappedName (IdP GhcPs)]
-> [Located (FieldLbl (IdP GhcPs))]
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith NoExtField
XIEThingWith GhcPs
noExtField (SrcSpan
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l IEWrappedName RdrName
newName)
        IEWildcard
NoIEWildcard ([Located ImpExpQcSpec]
-> [GenLocated SrcSpan (IEWrappedName RdrName)]
forall {l}.
[GenLocated l ImpExpQcSpec]
-> [GenLocated l (IEWrappedName RdrName)]
wrapped [Located ImpExpQcSpec]
xs) []) (IEWrappedName RdrName -> IE GhcPs)
-> P (IEWrappedName RdrName) -> P (IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName RdrName)
nameT
    ImpExpAllWith [Located ImpExpQcSpec]
xs                       ->
      do Bool
allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
PatternSynonymsBit
         if Bool
allowed
          then
            let withs :: [ImpExpQcSpec]
withs = (Located ImpExpQcSpec -> ImpExpQcSpec)
-> [Located ImpExpQcSpec] -> [ImpExpQcSpec]
forall a b. (a -> b) -> [a] -> [b]
map Located ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc [Located ImpExpQcSpec]
xs
                pos :: IEWildcard
pos   = IEWildcard -> (Int -> IEWildcard) -> Maybe Int -> IEWildcard
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IEWildcard
NoIEWildcard Int -> IEWildcard
IEWildcard
                          ((ImpExpQcSpec -> Bool) -> [ImpExpQcSpec] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ImpExpQcSpec -> Bool
isImpExpQcWildcard [ImpExpQcSpec]
withs)
                ies :: [GenLocated SrcSpan (IEWrappedName RdrName)]
ies   = [Located ImpExpQcSpec]
-> [GenLocated SrcSpan (IEWrappedName RdrName)]
forall {l}.
[GenLocated l ImpExpQcSpec]
-> [GenLocated l (IEWrappedName RdrName)]
wrapped ([Located ImpExpQcSpec]
 -> [GenLocated SrcSpan (IEWrappedName RdrName)])
-> [Located ImpExpQcSpec]
-> [GenLocated SrcSpan (IEWrappedName RdrName)]
forall a b. (a -> b) -> a -> b
$ (Located ImpExpQcSpec -> Bool)
-> [Located ImpExpQcSpec] -> [Located ImpExpQcSpec]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Located ImpExpQcSpec -> Bool) -> Located ImpExpQcSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcSpec -> Bool)
-> (Located ImpExpQcSpec -> ImpExpQcSpec)
-> Located ImpExpQcSpec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc) [Located ImpExpQcSpec]
xs
            in (\IEWrappedName RdrName
newName
                        -> XIEThingWith GhcPs
-> LIEWrappedName (IdP GhcPs)
-> IEWildcard
-> [LIEWrappedName (IdP GhcPs)]
-> [Located (FieldLbl (IdP GhcPs))]
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith NoExtField
XIEThingWith GhcPs
noExtField (SrcSpan
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l IEWrappedName RdrName
newName) IEWildcard
pos [GenLocated SrcSpan (IEWrappedName RdrName)]
[LIEWrappedName (IdP GhcPs)]
ies [])
               (IEWrappedName RdrName -> IE GhcPs)
-> P (IEWrappedName RdrName) -> P (IE GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (IEWrappedName RdrName)
nameT
          else SrcSpan -> SDoc -> P (IE GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l
            (String -> SDoc
text String
"Illegal export form (use PatternSynonyms to enable)")
  where
    name :: RdrName
name = ImpExpQcSpec -> RdrName
ieNameVal ImpExpQcSpec
specname
    nameT :: P (IEWrappedName RdrName)
nameT =
      if NameSpace -> Bool
isVarNameSpace (RdrName -> NameSpace
rdrNameSpace RdrName
name)
        then SrcSpan -> SDoc -> P (IEWrappedName RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l
              (String -> SDoc
text String
"Expecting a type constructor but found a variable,"
               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"."
              SDoc -> SDoc -> SDoc
$$ if OccName -> Bool
isSymOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
name
                   then String -> SDoc
text String
"If" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name)
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a type constructor"
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"then enable ExplicitNamespaces and use the 'type' keyword."
                   else SDoc
empty)
        else IEWrappedName RdrName -> P (IEWrappedName RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (IEWrappedName RdrName -> P (IEWrappedName RdrName))
-> IEWrappedName RdrName -> P (IEWrappedName RdrName)
forall a b. (a -> b) -> a -> b
$ ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec ImpExpQcSpec
specname

    ieNameVal :: ImpExpQcSpec -> RdrName
ieNameVal (ImpExpQcName Located RdrName
ln)  = Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
ln
    ieNameVal (ImpExpQcType Located RdrName
ln)  = Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
ln
    ieNameVal (ImpExpQcSpec
ImpExpQcWildcard) = String -> RdrName
forall a. String -> a
panic String
"ieNameVal got wildcard"

    ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec (ImpExpQcName Located RdrName
ln)  = Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEName Located RdrName
ln
    ieNameFromSpec (ImpExpQcType Located RdrName
ln)  = Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEType Located RdrName
ln
    ieNameFromSpec (ImpExpQcSpec
ImpExpQcWildcard) = String -> IEWrappedName RdrName
forall a. String -> a
panic String
"ieName got wildcard"

    wrapped :: [GenLocated l ImpExpQcSpec]
-> [GenLocated l (IEWrappedName RdrName)]
wrapped = (GenLocated l ImpExpQcSpec -> GenLocated l (IEWrappedName RdrName))
-> [GenLocated l ImpExpQcSpec]
-> [GenLocated l (IEWrappedName RdrName)]
forall a b. (a -> b) -> [a] -> [b]
map ((ImpExpQcSpec -> IEWrappedName RdrName)
-> GenLocated l ImpExpQcSpec
-> GenLocated l (IEWrappedName RdrName)
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec)

mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
             -> P (Located RdrName)
mkTypeImpExp :: Located RdrName -> P (Located RdrName)
mkTypeImpExp Located RdrName
name =
  do Bool
allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ExplicitNamespacesBit
     Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
name) (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
       String -> SDoc
text String
"Illegal keyword 'type' (use ExplicitNamespaces to enable)"
     Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RdrName -> NameSpace -> RdrName
`setRdrNameSpace` NameSpace
tcClsName) Located RdrName
name)

checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
checkImportSpec ie :: Located [LIE GhcPs]
ie@(L SrcSpan
_ [LIE GhcPs]
specs) =
    case [SrcSpan
l | (L SrcSpan
l (IEThingWith XIEThingWith GhcPs
_ LIEWrappedName (IdP GhcPs)
_ (IEWildcard Int
_) [LIEWrappedName (IdP GhcPs)]
_ [Located (FieldLbl (IdP GhcPs))]
_)) <- [LIE GhcPs]
specs] of
      [] -> Located [LIE GhcPs] -> P (Located [LIE GhcPs])
forall (m :: * -> *) a. Monad m => a -> m a
return Located [LIE GhcPs]
ie
      (SrcSpan
l:[SrcSpan]
_) -> SrcSpan -> P (Located [LIE GhcPs])
forall {m :: * -> *} {a}. MonadP m => SrcSpan -> m a
importSpecError SrcSpan
l
  where
    importSpecError :: SrcSpan -> m a
importSpecError SrcSpan
l =
      SrcSpan -> SDoc -> m a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l
        (String -> SDoc
text String
"Illegal import form, this syntax can only be used to bundle"
        SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"pattern synonyms with types in module exports.")

-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Located ImpExpQcSpec] -> ImpExpSubSpec
ImpExpList [])
mkImpExpSubSpec [L SrcSpan
_ ImpExpQcSpec
ImpExpQcWildcard] =
  ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ImpExpSubSpec
ImpExpAll)
mkImpExpSubSpec [Located ImpExpQcSpec]
xs =
  if ((Located ImpExpQcSpec -> Bool) -> [Located ImpExpQcSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcSpec -> Bool)
-> (Located ImpExpQcSpec -> ImpExpQcSpec)
-> Located ImpExpQcSpec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ImpExpQcSpec -> ImpExpQcSpec
forall l e. GenLocated l e -> e
unLoc) [Located ImpExpQcSpec]
xs)
    then ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec))
-> ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall a b. (a -> b) -> a -> b
$ ([], [Located ImpExpQcSpec] -> ImpExpSubSpec
ImpExpAllWith [Located ImpExpQcSpec]
xs)
    else ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec))
-> ([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall a b. (a -> b) -> a -> b
$ ([], [Located ImpExpQcSpec] -> ImpExpSubSpec
ImpExpList [Located ImpExpQcSpec]
xs)

isImpExpQcWildcard :: ImpExpQcSpec -> Bool
isImpExpQcWildcard :: ImpExpQcSpec -> Bool
isImpExpQcWildcard ImpExpQcSpec
ImpExpQcWildcard = Bool
True
isImpExpQcWildcard ImpExpQcSpec
_                = Bool
False

-----------------------------------------------------------------------------
-- Warnings and failures

warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule SrcSpan
span =
  WarningFlag -> SrcSpan -> SDoc -> P ()
forall (m :: * -> *).
MonadP m =>
WarningFlag -> SrcSpan -> SDoc -> m ()
addWarning WarningFlag
Opt_WarnPrepositiveQualifiedModule SrcSpan
span SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text String
"Found" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"qualified")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in prepositive position"
       SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Suggested fix: place " SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"qualified")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"after the module name instead."

failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost SrcSpan
loc = SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
loc SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text String
"Found" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"qualified")
          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in postpositive position. "
      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"To allow this, enable language extension 'ImportQualifiedPost'"

failOpImportQualifiedTwice :: SrcSpan -> P ()
failOpImportQualifiedTwice :: SrcSpan -> P ()
failOpImportQualifiedTwice SrcSpan
loc = SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
loc SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text String
"Multiple occurrences of 'qualified'"

warnStarIsType :: SrcSpan -> P ()
warnStarIsType :: SrcSpan -> P ()
warnStarIsType SrcSpan
span = WarningFlag -> SrcSpan -> SDoc -> P ()
forall (m :: * -> *).
MonadP m =>
WarningFlag -> SrcSpan -> SDoc -> m ()
addWarning WarningFlag
Opt_WarnStarIsType SrcSpan
span SDoc
msg
  where
    msg :: SDoc
msg =  String -> SDoc
text String
"Using" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"*")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(or its Unicode variant) to mean"
           SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Data.Kind.Type")
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"relies on the StarIsType extension, which will become"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"deprecated in the future."
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Suggested fix: use" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Type")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"from" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Data.Kind") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"instead."

warnStarBndr :: SrcSpan -> P ()
warnStarBndr :: SrcSpan -> P ()
warnStarBndr SrcSpan
span = WarningFlag -> SrcSpan -> SDoc -> P ()
forall (m :: * -> *).
MonadP m =>
WarningFlag -> SrcSpan -> SDoc -> m ()
addWarning WarningFlag
Opt_WarnStarBinder SrcSpan
span SDoc
msg
  where
    msg :: SDoc
msg =  String -> SDoc
text String
"Found binding occurrence of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"*")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"yet StarIsType is enabled."
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"NB. To use (or export) this operator in"
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"modules with StarIsType,"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"    including the definition module, you must qualify it."

failOpFewArgs :: Located RdrName -> P a
failOpFewArgs :: forall a. Located RdrName -> P a
failOpFewArgs (L SrcSpan
loc RdrName
op) =
  do { Bool
star_is_type <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
StarIsTypeBit
     ; let msg :: SDoc
msg = SDoc
too_few SDoc -> SDoc -> SDoc
$$ Bool -> RdrName -> SDoc
starInfo Bool
star_is_type RdrName
op
     ; SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc SDoc
msg }
  where
    too_few :: SDoc
too_few = String -> SDoc
text String
"Operator applied to too few arguments:" SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
op

-----------------------------------------------------------------------------
-- Misc utils

data PV_Context =
  PV_Context
    { PV_Context -> ParserFlags
pv_options :: ParserFlags
    , PV_Context -> SDoc
pv_hint :: SDoc  -- See Note [Parser-Validator Hint]
    }

data PV_Accum =
  PV_Accum
    { PV_Accum -> DynFlags -> Messages
pv_messages :: DynFlags -> Messages
    , PV_Accum -> [(ApiAnnKey, [RealSrcSpan])]
pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
    , PV_Accum -> [RealLocated AnnotationComment]
pv_comment_q :: [RealLocated AnnotationComment]
    , PV_Accum -> [(RealSrcSpan, [RealLocated AnnotationComment])]
pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
    }

data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum

-- See Note [Parser-Validator]
newtype PV a = PV { forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV :: PV_Context -> PV_Accum -> PV_Result a }

instance Functor PV where
  fmap :: forall a b. (a -> b) -> PV a -> PV b
fmap = (a -> b) -> PV a -> PV b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PV where
  pure :: forall a. a -> PV a
pure a
a = a
a a -> PV a -> PV a
`seq` (PV_Context -> PV_Accum -> PV_Result a) -> PV a
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV (\PV_Context
_ PV_Accum
acc -> PV_Accum -> a -> PV_Result a
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc a
a)
  <*> :: forall a b. PV (a -> b) -> PV a -> PV b
(<*>) = PV (a -> b) -> PV a -> PV b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad PV where
  PV a
m >>= :: forall a b. PV a -> (a -> PV b) -> PV b
>>= a -> PV b
f = (PV_Context -> PV_Accum -> PV_Result b) -> PV b
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result b) -> PV b)
-> (PV_Context -> PV_Accum -> PV_Result b) -> PV b
forall a b. (a -> b) -> a -> b
$ \PV_Context
ctx PV_Accum
acc ->
    case PV a -> PV_Context -> PV_Accum -> PV_Result a
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV PV a
m PV_Context
ctx PV_Accum
acc of
      PV_Ok PV_Accum
acc' a
a -> PV b -> PV_Context -> PV_Accum -> PV_Result b
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV (a -> PV b
f a
a) PV_Context
ctx PV_Accum
acc'
      PV_Failed PV_Accum
acc' -> PV_Accum -> PV_Result b
forall a. PV_Accum -> PV_Result a
PV_Failed PV_Accum
acc'

runPV :: PV a -> P a
runPV :: forall a. PV a -> P a
runPV = SDoc -> PV a -> P a
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
empty

runPV_msg :: SDoc -> PV a -> P a
runPV_msg :: forall a. SDoc -> PV a -> P a
runPV_msg SDoc
msg PV a
m =
  (PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s ->
    let
      pv_ctx :: PV_Context
pv_ctx = PV_Context :: ParserFlags -> SDoc -> PV_Context
PV_Context
        { pv_options :: ParserFlags
pv_options = PState -> ParserFlags
options PState
s
        , pv_hint :: SDoc
pv_hint = SDoc
msg }
      pv_acc :: PV_Accum
pv_acc = PV_Accum :: (DynFlags -> Messages)
-> [(ApiAnnKey, [RealSrcSpan])]
-> [RealLocated AnnotationComment]
-> [(RealSrcSpan, [RealLocated AnnotationComment])]
-> PV_Accum
PV_Accum
        { pv_messages :: DynFlags -> Messages
pv_messages = PState -> DynFlags -> Messages
messages PState
s
        , pv_annotations :: [(ApiAnnKey, [RealSrcSpan])]
pv_annotations = PState -> [(ApiAnnKey, [RealSrcSpan])]
annotations PState
s
        , pv_comment_q :: [RealLocated AnnotationComment]
pv_comment_q = PState -> [RealLocated AnnotationComment]
comment_q PState
s
        , pv_annotations_comments :: [(RealSrcSpan, [RealLocated AnnotationComment])]
pv_annotations_comments = PState -> [(RealSrcSpan, [RealLocated AnnotationComment])]
annotations_comments PState
s }
      mkPState :: PV_Accum -> PState
mkPState PV_Accum
acc' =
        PState
s { messages :: DynFlags -> Messages
messages = PV_Accum -> DynFlags -> Messages
pv_messages PV_Accum
acc'
          , annotations :: [(ApiAnnKey, [RealSrcSpan])]
annotations = PV_Accum -> [(ApiAnnKey, [RealSrcSpan])]
pv_annotations PV_Accum
acc'
          , comment_q :: [RealLocated AnnotationComment]
comment_q = PV_Accum -> [RealLocated AnnotationComment]
pv_comment_q PV_Accum
acc'
          , annotations_comments :: [(RealSrcSpan, [RealLocated AnnotationComment])]
annotations_comments = PV_Accum -> [(RealSrcSpan, [RealLocated AnnotationComment])]
pv_annotations_comments PV_Accum
acc' }
    in
      case PV a -> PV_Context -> PV_Accum -> PV_Result a
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV PV a
m PV_Context
pv_ctx PV_Accum
pv_acc of
        PV_Ok PV_Accum
acc' a
a -> PState -> a -> ParseResult a
forall a. PState -> a -> ParseResult a
POk (PV_Accum -> PState
mkPState PV_Accum
acc') a
a
        PV_Failed PV_Accum
acc' -> PState -> ParseResult a
forall a. PState -> ParseResult a
PFailed (PV_Accum -> PState
mkPState PV_Accum
acc')

localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
localPV_msg :: forall a. (SDoc -> SDoc) -> PV a -> PV a
localPV_msg SDoc -> SDoc
f PV a
m =
  let modifyHint :: PV_Context -> PV_Context
modifyHint PV_Context
ctx = PV_Context
ctx{pv_hint :: SDoc
pv_hint = SDoc -> SDoc
f (PV_Context -> SDoc
pv_hint PV_Context
ctx)} in
  (PV_Context -> PV_Accum -> PV_Result a) -> PV a
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV (\PV_Context
ctx PV_Accum
acc -> PV a -> PV_Context -> PV_Accum -> PV_Result a
forall a. PV a -> PV_Context -> PV_Accum -> PV_Result a
unPV PV a
m (PV_Context -> PV_Context
modifyHint PV_Context
ctx) PV_Accum
acc)

instance MonadP PV where
  addError :: SrcSpan -> SDoc -> PV ()
addError SrcSpan
srcspan SDoc
msg =
    (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ()) -> PV ())
-> (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a b. (a -> b) -> a -> b
$ \PV_Context
ctx acc :: PV_Accum
acc@PV_Accum{pv_messages :: PV_Accum -> DynFlags -> Messages
pv_messages=DynFlags -> Messages
m} ->
      let msg' :: SDoc
msg' = SDoc
msg SDoc -> SDoc -> SDoc
$$ PV_Context -> SDoc
pv_hint PV_Context
ctx in
      PV_Accum -> () -> PV_Result ()
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc{pv_messages :: DynFlags -> Messages
pv_messages=SrcSpan -> SDoc -> (DynFlags -> Messages) -> DynFlags -> Messages
appendError SrcSpan
srcspan SDoc
msg' DynFlags -> Messages
m} ()
  addWarning :: WarningFlag -> SrcSpan -> SDoc -> PV ()
addWarning WarningFlag
option SrcSpan
srcspan SDoc
warning =
    (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ()) -> PV ())
-> (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a b. (a -> b) -> a -> b
$ \PV_Context{pv_options :: PV_Context -> ParserFlags
pv_options=ParserFlags
o} acc :: PV_Accum
acc@PV_Accum{pv_messages :: PV_Accum -> DynFlags -> Messages
pv_messages=DynFlags -> Messages
m} ->
      PV_Accum -> () -> PV_Result ()
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc{pv_messages :: DynFlags -> Messages
pv_messages=ParserFlags
-> WarningFlag
-> SrcSpan
-> SDoc
-> (DynFlags -> Messages)
-> DynFlags
-> Messages
appendWarning ParserFlags
o WarningFlag
option SrcSpan
srcspan SDoc
warning DynFlags -> Messages
m} ()
  addFatalError :: forall a. SrcSpan -> SDoc -> PV a
addFatalError SrcSpan
srcspan SDoc
msg =
    SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
srcspan SDoc
msg PV () -> PV a -> PV a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (PV_Context -> PV_Accum -> PV_Result a) -> PV a
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Accum -> PV_Result a) -> PV_Context -> PV_Accum -> PV_Result a
forall a b. a -> b -> a
const PV_Accum -> PV_Result a
forall a. PV_Accum -> PV_Result a
PV_Failed)
  getBit :: ExtBits -> PV Bool
getBit ExtBits
ext =
    (PV_Context -> PV_Accum -> PV_Result Bool) -> PV Bool
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result Bool) -> PV Bool)
-> (PV_Context -> PV_Accum -> PV_Result Bool) -> PV Bool
forall a b. (a -> b) -> a -> b
$ \PV_Context
ctx PV_Accum
acc ->
      let b :: Bool
b = ExtBits
ext ExtBits -> ExtsBitmap -> Bool
`xtest` ParserFlags -> ExtsBitmap
pExtsBitmap (PV_Context -> ParserFlags
pv_options PV_Context
ctx) in
      PV_Accum -> Bool -> PV_Result Bool
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc (Bool -> PV_Result Bool) -> Bool -> PV_Result Bool
forall a b. (a -> b) -> a -> b
$! Bool
b
  addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> PV ()
addAnnotation (RealSrcSpan RealSrcSpan
l Maybe BufSpan
_) AnnKeywordId
a (RealSrcSpan RealSrcSpan
v Maybe BufSpan
_) =
    (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a. (PV_Context -> PV_Accum -> PV_Result a) -> PV a
PV ((PV_Context -> PV_Accum -> PV_Result ()) -> PV ())
-> (PV_Context -> PV_Accum -> PV_Result ()) -> PV ()
forall a b. (a -> b) -> a -> b
$ \PV_Context
_ PV_Accum
acc ->
      let
        ([RealLocated AnnotationComment]
comment_q', [(RealSrcSpan, [RealLocated AnnotationComment])]
new_ann_comments) = RealSrcSpan
-> [RealLocated AnnotationComment]
-> ([RealLocated AnnotationComment],
    [(RealSrcSpan, [RealLocated AnnotationComment])])
allocateComments RealSrcSpan
l (PV_Accum -> [RealLocated AnnotationComment]
pv_comment_q PV_Accum
acc)
        annotations_comments' :: [(RealSrcSpan, [RealLocated AnnotationComment])]
annotations_comments' = [(RealSrcSpan, [RealLocated AnnotationComment])]
new_ann_comments [(RealSrcSpan, [RealLocated AnnotationComment])]
-> [(RealSrcSpan, [RealLocated AnnotationComment])]
-> [(RealSrcSpan, [RealLocated AnnotationComment])]
forall a. [a] -> [a] -> [a]
++ PV_Accum -> [(RealSrcSpan, [RealLocated AnnotationComment])]
pv_annotations_comments PV_Accum
acc
        annotations' :: [(ApiAnnKey, [RealSrcSpan])]
annotations' = ((RealSrcSpan
l,AnnKeywordId
a), [RealSrcSpan
v]) (ApiAnnKey, [RealSrcSpan])
-> [(ApiAnnKey, [RealSrcSpan])] -> [(ApiAnnKey, [RealSrcSpan])]
forall a. a -> [a] -> [a]
: PV_Accum -> [(ApiAnnKey, [RealSrcSpan])]
pv_annotations PV_Accum
acc
        acc' :: PV_Accum
acc' = PV_Accum
acc
          { pv_annotations :: [(ApiAnnKey, [RealSrcSpan])]
pv_annotations = [(ApiAnnKey, [RealSrcSpan])]
annotations'
          , pv_comment_q :: [RealLocated AnnotationComment]
pv_comment_q = [RealLocated AnnotationComment]
comment_q'
          , pv_annotations_comments :: [(RealSrcSpan, [RealLocated AnnotationComment])]
pv_annotations_comments = [(RealSrcSpan, [RealLocated AnnotationComment])]
annotations_comments' }
      in
        PV_Accum -> () -> PV_Result ()
forall a. PV_Accum -> a -> PV_Result a
PV_Ok PV_Accum
acc' ()
  addAnnotation SrcSpan
_ AnnKeywordId
_ SrcSpan
_ = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- Note [Parser-Validator]
~~~~~~~~~~~~~~~~~~~~~~~~~~

When resolving ambiguities, we need to postpone failure to make a choice later.
For example, if we have ambiguity between some A and B, our parser could be

  abParser :: P (Maybe A, Maybe B)

This way we can represent four possible outcomes of parsing:

    (Just a, Nothing)       -- definitely A
    (Nothing, Just b)       -- definitely B
    (Just a, Just b)        -- either A or B
    (Nothing, Nothing)      -- neither A nor B

However, if we want to report informative parse errors, accumulate warnings,
and add API annotations, we are better off using 'P' instead of 'Maybe':

  abParser :: P (P A, P B)

So we have an outer layer of P that consumes the input and builds the inner
layer, which validates the input.

For clarity, we introduce the notion of a parser-validator: a parser that does
not consume any input, but may fail or use other effects. Thus we have:

  abParser :: P (PV A, PV B)

-}

{- Note [Parser-Validator Hint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A PV computation is parametrized by a hint for error messages, which can be set
depending on validation context. We use this in checkPattern to fix #984.

Consider this example, where the user has forgotten a 'do':

  f _ = do
    x <- computation
    case () of
      _ ->
        result <- computation
        case () of () -> undefined

GHC parses it as follows:

  f _ = do
    x <- computation
    (case () of
      _ ->
        result) <- computation
        case () of () -> undefined

Note that this fragment is parsed as a pattern:

  case () of
    _ ->
      result

We attempt to detect such cases and add a hint to the error messages:

  T984.hs:6:9:
    Parse error in pattern: case () of { _ -> result }
    Possibly caused by a missing 'do'?

The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
as the 'pv_hint' field 'PV_Context'. When validating in a context other than
'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has
no effect on the error messages.

-}

-- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat SrcSpan
span Pat GhcPs
e = do
    Bool
bang_on <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BangPatBit
    Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
bang_on (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
span
        (String -> SDoc
text String
"Illegal bang-pattern (use BangPatterns):" SDoc -> SDoc -> SDoc
$$ Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
e)

data SumOrTuple b
  = Sum ConTag Arity (Located b)
  | Tuple [Located (Maybe (Located b))]

pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple :: forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
boxity = \case
    Sum Int
alt Int
arity Located b
e ->
      SDoc
parOpen SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SDoc -> SDoc -> SDoc
<+> Located b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located b
e SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alt)
              SDoc -> SDoc -> SDoc
<+> SDoc
parClose
    Tuple [Located (Maybe (Located b))]
xs ->
      SDoc
parOpen SDoc -> SDoc -> SDoc
<> ([SDoc] -> SDoc
fcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located (Maybe (Located b)) -> SDoc)
-> [Located (Maybe (Located b))] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> (Located b -> SDoc) -> Maybe (Located b) -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty Located b -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Maybe (Located b) -> SDoc)
-> (Located (Maybe (Located b)) -> Maybe (Located b))
-> Located (Maybe (Located b))
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Maybe (Located b)) -> Maybe (Located b)
forall l e. GenLocated l e -> e
unLoc) [Located (Maybe (Located b))]
xs)
              SDoc -> SDoc -> SDoc
<> SDoc
parClose
  where
    ppr_bars :: Int -> SDoc
ppr_bars Int
n = [SDoc] -> SDoc
hsep (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate Int
n (Char -> SDoc
Outputable.char Char
'|'))
    (SDoc
parOpen, SDoc
parClose) =
      case Boxity
boxity of
        Boxity
Boxed -> (String -> SDoc
text String
"(", String -> SDoc
text String
")")
        Boxity
Unboxed -> (String -> SDoc
text String
"(#", String -> SDoc
text String
"#)")

mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)

-- Tuple
mkSumOrTupleExpr :: SrcSpan
-> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkSumOrTupleExpr SrcSpan
l Boxity
boxity (Tuple [Located (Maybe (LHsExpr GhcPs))]
es) =
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcPs
noExtField ((Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs)
-> [Located (Maybe (LHsExpr GhcPs))] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg [Located (Maybe (LHsExpr GhcPs))]
es) Boxity
boxity)
  where
    toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
    toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = (Maybe (LHsExpr GhcPs) -> HsTupArg GhcPs)
-> Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (HsTupArg GhcPs
-> (LHsExpr GhcPs -> HsTupArg GhcPs)
-> Maybe (LHsExpr GhcPs)
-> HsTupArg GhcPs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsTupArg GhcPs
missingTupArg (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noExtField))

-- Sum
mkSumOrTupleExpr SrcSpan
l Boxity
Unboxed (Sum Int
alt Int
arity LHsExpr GhcPs
e) =
    LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> PV (LHsExpr GhcPs))
-> LHsExpr GhcPs -> PV (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XExplicitSum GhcPs -> Int -> Int -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum NoExtField
XExplicitSum GhcPs
noExtField Int
alt Int
arity LHsExpr GhcPs
e)
mkSumOrTupleExpr SrcSpan
l Boxity
Boxed a :: SumOrTuple (HsExpr GhcPs)
a@Sum{} =
    SrcSpan -> SDoc -> PV (LHsExpr GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Boxed sums not supported:") Int
2
                      (Boxity -> SumOrTuple (HsExpr GhcPs) -> SDoc
forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
Boxed SumOrTuple (HsExpr GhcPs)
a))

mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))

-- Tuple
mkSumOrTuplePat :: SrcSpan
-> Boxity
-> SumOrTuple (PatBuilder GhcPs)
-> PV (Located (PatBuilder GhcPs))
mkSumOrTuplePat SrcSpan
l Boxity
boxity (Tuple [Located (Maybe (Located (PatBuilder GhcPs)))]
ps) = do
  [Located (Pat GhcPs)]
ps' <- (Located (Maybe (Located (PatBuilder GhcPs)))
 -> PV (Located (Pat GhcPs)))
-> [Located (Maybe (Located (PatBuilder GhcPs)))]
-> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Located (Maybe (Located (PatBuilder GhcPs)))
-> PV (Located (Pat GhcPs))
Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
toTupPat [Located (Maybe (Located (PatBuilder GhcPs)))]
ps
  Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> Pat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat NoExtField
XTuplePat GhcPs
noExtField [Located (Pat GhcPs)]
[LPat GhcPs]
ps' Boxity
boxity))
  where
    toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
    -- Ignore the element location so that the error message refers to the
    -- entire tuple. See #19504 (and the discussion) for details.
    toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
toTupPat (L SrcSpan
_ Maybe (Located (PatBuilder GhcPs))
p) = case Maybe (Located (PatBuilder GhcPs))
p of
      Maybe (Located (PatBuilder GhcPs))
Nothing -> SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (String -> SDoc
text String
"Tuple section in pattern context")
      Just Located (PatBuilder GhcPs)
p' -> Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
p'

-- Sum
mkSumOrTuplePat SrcSpan
l Boxity
Unboxed (Sum Int
alt Int
arity Located (PatBuilder GhcPs)
p) = do
   Located (Pat GhcPs)
p' <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
p
   Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)))
-> Located (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PatBuilder GhcPs -> Located (PatBuilder GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Pat GhcPs -> PatBuilder GhcPs
forall p. Pat p -> PatBuilder p
PatBuilderPat (XSumPat GhcPs -> LPat GhcPs -> Int -> Int -> Pat GhcPs
forall p. XSumPat p -> LPat p -> Int -> Int -> Pat p
SumPat NoExtField
XSumPat GhcPs
noExtField Located (Pat GhcPs)
LPat GhcPs
p' Int
alt Int
arity))
mkSumOrTuplePat SrcSpan
l Boxity
Boxed a :: SumOrTuple (PatBuilder GhcPs)
a@Sum{} =
    SrcSpan -> SDoc -> PV (Located (PatBuilder GhcPs))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Boxed sums not supported:") Int
2
                      (Boxity -> SumOrTuple (PatBuilder GhcPs) -> SDoc
forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
Boxed SumOrTuple (PatBuilder GhcPs)
a))

mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
x Located RdrName
op LHsType GhcPs
y =
  let loc :: SrcSpan
loc = LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
x SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
op SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
y
  in SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (LHsType GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsKind GhcPs
forall (p :: Pass).
LHsType (GhcPass p)
-> Located (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy LHsType GhcPs
x Located RdrName
Located (IdP GhcPs)
op LHsType GhcPs
y)

mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)
mkMultTy :: IsUnicodeSyntax
-> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)
mkMultTy IsUnicodeSyntax
u Located Token
tok t :: LHsType GhcPs
t@(L SrcSpan
_ (HsTyLit XTyLit GhcPs
_ (HsNumTy (SourceText String
"1") Integer
1)))
  -- See #18888 for the use of (SourceText "1") above
  = (IsUnicodeSyntax -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> HsArrow pass
HsLinearArrow IsUnicodeSyntax
u, AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnPercentOne (Located Token -> LHsType GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located Token
tok LHsType GhcPs
t))
mkMultTy IsUnicodeSyntax
u Located Token
tok LHsType GhcPs
t = (IsUnicodeSyntax -> LHsType GhcPs -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> LHsType pass -> HsArrow pass
HsExplicitMult IsUnicodeSyntax
u LHsType GhcPs
t, AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnPercent (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
tok))

-----------------------------------------------------------------------------
-- Token symbols

starSym :: Bool -> String
starSym :: Bool -> String
starSym Bool
True = String
"★"
starSym Bool
False = String
"*"

forallSym :: Bool -> String
forallSym :: Bool -> String
forallSym Bool
True = String
"∀"
forallSym Bool
False = String
"forall"