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

-- Functions over HsSyn specialised to RdrName.

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

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

        cvBindGroup,
        cvBindsAndSigs,
        cvTopDecls,
        placeHolderPunRhs,

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

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

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

        -- Token symbols
        forallSym,
        starSym,

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

        SumOrTuple (..),

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

    ) where

import GhcPrelude
import GHC.Hs           -- Lots of it
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
import CoAxiom          ( Role, fsFromRole )
import RdrName
import Name
import BasicTypes
import TcEvidence       ( idHsWrapper )
import Lexer
import Lexeme           ( isLexCon )
import Type             ( TyThing(..), funTyCon )
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
                          listTyConName, listTyConKey, eqTyCon_RDR,
                          tupleTyConName, cTupleTyConNameArity_maybe )
import ForeignCall
import PrelNames        ( allNameStrings )
import SrcLoc
import Unique           ( hasKey )
import OrdList          ( OrdList, fromOL )
import Bag              ( emptyBag, consBag )
import Outputable
import FastString
import Maybes
import Util
import ApiAnnotation
import Data.List
import DynFlags ( WarningFlag(..), DynFlags )
import ErrUtils ( Messages )

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

#include "HsVersions.h"


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

  Construction functions for Rdr stuff

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

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

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

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

mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (LTyClDecl (GhcPass p)
-> Located (SrcSpanLess (LTyClDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LTyClDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD (GhcPass p)
NoExtField
noExtField SrcSpanLess (LTyClDecl (GhcPass p))
TyClDecl (GhcPass p)
d)

mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (LInstDecl (GhcPass p)
-> Located (SrcSpanLess (LInstDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LInstDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD (GhcPass p)
NoExtField
noExtField SrcSpanLess (LInstDecl (GhcPass p))
InstDecl (GhcPass p)
d)

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

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

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

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


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

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

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

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

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

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

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

  | HsSpliceE _ splice@(HsQuasiQuote {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
  = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)

  | Bool
otherwise
  = XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice SpliceDecoration
NoParens LHsExpr GhcPs
lexpr))
                              SpliceExplicitFlag
ImplicitSplice)

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

    parse_role :: Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc_role SrcSpanLess (Located (Maybe FastString))
Nothing) = Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role SrcSpanLess (Located (Maybe Role))
forall a. Maybe a
Nothing
    parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc_role (Just role))
      = case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
          Just Role
found_role -> Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role (SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role))
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
          Maybe Role
Nothing         ->
            let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
                  ((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
            in
            SrcSpan -> SDoc -> P (Located (Maybe Role))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc_role
              (String -> SDoc
text String
"Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
               [Role] -> SDoc
forall a. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)
    parse_role Located (Maybe FastString)
_ = String -> P (Located (Maybe Role))
forall a. String -> a
panic String
"parse_role: Impossible Match"
                                -- due to #15884

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

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

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

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

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


--  | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
  where
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go []                     = []
    go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ValD x b)) : [LHsDecl GhcPs]
ds)
      = SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
x SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds'
        where (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l' SrcSpanLess (LHsBind GhcPs)
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
    go (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds)                    = LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds

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

cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
fb = [LHsDecl GhcPs]
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall (m :: * -> *) a a a a a.
(HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a,
 HasSrcSpan a, MonadP m, SrcSpanLess a ~ DataFamInstDecl GhcPs,
 SrcSpanLess a ~ FamilyDecl GhcPs, SrcSpanLess a ~ Sig GhcPs,
 SrcSpanLess a ~ TyFamInstDecl GhcPs, SrcSpanLess a ~ DocDecl) =>
[LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
fb)
  where
    go :: [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go []              = (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
forall a. Bag a
emptyBag, [], [], [], [], [])
    go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ValD _ b)) : [LHsDecl GhcPs]
ds)
      = do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds'
           ; (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBind GhcPs
b' LHsBind GhcPs -> LHsBinds GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a -> Bag a
`consBag` LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) }
      where
        (LHsBind GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
    go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsDecl GhcPs)
decl) : [LHsDecl GhcPs]
ds)
      = do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds
           ; case SrcSpanLess (LHsDecl GhcPs)
decl of
               SigD _ s
                 -> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
Sig GhcPs
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
               TyClD _ (FamDecl _ t)
                 -> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
FamilyDecl GhcPs
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
               InstD _ (TyFamInstD { tfid_inst = tfi })
                 -> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
TyFamInstDecl GhcPs
tfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tfis, [a]
dfis, [a]
docs)
               InstD _ (DataFamInstD { dfid_inst = dfi })
                 -> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DataFamInstDecl GhcPs
dfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
dfis, [a]
docs)
               DocD _ d
                 -> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DocDecl
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
docs)
               SpliceD _ d
                 -> SrcSpan -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]))
-> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a b. (a -> b) -> a -> b
$
                    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
                          String -> SDoc
text String
"at the top level:")
                       Int
2 (SpliceDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl GhcPs
d)
               SrcSpanLess (LHsDecl GhcPs)
_ -> String -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cvBindsAndSigs" (HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl) }

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

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

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

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

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

has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args []                                    = String -> Bool
forall a. String -> a
panic String
"RdrHsSyn:has_args"
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_pats = args })) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args)
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XMatch nec)) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = NoExtCon -> Bool
forall a. NoExtCon -> a
noExtCon XXMatch GhcPs (LHsExpr GhcPs)
NoExtCon
nec
has_args (LMatch GhcPs (LHsExpr GhcPs)
_ : [LMatch GhcPs (LHsExpr GhcPs)]
_) = String -> Bool
forall a. String -> a
panic String
"has_args:Impossible Match" -- due to #15884

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

  #PrefixToHS-utils# Utilities for conversion

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-}

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

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

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

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

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

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

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

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

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

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

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

mkGadtDecl :: [Located RdrName]
           -> LHsType GhcPs     -- Always a HsForAllTy
           -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
names LHsType GhcPs
ty
  = (ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> LHsQTyVars pass
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = XConDeclGADT GhcPs
NoExtField
noExtField
                 , con_names :: [Located (IdP GhcPs)]
con_names  = [Located RdrName]
[Located (IdP GhcPs)]
names
                 , con_forall :: Located Bool
con_forall = SrcSpan -> SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
ty'
                 , con_qvars :: LHsQTyVars GhcPs
con_qvars  = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tvs
                 , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
                 , con_args :: HsConDeclDetails GhcPs
con_args   = HsConDeclDetails GhcPs
args
                 , con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
                 , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }
    , [AddAnn]
anns1 [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
anns2)
  where
    (ty' :: LHsType GhcPs
ty'@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
_),[AddAnn]
anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn])
forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType GhcPs
ty []
    ([LHsTyVarBndr GhcPs]
tvs, LHsType GhcPs
rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTyInvis LHsType GhcPs
ty'
    (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tau, [AddAnn]
anns2) = LHsType GhcPs
-> [AddAnn] -> (Maybe (LHsContext GhcPs), LHsType GhcPs, [AddAnn])
forall pass.
LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType GhcPs
rho []

    split_rho :: LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) [AddAnn]
ann
      = (LHsContext pass -> Maybe (LHsContext pass)
forall a. a -> Maybe a
Just LHsContext pass
cxt, LHsType pass
tau, [AddAnn]
ann)
    split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann
      = LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType pass
ty ([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
    split_rho LHsType pass
tau                  [AddAnn]
ann
      = (Maybe (LHsContext pass)
forall a. Maybe a
Nothing, LHsType pass
tau, [AddAnn]
ann)

    (HsConDeclDetails GhcPs
args, LHsType GhcPs
res_ty) = LHsType GhcPs -> (HsConDeclDetails GhcPs, LHsType GhcPs)
forall rec pass arg.
(HasSrcSpan rec, SrcSpanLess rec ~ [LConDeclField pass]) =>
LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau LHsType GhcPs
tau

    -- See Note [GADT abstract syntax] in GHC.Hs.Decls
    split_tau :: LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
      = (rec -> HsConDetails arg rec
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan -> SrcSpanLess rec -> rec
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LConDeclField pass]
SrcSpanLess rec
rf), LHsType pass
res_ty)
    split_tau LHsType pass
tau
      = ([arg] -> HsConDetails arg rec
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [], LHsType pass
tau)

    peel_parens :: LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann = LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType pass
ty
                                                       ([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
    peel_parens LHsType pass
ty                   [AddAnn]
ann = (LHsType pass
ty, [AddAnn]
ann)


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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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



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

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

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

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

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

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

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

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

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

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

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

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

    checkCmd :: LHsCmd GhcPs -> PV ()
    checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case LHsCmd GhcPs -> SrcSpanLess (LHsCmd GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsCmd GhcPs
cmd of
      HsCmdLam {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"lambda command" LHsCmd GhcPs
cmd
      HsCmdCase {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"case command" LHsCmd GhcPs
cmd
      HsCmdIf {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"if command" LHsCmd GhcPs
cmd
      HsCmdLet {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"let command" LHsCmd GhcPs
cmd
      HsCmdDo {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"do command" LHsCmd GhcPs
cmd
      SrcSpanLess (LHsCmd GhcPs)
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

  -- no need for anns, returning original
  check [AddAnn]
_anns LHsType GhcPs
t = SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
t P ()
-> P ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t])

  msg :: SDoc
msg = String -> SDoc
text String
"data constructor context"

-- | Check recursively if there are any 'HsDocTy's in the given type.
-- This only works on a subset of types produced by 'btype_no_ops'
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
ty = LHsType GhcPs -> P ()
go LHsType GhcPs
ty
  where
    go :: LHsType GhcPs -> P ()
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppKindTy _ ty ki)) = LHsType GhcPs -> P ()
go LHsType GhcPs
ty P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
ki
    go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppTy _ t1 t2)) = LHsType GhcPs -> P ()
go LHsType GhcPs
t1 P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
t2
    go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
                                  [ String -> SDoc
text String
"Unexpected haddock", SDoc -> SDoc
quotes (LHsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsDocString
ds)
                                  , String -> SDoc
text String
"on", SDoc
msg, SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t) ]
    go LHsType GhcPs
_ = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

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

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

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

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

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

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

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

checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: Located (PatBuilder GhcPs)
e@(Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located (PatBuilder GhcPs))
_) = SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
l Located (PatBuilder GhcPs)
e []

checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
         -> PV (LPat GhcPs)
checkPat :: SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l e :: SrcSpanLess (Located (PatBuilder GhcPs))
e@(PatBuilderVar (dL->L _ c))) [LPat GhcPs]
args
  | RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
c) ([Located (Pat GhcPs)]
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [Located (Pat GhcPs)]
[LPat GhcPs]
args)))
  | Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec SrcSpanLess (Located RdrName)
RdrName
c =
      (SDoc -> SDoc)
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a. (SDoc -> SDoc) -> PV a -> PV a
localPV_msg (\SDoc
_ -> String -> SDoc
text String
"Perhaps you intended to use RecursiveDo") (PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located (PatBuilder GhcPs))
PatBuilder GhcPs
e)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
args     -- OK to let this happen even if bang-patterns
                        -- are not enabled, because there is no valid
                        -- non-bang-pattern parse of (C ! e)
  | Just (Located (PatBuilder GhcPs)
e', [Located (PatBuilder GhcPs)]
args') <- Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang Located (PatBuilder GhcPs)
e
  = do  { [Located (Pat GhcPs)]
args'' <- (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [Located (PatBuilder GhcPs)]
args'
        ; SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e' ([Located (Pat GhcPs)]
args'' [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)]
[LPat GhcPs]
args) }
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [LPat GhcPs]
args
  = do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
       SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
f (Located (Pat GhcPs)
p Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [Located (Pat GhcPs)]
[LPat GhcPs]
args)
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (PatBuilder GhcPs))
e) []
  = do Pat GhcPs
p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc SrcSpanLess (Located (PatBuilder GhcPs))
PatBuilder GhcPs
e
       Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (Pat GhcPs))
Pat GhcPs
p)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
_
  = SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
e)

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

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

   PatBuilderBang SrcSpan
lb Located (PatBuilder GhcPs)
e   -- (! x)
        -> do { SrcSpan -> PatBuilder GhcPs -> PV ()
hintBangPat SrcSpan
loc PatBuilder GhcPs
e0
              ; Located (Pat GhcPs)
e' <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
              ; SrcSpan -> AnnKeywordId -> SrcSpan -> PV ()
forall (m :: * -> *).
MonadP m =>
SrcSpan -> AnnKeywordId -> SrcSpan -> m ()
addAnnotation SrcSpan
loc AnnKeywordId
AnnBang SrcSpan
lb
              ; Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return  (XBangPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcPs
NoExtField
noExtField Located (Pat GhcPs)
LPat GhcPs
e') }

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

   PatBuilderOpApp Located (PatBuilder GhcPs)
l (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
cl SrcSpanLess (Located RdrName)
c) Located (PatBuilder GhcPs)
r
     | RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c -> do
         Located (Pat GhcPs)
l <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
l
         Located (Pat GhcPs)
r <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
r
         Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
cl SrcSpanLess (Located RdrName)
c) (Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcPs)
l Located (Pat GhcPs)
r))

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

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

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

isBangRdr, isTildeRdr :: RdrName -> Bool
isBangRdr :: RdrName -> Bool
isBangRdr (Unqual OccName
occ) = OccName -> FastString
occNameFS OccName
occ FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit String
"!"
isBangRdr RdrName
_ = Bool
False
isTildeRdr :: RdrName -> Bool
isTildeRdr = (RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
==RdrName
eqTyCon_RDR)

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

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

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

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

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

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

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

checkFunBind :: SrcStrictness
             -> [AddAnn]
             -> SrcSpan
             -> Located RdrName
             -> LexicalFixity
             -> [Located (PatBuilder GhcPs)]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind SrcStrictness
strictness [AddAnn]
ann SrcSpan
lhs_loc Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (Located (GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
rhs_span SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
grhss)
  = do  [Located (Pat GhcPs)]
ps <- (Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> P [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern [Located (PatBuilder GhcPs)]
pats
        let match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lhs_loc SrcSpan
rhs_span
        -- Add back the annotations stripped from any HsPar values in the lhs
        -- mapM_ (\a -> a match_span) ann
        ([AddAnn], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
ann, Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
fun
                  [SrcSpan
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
match_span (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExtField
noExtField
                                        , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs
                                            { mc_fun :: Located RdrName
mc_fun    = Located RdrName
fun
                                            , mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
                                            , mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
                                        , m_pats :: [LPat GhcPs]
m_pats = [Located (Pat GhcPs)]
[LPat GhcPs]
ps
                                        , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
GRHSs GhcPs (LHsExpr GhcPs)
grhss })])
        -- The span of the match covers the entire equation.
        -- That isn't quite right, but it'll do for now.

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

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

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

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

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

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

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


        -- The parser left-associates, so there should
        -- not be any OpApps inside the e's
splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
-- Splits (f ! g a b) into (f, [(! g), a, b])
splitBang :: Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderOpApp l_arg op r_arg))
  | RdrName -> Bool
isBangRdr (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
op)
  = (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall a. a -> Maybe a
Just (Located (PatBuilder GhcPs)
l_arg, SrcSpan
-> SrcSpanLess (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (SrcSpan -> Located (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p. SrcSpan -> Located (PatBuilder p) -> PatBuilder p
PatBuilderBang (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located RdrName
op) Located (PatBuilder GhcPs)
arg1) Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder GhcPs)]
argns)
  where
    l' :: SrcSpan
l' = Located RdrName -> Located (PatBuilder GhcPs) -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs Located RdrName
op Located (PatBuilder GhcPs)
arg1
    (Located (PatBuilder GhcPs)
arg1,[Located (PatBuilder GhcPs)]
argns) = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall p.
Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang Located (PatBuilder GhcPs)
r_arg []
    split_bang :: Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang (Located (PatBuilder p)
-> Located (SrcSpanLess (Located (PatBuilder p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [Located (PatBuilder p)]
es = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang Located (PatBuilder p)
f (Located (PatBuilder p)
eLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es)
    split_bang Located (PatBuilder p)
e                       [Located (PatBuilder p)]
es = (Located (PatBuilder p)
e,[Located (PatBuilder p)]
es)
splitBang Located (PatBuilder GhcPs)
_ = Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall a. Maybe a
Nothing

-- See Note [isFunLhs vs mergeDataCon]
isFunLhs :: Located (PatBuilder GhcPs)
      -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
--
-- The whole LHS is parsed as a single expression.
-- Any infix operators on the LHS will parse left-associatively
-- E.g.         f !x y !z
--      will parse (rather strangely) as
--              (f ! x y) ! z
--      It's up to isFunLhs to sort out the mess
--
-- a .!. !b

isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
         [AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
e = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> P (Maybe
        (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
         [AddAnn]))
forall (m :: * -> *) a.
(HasSrcSpan a, MonadP m, SrcSpanLess a ~ RdrName) =>
Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e [] []
 where
   go :: Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (PatBuilderVar (dL->L _ f))) [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
       | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
f)        = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
SrcSpanLess (Located RdrName)
f, LexicalFixity
Prefix, [Located (PatBuilder GhcPs)]
es, [AddAnn]
ann))
   go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [Located (PatBuilder GhcPs)]
es       [AddAnn]
ann = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
f (Located (PatBuilder GhcPs)
eLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es) [AddAnn]
ann
   go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (PatBuilderPar e))   es :: [Located (PatBuilder GhcPs)]
es@(Located (PatBuilder GhcPs)
_:[Located (PatBuilder GhcPs)]
_) [AddAnn]
ann = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e [Located (PatBuilder GhcPs)]
es ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)

        -- Things of the form `!x` are also FunBinds
        -- See Note [FunBind vs PatBind]
   go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] [AddAnn]
ann
        | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
var)     = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
SrcSpanLess (Located RdrName)
var, LexicalFixity
Prefix, [], [AddAnn]
ann))

      -- For infix function defns, there should be only one infix *function*
      -- (though there may be infix *datacons* involved too).  So we don't
      -- need fixity info to figure out which function is being defined.
      --      a `K1` b `op` c `K2` d
      -- must parse as
      --      (a `K1` b) `op` (c `K2` d)
      -- The renamer checks later that the precedences would yield such a parse.
      --
      -- There is a complication to deal with bang patterns.
      --
      -- ToDo: what about this?
      --              x + 1 `op` y = ...

   go e :: Located (PatBuilder GhcPs)
e@(L SrcSpan
loc (PatBuilderOpApp Located (PatBuilder GhcPs)
l (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc' SrcSpanLess (Located RdrName)
op) Located (PatBuilder GhcPs)
r)) [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
        | Just (Located (PatBuilder GhcPs)
e',[Located (PatBuilder GhcPs)]
es') <- Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang Located (PatBuilder GhcPs)
e
        = do { Bool
bang_on <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BangPatBit
             ; if Bool
bang_on then Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e' ([Located (PatBuilder GhcPs)]
es' [Located (PatBuilder GhcPs)]
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (PatBuilder GhcPs)]
es) [AddAnn]
ann
               else Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess a
SrcSpanLess (Located RdrName)
op, LexicalFixity
Infix, (Located (PatBuilder GhcPs)
lLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:Located (PatBuilder GhcPs)
rLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es), [AddAnn]
ann)) }
                -- No bangs; behave just like the next case
        | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
op)         -- We have found the function!
        = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess a
SrcSpanLess (Located RdrName)
op, LexicalFixity
Infix, (Located (PatBuilder GhcPs)
lLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:Located (PatBuilder GhcPs)
rLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es), [AddAnn]
ann))
        | Bool
otherwise                     -- Infix data con; keep going
        = do { Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
mb_l <- Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
l [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
             ; case Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
mb_l of
                 Just (a
op', LexicalFixity
Infix, Located (PatBuilder GhcPs)
j : Located (PatBuilder GhcPs)
k : [Located (PatBuilder GhcPs)]
es', [AddAnn]
ann')
                   -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (a
op', LexicalFixity
Infix, Located (PatBuilder GhcPs)
j Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: Located (PatBuilder GhcPs)
op_app Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder GhcPs)]
es', [AddAnn]
ann'))
                   where
                     op_app :: Located (PatBuilder GhcPs)
op_app = SrcSpan
-> SrcSpanLess (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located RdrName
-> Located (PatBuilder GhcPs)
-> PatBuilder GhcPs
forall p.
Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
PatBuilderOpApp Located (PatBuilder GhcPs)
k
                               (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess (Located RdrName)
op) Located (PatBuilder GhcPs)
r)
                 Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
_ -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. Maybe a
Nothing }
   go Located (PatBuilder GhcPs)
_ [Located (PatBuilder GhcPs)]
_ [AddAnn]
_ = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
        (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. Maybe a
Nothing

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


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

A TyElKindApp captures type application written in haskell as

    @ Foo

where Foo is some type.

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

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

tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness TyEl
TyElTilde = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnTilde, SrcStrictness
SrcLazy)
tyElStrictness TyEl
TyElBang = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnBang, SrcStrictness
SrcStrict)
tyElStrictness TyEl
_ = Maybe (AnnKeywordId, SrcStrictness)
forall a. Maybe a
Nothing

-- | Extract a strictness/unpackedness annotation from the front of a reversed
-- 'TyEl' list.
pStrictMark
  :: [Located TyEl] -- reversed TyEl
  -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -}
           , [AddAnn]
           , [Located TyEl] {- remaining TyEl -})
pStrictMark :: [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (Located TyEl)
x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located TyEl)
x2) : [Located TyEl]
xs)
  | Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
  , TyElUnpackedness (unpkAnns, prag, unpk) <- SrcSpanLess (Located TyEl)
x2
  = (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
str)
         , [AddAnn]
unpkAnns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
strAnnId SrcSpan
l1]
         , [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
  | Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
  = (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
str)
         , [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
strAnnId SrcSpan
l]
         , [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
  | TyElUnpackedness (anns, prag, unpk) <- SrcSpanLess (Located TyEl)
x1
  = (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
         , [AddAnn]
anns
         , [Located TyEl]
xs )
pStrictMark [Located TyEl]
_ = Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. Maybe a
Nothing

pBangTy
  :: LHsType GhcPs  -- a type to be wrapped inside HsBangTy
  -> [Located TyEl] -- reversed TyEl
  -> ( Bool           {- has a strict mark been consumed? -}
     , LHsType GhcPs  {- the resulting BangTy -}
     , P ()           {- add annotations -}
     , [Located TyEl] {- remaining TyEl -})
pBangTy :: LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy lt :: LHsType GhcPs
lt@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
_) [Located TyEl]
xs =
  case [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark [Located TyEl]
xs of
    Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
    Just (Located HsSrcBang -> Located (SrcSpanLess (Located HsSrcBang))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located HsSrcBang)
strictMark, [AddAnn]
anns, [Located TyEl]
xs') ->
      let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
          bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExtField
noExtField SrcSpanLess (Located HsSrcBang)
HsSrcBang
strictMark LHsType GhcPs
lt
      in (Bool
True, SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bl SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl [AddAnn]
anns, [Located TyEl]
xs')

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

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

    -- clause [doc]:
    -- we do not expect to encounter any docs
    go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElDocPrev _)):[a]
_) =
      SrcSpan -> P (LHsType GhcPs)
forall a. SrcSpan -> P a
failOpDocPrev SrcSpan
l

    -- to improve error messages, we do a bit of guesswork to determine if the
    -- user intended a '!' or a '~' as a strictness annotation
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
x) : [a]
xs)
      | Just (AnnKeywordId
_, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess a
TyEl
x
      , let guess :: [a] -> Bool
guess [] = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpd _)):[a]
_) = Bool
False
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpr _)):[a]
_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElKindApp _ _)):[a]
_) = Bool
False
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElTilde)):[a]
_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElBang)):[a]
_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElUnpackedness _)):[a]
_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElDocPrev _)):[a]
xs') = [a] -> Bool
guess [a]
xs'
            guess [a]
_ = String -> Bool
forall a. String -> a
panic String
"mergeOps.go.guess: Impossible Match"
                      -- due to #15884
        in [a] -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => [a] -> Bool
guess [a]
xs
      = if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& (t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1 Bool -> Bool -> Bool
|| [LHsTypeArg GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTypeArg GhcPs]
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
        then do { LHsType GhcPs
a <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
                ; Located SrcStrictness -> LHsType GhcPs -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
a) }
        else Located SrcStrictness -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> P a
failOpStrictnessPosition (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str)

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

    -- clause [opr.1]: interpret 'TyElTilde' as an operator
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElTilde):[a]
xs) =
      let op :: RdrName
op = RdrName
eqTyCon_RDR
      in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

    -- clause [opr.2]: interpret 'TyElBang' as an operator
    go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElBang):[a]
xs) =
      let op :: RdrName
op = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
tcClsName (String -> FastString
fsLit String
"!")
      in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

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

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

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

    go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ [a]
_ = String -> P (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOps.go: Impossible Match"
                        -- due to #15884

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

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

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

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

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

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

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

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

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

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

-}

pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd t)):[Located TyEl]
xs)
  | (Bool
True, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
t) [Located TyEl]
xs
  = (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs')
pInfixSide (Located TyEl
el:[Located TyEl]
xs1)
  | Just LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
  = [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1] [Located TyEl]