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

-- Functions over HsSyn specialised to RdrName.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}

module   RdrHsSyn (
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkSpliceDecl,
        mkRoleAnnotDecl,
        mkClassDecl,
        mkTyData, mkDataFamInst,
        mkTySynonym, mkTyFamInstEqn,
        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,
        mkATDefault,

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
        checkBlockArguments,
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
        bang_RDR,
        isBangRdr,
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSigLhs,
        checkDoAndIfThenElse,
        LRuleTyTmVar, RuleTyTmVar(..),
        mkRuleBndrs, mkRuleTyVarBndrs,
        checkRuleTyVarBndrNames,
        checkRecordSyntax,
        checkEmptyGADTs,
        parseErrorSDoc, hintBangPat,
        TyEl(..), mergeOps, mergeDataCon,

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

        -- Token symbols
        forallSym,
        starSym,

        -- Warnings and errors
        warnStarIsType,
        failOpFewArgs,

        SumOrTuple (..), mkSumOrTuple

    ) where

import GhcPrelude
import HsSyn            -- 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(..) )

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 HsDecls ****

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 loc :: SrcSpan
loc d :: 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)
NoExt
noExt 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 loc :: SrcSpan
loc d :: 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)
NoExt
noExt 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 loc :: 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 _ (mcxt, tycl_hdr)) fds :: Located (a, [LHsFunDep GhcPs])
fds where_cls :: OrdList (LHsDecl GhcPs)
where_cls
  = do { (binds :: LHsBinds GhcPs
binds, sigs :: [LSig GhcPs]
sigs, ats :: [LFamilyDecl GhcPs]
ats, at_insts :: [LTyFamInstDecl GhcPs]
at_insts, _, docs :: [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
       ; (cls :: Located RdrName
cls, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
       ; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars :: LHsQTyVars GhcPs
tyvars,annst :: [AddAnn]
annst) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text "class") SDoc
whereDots Located RdrName
cls [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
annst -- Add any API Annotations to the top SrcSpan
       ; (at_defs :: [LTyFamDefltEqn GhcPs]
at_defs, annsi :: [P ()]
annsi) <- (LTyFamInstDecl GhcPs -> P (LTyFamDefltEqn GhcPs, P ()))
-> [LTyFamInstDecl GhcPs] -> P ([LTyFamDefltEqn GhcPs], [P ()])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-> P (LTyFamDefltEqn GhcPs, P ())
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
 -> P (LTyFamDefltEqn GhcPs, P ()))
-> (LTyFamInstDecl GhcPs
    -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()))
-> LTyFamInstDecl GhcPs
-> P (LTyFamDefltEqn GhcPs, P ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
mkATDefault) [LTyFamInstDecl GhcPs]
at_insts
       ; [P ()] -> P ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [P ()]
annsi
       ; 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]
-> [LTyFamDefltEqn pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = XClassDecl GhcPs
NoExt
noExt, 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 :: [LTyFamDefltEqn GhcPs]
tcdATDefs = [LTyFamDefltEqn GhcPs]
at_defs
                                   , tcdDocs :: [LDocDecl]
tcdDocs  = [LDocDecl]
docs })) }

mkATDefault :: LTyFamInstDecl GhcPs
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-- ^ Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration.
-- We parse things as the former and use this function to convert to the latter
--
-- We use the Either monad because this also called from "Convert".
--
-- The @P ()@ we return corresponds represents an action which will add
-- some necessary paren annotations to the parsing context. Naturally, this
-- is not something that the "Convert" use cares about.
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
      | FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon = Located (IdP GhcPs)
tc, feqn_bndrs :: forall pass pats rhs.
FamEqn pass pats rhs -> Maybe [LHsTyVarBndr pass]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs, feqn_pats :: forall pass pats rhs. FamEqn pass pats rhs -> pats
feqn_pats = [LHsTypeArg GhcPs]
pats
               , feqn_fixity :: forall pass pats rhs. FamEqn pass pats rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity, feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs = LHsType GhcPs
rhs } <- FamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
e
      = do { (tvs :: LHsQTyVars GhcPs
tvs, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text "default") SDoc
equalsDots Located RdrName
Located (IdP GhcPs)
tc [LHsTypeArg GhcPs]
pats
           ; let f :: LTyFamDefltEqn GhcPs
f = SrcSpan
-> SrcSpanLess (LTyFamDefltEqn GhcPs) -> LTyFamDefltEqn GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsQTyVars GhcPs) (LHsType GhcPs)
feqn_ext    = XCFamEqn GhcPs (LHsQTyVars GhcPs) (LHsType GhcPs)
NoExt
noExt
                                    , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon  = Located (IdP GhcPs)
tc
                                    , feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs  = ASSERT( isNothing bndrs )
                                                    Maybe [LHsTyVarBndr GhcPs]
forall a. Maybe a
Nothing
                                    , feqn_pats :: LHsQTyVars GhcPs
feqn_pats   = LHsQTyVars GhcPs
tvs
                                    , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                                    , feqn_rhs :: LHsType GhcPs
feqn_rhs    = LHsType GhcPs
rhs })
           ; (LTyFamDefltEqn GhcPs, P ())
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LTyFamDefltEqn GhcPs
f, SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns) }
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault"
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault"
mkATDefault _ = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault: Impossible Match"
                                -- due to #15884

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 loc :: SrcSpan
loc new_or_data :: NewOrData
new_or_data cType :: 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 _ (mcxt, tycl_hdr))
         ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: HsDeriving GhcPs
maybe_deriv
  = do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (NewOrData -> SDoc
forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
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
NoExt
noExt,
                                    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 new_or_data :: NewOrData
new_or_data cType :: Maybe (Located CType)
cType mcxt :: Maybe (LHsContext GhcPs)
mcxt ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: 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
NoExt
noExt
                            , 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 loc :: SrcSpan
loc lhs :: LHsType GhcPs
lhs rhs :: LHsType GhcPs
rhs
  = do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text "type") SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
       ; SrcSpan -> [AddAnn] -> P ()
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
NoExt
noExt
                                 , 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 })) }

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 bndrs :: Maybe [LHsTyVarBndr GhcPs]
bndrs lhs :: LHsType GhcPs
lhs rhs :: LHsType GhcPs
rhs
  = do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [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 [LHsTypeArg GhcPs] (LHsType GhcPs)
-> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                  (FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
feqn_ext    = XCFamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
NoExt
noExt
                          , 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 loc :: SrcSpan
loc new_or_data :: NewOrData
new_or_data cType :: Maybe (Located CType)
cType (mcxt :: Maybe (LHsContext GhcPs)
mcxt, bndrs :: Maybe [LHsTyVarBndr GhcPs]
bndrs, tycl_hdr :: LHsType GhcPs
tycl_hdr)
              ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: HsDeriving GhcPs
maybe_deriv
  = do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
       ; (AddAnn -> P ()) -> [AddAnn] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\a :: AddAnn
a -> AddAnn
a 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
NoExt
noExt (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl (FamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                  (FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
feqn_ext    = XCFamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
NoExt
noExt
                          , 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 loc :: SrcSpan
loc eqn :: 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
NoExt
noExt (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 loc :: SrcSpan
loc info :: FamilyInfo GhcPs
info lhs :: LHsType GhcPs
lhs ksig :: Located (FamilyResultSig GhcPs)
ksig injAnn :: Maybe (LInjectivityAnn GhcPs)
injAnn
  = do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
       ; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (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 ()
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
NoExt
noExt (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
NoExt
noExt
                                           , 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
                        DataFamily          -> SDoc
empty
                        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 loc :: SrcSpan
loc expr :: 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
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (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
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (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
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (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 loc :: SrcSpan
loc tycon :: Located RdrName
tycon roles :: [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
NoExt
noExt 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 loc_role :: SrcSpan
loc_role 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 loc_role :: 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 found_role :: 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
          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 a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc_role
              (String -> SDoc
text "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 _ = String -> P (Located (Maybe Role))
forall a. String -> a
panic "parse_role: Impossible Match"
                                -- due to #15884

    suggestions :: [a] -> SDoc
suggestions []   = SDoc
empty
    suggestions [r :: a
r]  = String -> SDoc
text "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 list :: [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Perhaps you meant one of these:")
                       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 decls :: 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 l :: SrcSpan
l (ValD x b)) : ds :: [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 l' :: SrcSpan
l' b' :: SrcSpanLess (LHsBind GhcPs)
b', ds' :: [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 (d :: LHsDecl GhcPs
d : ds :: [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 binding :: OrdList (LHsDecl GhcPs)
binding
  = do { (mbs :: LHsBinds GhcPs
mbs, sigs :: [LSig GhcPs]
sigs, fam_ds :: [LFamilyDecl GhcPs]
fam_ds, tfam_insts :: [LTyFamInstDecl GhcPs]
tfam_insts
         , dfam_insts :: [LDataFamInstDecl GhcPs]
dfam_insts, _) <- 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
NoExt
noExt 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 fb :: OrdList (LHsDecl GhcPs)
fb = [LHsDecl GhcPs]
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall a a a a a.
(HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a,
 HasSrcSpan a, SrcSpanLess a ~ Sig GhcPs,
 SrcSpanLess a ~ FamilyDecl GhcPs,
 SrcSpanLess a ~ TyFamInstDecl GhcPs,
 SrcSpanLess a ~ DataFamInstDecl GhcPs, SrcSpanLess a ~ DocDecl) =>
[LHsDecl GhcPs] -> P (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] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go []              = (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (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 l :: SrcSpan
l (ValD _ b)) : ds :: [LHsDecl GhcPs]
ds)
      = do { (bs :: LHsBinds GhcPs
bs, ss :: [a]
ss, ts :: [a]
ts, tfis :: [a]
tfis, dfis :: [a]
dfis, docs :: [a]
docs) <- [LHsDecl GhcPs] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds'
           ; (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (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
        (b' :: LHsBind GhcPs
b', ds' :: [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 l :: SrcSpan
l decl :: SrcSpanLess (LHsDecl GhcPs)
decl) : ds :: [LHsDecl GhcPs]
ds)
      = do { (bs :: LHsBinds GhcPs
bs, ss :: [a]
ss, ts :: [a]
ts, tfis :: [a]
tfis, dfis :: [a]
dfis, docs :: [a]
docs) <- [LHsDecl GhcPs] -> P (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])
-> P (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])
-> P (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])
-> P (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])
-> P (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])
-> P (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 -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a]))
-> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a b. (a -> b) -> a -> b
$
                    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
                          String -> SDoc
text "at the top level:")
                       2 (SpliceDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl GhcPs
d)
               _ -> String -> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 loc1 :: SrcSpan
loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
                                 , fun_matches =
                                   MG { mg_alts = (dL->L _ mtchs1) } }))
            binds :: [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 mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc
       ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
                                    , fun_matches =
                                        MG { mg_alts = (dL->L _ mtchs2) } })))
         : binds :: [LHsDecl GhcPs]
binds) _
        | 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 mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 (DocD {})) : binds :: [LHsDecl GhcPs]
binds) doc_decls :: [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 mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc binds :: [LHsDecl GhcPs]
binds doc_decls :: [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 bind :: LHsBind GhcPs
bind binds :: [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 "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 _ (Match { m_pats = args })) : _) = Bool -> Bool
not ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args)
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XMatch _)) : _) = String -> Bool
forall a. String -> a
panic "has_args"
has_args (_ : _) = String -> Bool
forall a. String -> a
panic "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 loc :: SrcSpan
loc tc :: 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 "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 loc :: SrcSpan
loc patsyn_name :: 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 _ decls :: 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) (AddAnn
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)) ~ NoExt) =>
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 loc :: 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 pats :: [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)
NoExt
noExt
                                                , 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 p1 :: LPat GhcPs
p1 p2 :: 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)
NoExt
noExt
                                                , 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 loc :: SrcSpan
loc decl :: SrcSpanLess (LHsDecl GhcPs)
decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a a. Outputable a => SrcSpan -> a -> P a
extraDeclErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl

    extraDeclErr :: SrcSpan -> a -> P a
extraDeclErr loc :: SrcSpan
loc decl :: a
decl =
        SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text "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 loc :: SrcSpan
loc decl :: HsDecl GhcPs
decl =
      SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text "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 :: AddAnn
wrongNumberErr loc :: SrcSpan
loc =
      SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text "pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text "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 loc :: SrcSpan
loc pat :: LPat GhcPs
pat =
    SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text "record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
    LPat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 name :: Located RdrName
name mb_forall :: Maybe [LHsTyVarBndr GhcPs]
mb_forall mb_cxt :: Maybe (LHsContext GhcPs)
mb_cxt args :: 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
NoExt
noExt
               , 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 }
  where
    args' :: HsConDeclDetails GhcPs
args' = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
args

mkGadtDecl :: [Located RdrName]
           -> LHsType GhcPs     -- Always a HsForAllTy
           -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl names :: [Located RdrName]
names ty :: 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
NoExt
noExt
                 , 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 l :: SrcSpan
l _),anns1 :: [AddAnn]
anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn])
forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType GhcPs
ty []
    (tvs :: [LHsTyVarBndr GhcPs]
tvs, rho :: LHsType GhcPs
rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy LHsType GhcPs
ty'
    (mcxt :: Maybe (LHsContext GhcPs)
mcxt, tau :: LHsType GhcPs
tau, anns2 :: [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 _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann :: [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 l :: SrcSpan
l (HsParTy _ ty)) ann :: [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 tau :: LHsType pass
tau                  ann :: [AddAnn]
ann
      = (Maybe (LHsContext pass)
forall a. Maybe a
Nothing, LHsType pass
tau, [AddAnn]
ann)

    (args :: HsConDeclDetails GhcPs
args, res_ty :: 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
    args' :: HsConDeclDetails GhcPs
args' = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
args

    -- See Note [GADT abstract syntax] in HsDecls
    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 _ (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 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 l :: SrcSpan
l (HsParTy _ ty)) ann :: [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 ty :: LHsType pass
ty                   ann :: [AddAnn]
ann = (LHsType pass
ty, [AddAnn]
ann)

nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
-- ^ This function ensures that fields with strictness or packedness
-- annotations put these annotations on an outer 'HsBangTy'.
--
-- The problem is that in the parser, strictness and packedness annotations
-- bind more tightly that docstrings. However, the expectation downstream of
-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
-- top-level type.
--
-- See #15206
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs details :: HsConDeclDetails GhcPs
details
  = case HsConDeclDetails GhcPs
details of
      PrefixCon as :: [LHsType GhcPs]
as -> [LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> LHsType GhcPs)
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
 SrcSpanLess p ~ HsType pass) =>
p -> p
go [LHsType GhcPs]
as)
      RecCon r :: Located [LConDeclField GhcPs]
r -> Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon Located [LConDeclField GhcPs]
r
      InfixCon a1 :: LHsType GhcPs
a1 a2 :: LHsType GhcPs
a2 -> LHsType GhcPs -> LHsType GhcPs -> HsConDeclDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
 SrcSpanLess p ~ HsType pass) =>
p -> p
go LHsType GhcPs
a1) (LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
 SrcSpanLess p ~ HsType pass) =>
p -> p
go LHsType GhcPs
a2)
  where
    go :: p -> p
go (p -> Located (SrcSpanLess p)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
      SrcSpan -> SrcSpanLess p -> p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy pass
NoExt
noExt HsSrcBang
s (LHsType pass
-> LHsDocString -> SrcSpanLess (LHsType pass) -> LHsType pass
forall a b c.
(HasSrcSpan a, HasSrcSpan b, HasSrcSpan c) =>
a -> b -> SrcSpanLess c -> c
addCLoc LHsType pass
lty LHsDocString
lds (XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy XDocTy pass
NoExt
noExt LHsType pass
lty LHsDocString
lds)))
    go lty :: p
lty = p
lty


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 occ :: OccName
occ) ns :: NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual m :: ModuleName
m occ :: OccName
occ) ns :: NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig m :: Module
m occ :: OccName
occ) ns :: NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact n :: Name
n)    ns :: NameSpace
ns
  | Just thing :: 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 tc :: TyCon
tc) ns :: 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 dc :: DataCon
dc)) ns :: 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 thing :: TyThing
thing ns :: NameSpace
ns
  = String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 tc :: TyCon
tc
  | TyCon -> Bool
isTupleTyCon TyCon
tc
  , Just dc :: 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 dc :: 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 n :: Name
n)
  | Just arity :: 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 rdr :: 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!
-}

checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
             -> P (LHsQTyVars GhcPs, [AddAnn])
-- Same as checkTyVars, but in the P monad
checkTyVarsP :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP pp_what :: SDoc
pp_what equals_or_where :: SDoc
equals_or_where tc :: Located RdrName
tc tparms :: [LHsTypeArg GhcPs]
tparms
  = do { let checkedTvs :: Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkedTvs = SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars SDoc
pp_what SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparms
       ; Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
-> P (LHsQTyVars GhcPs, [AddAnn])
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkedTvs }

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

checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
            -> Either (SrcSpan, SDoc)
                      ( 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).
-- We use the Either monad because it's also called (via 'mkATDefault') from
-- "Convert".
checkTyVars :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars pp_what :: SDoc
pp_what equals_or_where :: SDoc
equals_or_where tc :: Located RdrName
tc tparms :: [LHsTypeArg GhcPs]
tparms
  = do { (tvs :: [LHsTyVarBndr GhcPs]
tvs, anns :: [[AddAnn]]
anns) <- ([(LHsTyVarBndr GhcPs, [AddAnn])]
 -> ([LHsTyVarBndr GhcPs], [[AddAnn]]))
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
-> Either (SrcSpan, SDoc) ([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 (Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
 -> Either (SrcSpan, SDoc) ([LHsTyVarBndr GhcPs], [[AddAnn]]))
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
-> Either (SrcSpan, SDoc) ([LHsTyVarBndr GhcPs], [[AddAnn]])
forall a b. (a -> b) -> a -> b
$ (LHsTypeArg GhcPs
 -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]))
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTypeArg GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
check [LHsTypeArg GhcPs]
tparms
       ; (LHsQTyVars GhcPs, [AddAnn])
-> Either (SrcSpan, SDoc) (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
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
check (HsTypeArg _ ki :: LHsType GhcPs
ki@(L loc :: SrcSpan
loc _))
                              = (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan
loc,
                                      [SDoc] -> SDoc
vcat [ String -> SDoc
text "Unexpected type application" SDoc -> SDoc -> SDoc
<+>
                                            String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
                                          , String -> SDoc
text "In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what SDoc -> SDoc -> SDoc
<+>
                                            PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)])
    check (HsValArg ty :: LHsType GhcPs
ty) = [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens [] LHsType GhcPs
ty
    check (HsArgPar sp :: SrcSpan
sp) = (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan
sp, [SDoc] -> SDoc
vcat [String -> SDoc
text "Malformed" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "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
              -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
    chkParens :: [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens acc :: [AddAnn]
acc (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsParTy _ ty)) = [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens (SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l
                                                        [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
acc) LHsType GhcPs
ty
    chkParens acc :: [AddAnn]
acc ty :: LHsType GhcPs
ty = case LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk LHsType GhcPs
ty of
      Left err :: (SrcSpan, SDoc)
err -> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
      Right tv :: LHsTyVarBndr GhcPs
tv -> (LHsTyVarBndr GhcPs, [AddAnn])
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. b -> Either a b
Right (LHsTyVarBndr GhcPs
tv, [AddAnn] -> [AddAnn]
forall a. [a] -> [a]
reverse [AddAnn]
acc)

        -- Check that the name space is correct!
    chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
    chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
        | RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv    = LHsTyVarBndr GhcPs -> Either (SrcSpan, SDoc) (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
NoExt
noExt (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 l :: SrcSpan
l (HsTyVar _ _ (dL->L ltv tv)))
        | RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv    = LHsTyVarBndr GhcPs -> Either (SrcSpan, SDoc) (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
NoExt
noExt (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 loc :: SrcSpan
loc _)
        = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc,
                [SDoc] -> SDoc
vcat [ String -> SDoc
text "Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
                     , String -> SDoc
text "In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                       SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
                     , [SDoc] -> SDoc
vcat[ (String -> SDoc
text "A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
                              SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration should have form"))
                     , Int -> SDoc -> SDoc
nest 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 "where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text "= ..."

checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just c :: LHsContext GhcPs
c)
    = do Bool
allowed <- ExtBits -> P 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 a. SrcSpan -> SDoc -> P a
parseErrorSDoc (LHsContext GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsContext GhcPs
c)
                 (String -> SDoc
text "Illegal datatype context (use DatatypeContexts):"
                  SDoc -> SDoc -> SDoc
<+> LHsContext GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId (GhcPass 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 v :: Located RdrName
v Nothing)    = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr    XCRuleBndr GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
v
        cvt_one (RuleTyTmVar v :: Located RdrName
v (Just sig :: 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
NoExt
noExt 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 v :: Located RdrName
v Nothing)    = XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar   XUserTyVar GhcPs
NoExt
noExt ((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 v :: Located RdrName
v (Just sig :: 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
NoExt
noExt ((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 occ :: OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
        tm_to_ty _ = String -> RdrName
forall a. String -> a
panic "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. (HasSrcSpan a, SrcSpanLess a ~ RdrName) => a -> P ()
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 pass. HsTyVarBndr pass -> IdP pass
hsTyVarName)
  where check :: a -> P ()
check (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Unqual occ)) = do
          Bool -> P () -> P ()
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` ["forall","family","role"])
               (SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ "parse error on input "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
        check _ = String -> P ()
forall a. String -> a
panic "checkRuleTyVarBndrNames"

checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax :: Located a -> P (Located a)
checkRecordSyntax lr :: Located a
lr@(Located a -> Located (SrcSpanLess (Located a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc r :: SrcSpanLess (Located a)
r)
    = do Bool
allowed <- ExtBits -> P Bool
getBit ExtBits
TraditionalRecordSyntaxBit
         if Bool
allowed
             then Located a -> P (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
lr
             else SrcSpan -> SDoc -> P (Located a)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc
                   (String -> SDoc
text "Illegal record syntax (use TraditionalRecordSyntax):"
                    SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
SrcSpanLess (Located a)
r)

-- | 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 span :: SrcSpan
span (_, []))           -- Empty GADT declaration.
    = do Bool
gadtSyntax <- ExtBits -> P Bool
getBit ExtBits
GadtSyntaxBit   -- GADTs implies GADTSyntax
         if Bool
gadtSyntax
            then Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
            else SrcSpan -> SDoc -> P (Located ([AddAnn], [LConDecl GhcPs]))
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
span (SDoc -> P (Located ([AddAnn], [LConDecl GhcPs])))
-> SDoc -> P (Located ([AddAnn], [LConDecl GhcPs]))
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
              [ String -> SDoc
text "Illegal keyword 'where' in data declaration"
              , String -> SDoc
text "Perhaps you intended to use GADTs or a similar language"
              , String -> SDoc
text "extension to enable syntax: data T where"
              ]
checkEmptyGADTs gadts :: 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 is_cls :: Bool
is_cls ty :: 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 l :: SrcSpan
l ty :: SrcSpanLess (LHsType GhcPs)
ty) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix = SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ty [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix

    -- workaround to define '*' despite StarIsType
    go :: SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go lp :: SrcSpan
lp (HsParTy _ (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsStarTy _ isUni))) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix
      = do { AddAnn
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 l :: SrcSpan
l (HsTyVar _ _ (Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ tc :: SrcSpanLess (Located RdrName)
tc)) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: 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 (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
tc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, [AddAnn]
ann)
    go _ (HsOpTy _ t1 :: 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 _ tc :: SrcSpanLess (Located RdrName)
tc) t2 :: LHsType GhcPs
t2) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann _fix :: 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 l :: SrcSpan
l (HsParTy _ ty :: LHsType GhcPs
ty)    acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: 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 _ (HsAppTy _ t1 :: LHsType GhcPs
t1 t2 :: LHsType GhcPs
t2) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: 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 _ (HsAppKindTy l :: XAppKindTy GhcPs
l ty :: LHsType GhcPs
ty ki :: LHsType GhcPs
ki) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: 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 l :: SrcSpan
l (HsTupleTy _ HsBoxedOrConstraintTuple ts :: [LHsType GhcPs]
ts) [] ann :: [AddAnn]
ann fix :: 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 HsTypes  (TODO: is this still relevant?)
    go l :: SrcSpan
l _ _ _ _
      = SrcSpan
-> SDoc
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text "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.
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments expr :: LHsExpr GhcPs
expr = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
expr of
    HsDo _ DoExpr _ -> String -> P ()
check "do block"
    HsDo _ MDoExpr _ -> String -> P ()
check "mdo block"
    HsLam {} -> String -> P ()
check "lambda expression"
    HsCase {} -> String -> P ()
check "case expression"
    HsLamCase {} -> String -> P ()
check "lambda-case expression"
    HsLet {} -> String -> P ()
check "let expression"
    HsIf {} -> String -> P ()
check "if expression"
    HsProc {} -> String -> P ()
check "proc expression"
    _ -> () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    check :: String -> P ()
check element :: String
element = do
      Bool
blockArguments <- ExtBits -> P Bool
getBit ExtBits
BlockArgumentsBit
      Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
        SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
expr) (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text "Unexpected " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text " in function application:"
           SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 (LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
expr)
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "You could write it with parentheses"
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "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 l :: SrcSpan
l orig_t :: 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 anns :: [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lp :: 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 anns :: [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lp1 :: 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 _anns :: [AddAnn]
_anns t :: 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 "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 msg :: SDoc
msg ty :: 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 _ (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 _ (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 l :: SrcSpan
l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
                                  [ String -> SDoc
text "Unexpected haddock", SDoc -> SDoc
quotes (LHsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsDocString
ds)
                                  , String -> SDoc
text "on", SDoc
msg, SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t) ]
    go _ = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern msg :: SDoc
msg e :: LHsExpr GhcPs
e = SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e

checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns msg :: SDoc
msg es :: [LHsExpr GhcPs]
es = (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern SDoc
msg) [LHsExpr GhcPs]
es

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

checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
         -> P (LPat GhcPs)
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat _ loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l e :: SrcSpanLess (LHsExpr GhcPs)
e@(HsVar _ (dL->L _ c))) args :: [LPat GhcPs]
args
  | RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c = LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat 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) ([LPat GhcPs] -> HsConPatDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LPat GhcPs]
args)))
  | Bool -> Bool
not ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec SrcSpanLess (Located RdrName)
RdrName
c =
      SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail (String -> SDoc
text "Perhaps you intended to use RecursiveDo") SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e
checkPat msg :: SDoc
msg loc :: SrcSpan
loc e :: LHsExpr GhcPs
e args :: [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 (e' :: LHsExpr GhcPs
e', args' :: [LHsExpr GhcPs]
args') <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang LHsExpr GhcPs
e
  = do  { [LPat GhcPs]
args'' <- SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns SDoc
msg [LHsExpr GhcPs]
args'
        ; SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat SDoc
msg SrcSpan
loc LHsExpr GhcPs
e' ([LPat GhcPs]
args'' [LPat GhcPs] -> [LPat GhcPs] -> [LPat GhcPs]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs]
args) }
checkPat msg :: SDoc
msg loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) args :: [LPat GhcPs]
args
  = do LPat GhcPs
p <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
       SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat SDoc
msg SrcSpan
loc LHsExpr GhcPs
f (LPat GhcPs
p LPat GhcPs -> [LPat GhcPs] -> [LPat GhcPs]
forall a. a -> [a] -> [a]
: [LPat GhcPs]
args)
checkPat msg :: SDoc
msg loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ e :: SrcSpanLess (LHsExpr GhcPs)
e) []
  = do LPat GhcPs
p <- SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
checkAPat SDoc
msg SrcSpan
loc SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e
       LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LPat GhcPs)
LPat GhcPs
p)
checkPat msg :: SDoc
msg loc :: SrcSpan
loc e :: LHsExpr GhcPs
e _
  = SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
e)

checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
checkAPat msg :: SDoc
msg loc :: SrcSpan
loc e0 :: HsExpr GhcPs
e0 = do
 Bool
nPlusKPatterns <- ExtBits -> P Bool
getBit ExtBits
NPlusKPatternsBit
 case HsExpr GhcPs
e0 of
   EWildPat _ -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> LPat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExt
noExt)
   HsVar _ x :: Located (IdP GhcPs)
x  -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcPs
NoExt
noExt Located (IdP GhcPs)
x)
   HsLit _ (HsStringPrim _ _) -- (#13260)
       -> SrcSpan -> SDoc -> P (LPat GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text "Illegal unboxed string literal in pattern:"
                              SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)

   HsLit _ l :: HsLit GhcPs
l  -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitPat GhcPs -> HsLit GhcPs -> LPat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcPs
NoExt
noExt HsLit GhcPs
l)

   -- 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
   HsOverLit _ pos_lit :: HsOverLit GhcPs
pos_lit          -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> LPat 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)
   NegApp _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsOverLit _ pos_lit)) _
                        -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> LPat GhcPs
mkNPat (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
pos_lit) (SyntaxExpr GhcPs -> Maybe (SyntaxExpr GhcPs)
forall a. a -> Maybe a
Just SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr))

   SectionR _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lb :: SrcSpan
lb (HsVar _ (dL->L _ bang))) e :: LHsExpr GhcPs
e    -- (! x)
        | SrcSpanLess (Located RdrName)
RdrName
bang RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR
        -> do { SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat SrcSpan
loc HsExpr GhcPs
e0
              ; LPat GhcPs
e' <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
              ; SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
loc AnnKeywordId
AnnBang SrcSpan
lb
              ; LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return  (XBangPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XBangPat p -> Pat p -> Pat p
BangPat XBangPat GhcPs
NoExt
noExt LPat GhcPs
e') }

   ELazyPat _ e :: LHsExpr GhcPs
e         -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XLazyPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XLazyPat p -> Pat p -> Pat p
LazyPat XLazyPat GhcPs
NoExt
noExt))
   EAsPat _ n :: Located (IdP GhcPs)
n e :: LHsExpr GhcPs
e         -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XAsPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs -> LPat GhcPs
forall p. XAsPat p -> Located (IdP p) -> Pat p -> Pat p
AsPat XAsPat GhcPs
NoExt
noExt) Located (IdP GhcPs)
n)
   -- view pattern is well-formed if the pattern is
   EViewPat _ expr :: LHsExpr GhcPs
expr patE :: LHsExpr GhcPs
patE -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
patE P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                            (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\p :: LPat GhcPs
p -> XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XViewPat p -> LHsExpr p -> Pat p -> Pat p
ViewPat XViewPat GhcPs
NoExt
noExt LHsExpr GhcPs
expr LPat GhcPs
p))
   ExprWithTySig _ e :: LHsExpr GhcPs
e t :: LHsSigWcType (NoGhcTc GhcPs)
t  -> do LPat GhcPs
e <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
                              LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSigPat GhcPs
-> LPat GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> LPat GhcPs
forall p. XSigPat p -> Pat p -> LHsSigWcType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
NoExt
noExt LPat GhcPs
e LHsSigWcType (NoGhcTc GhcPs)
t)

   -- n+k patterns
   OpApp _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L nloc :: SrcSpan
nloc (HsVar _ (dL->L _ n)))
           (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _    (HsVar _ (dL->L _ plus)))
           (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lloc :: SrcSpan
lloc (HsOverLit _ 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)
                      -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> Located (HsOverLit GhcPs) -> LPat 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))
   OpApp _ l :: LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L cl :: SrcSpan
cl (HsVar _ (dL->L _ c))) r :: LHsExpr GhcPs
r
     | OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
c) -> do
         LPat GhcPs
l <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
l
         LPat GhcPs
r <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
r
         LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat 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) (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
l LPat GhcPs
r))

   OpApp {}           -> SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc HsExpr GhcPs
e0

   ExplicitList _ _ es :: [LHsExpr GhcPs]
es -> do [LPat GhcPs]
ps <- (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg) [LHsExpr GhcPs]
es
                             LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XListPat GhcPs -> [LPat GhcPs] -> LPat GhcPs
forall p. XListPat p -> [Pat p] -> Pat p
ListPat XListPat GhcPs
NoExt
noExt [LPat GhcPs]
ps)

   HsPar _ e :: LHsExpr GhcPs
e          -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> Pat p -> Pat p
ParPat XParPat GhcPs
NoExt
noExt))

   ExplicitTuple _ es :: [LHsTupArg GhcPs]
es b :: Boxity
b
     | (LHsTupArg GhcPs -> Bool) -> [LHsTupArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcPs -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcPs]
es  -> do [LPat GhcPs]
ps <- (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg)
                                           [LHsExpr GhcPs
e | (LHsTupArg GhcPs -> Located (SrcSpanLess (LHsTupArg GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (Present _ e)) <- [LHsTupArg GhcPs]
es]
                                   LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> LPat GhcPs
forall p. XTuplePat p -> [Pat p] -> Boxity -> Pat p
TuplePat XTuplePat GhcPs
NoExt
noExt [LPat GhcPs]
ps Boxity
b)
     | Bool
otherwise -> SrcSpan -> SDoc -> P (LPat GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text "Illegal tuple section in pattern:"
                                        SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)

   ExplicitSum _ alt :: Int
alt arity :: Int
arity expr :: LHsExpr GhcPs
expr -> do
     LPat GhcPs
p <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
expr
     LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSumPat GhcPs -> LPat GhcPs -> Int -> Int -> LPat GhcPs
forall p. XSumPat p -> Pat p -> Int -> Int -> Pat p
SumPat XSumPat GhcPs
NoExt
noExt LPat GhcPs
p Int
alt Int
arity)

   RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = Located (IdP GhcPs)
c, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecFields fs :: [LHsRecField GhcPs (LHsExpr GhcPs)]
fs dd :: Maybe Int
dd }
                        -> do [LHsRecField GhcPs (LPat GhcPs)]
fs <- (LHsRecField GhcPs (LHsExpr GhcPs)
 -> P (LHsRecField GhcPs (LPat GhcPs)))
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> P [LHsRecField GhcPs (LPat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc
-> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField SDoc
msg) [LHsRecField GhcPs (LHsExpr GhcPs)]
fs
                              LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcPs)
c (HsRecFields GhcPs (LPat GhcPs) -> HsConPatDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon ([LHsRecField GhcPs (LPat GhcPs)]
-> Maybe Int -> HsRecFields GhcPs (LPat GhcPs)
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields [LHsRecField GhcPs (LPat GhcPs)]
fs Maybe Int
dd)))
   HsSpliceE _ s :: HsSplice GhcPs
s | Bool -> Bool
not (HsSplice GhcPs -> Bool
forall id. HsSplice id -> Bool
isTypedSplice HsSplice GhcPs
s)
               -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSplicePat GhcPs -> HsSplice GhcPs -> LPat GhcPs
forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat XSplicePat GhcPs
NoExt
noExt HsSplice GhcPs
s)
   _           -> SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc HsExpr GhcPs
e0

placeHolderPunRhs :: LHsExpr GhcPs
-- 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 :: LHsExpr GhcPs
placeHolderPunRhs = SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
pun_RDR))

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

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

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

patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg :: SDoc
msg loc :: SrcSpan
loc e :: HsExpr GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
err
    where err :: SDoc
err = String -> SDoc
text "Parse error in pattern:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
             SDoc -> SDoc -> SDoc
$$ SDoc
msg

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


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

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

checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkValDef msg :: SDoc
msg _strictness :: SrcStrictness
_strictness lhs :: LHsExpr GhcPs
lhs (Just sig :: LHsType GhcPs
sig) grhss :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
        -- x :: ty = rhs  parses as a *pattern* binding
  = SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind SDoc
msg (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LHsExpr GhcPs -> LHsType GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
lhs LHsType GhcPs
sig)
                        (XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
NoExt
noExt LHsExpr GhcPs
lhs (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig))) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss

checkValDef msg :: SDoc
msg strictness :: SrcStrictness
strictness lhs :: LHsExpr GhcPs
lhs 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 l :: SrcSpan
l (_,grhss))
  = do  { Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_fun <- LHsExpr GhcPs
-> P (Maybe
        (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
isFunLhs LHsExpr GhcPs
lhs
        ; case Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_fun of
            Just (fun :: Located RdrName
fun, is_infix :: LexicalFixity
is_infix, pats :: [LHsExpr GhcPs]
pats, ann :: [AddAnn]
ann) ->
              SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind SDoc
msg SrcStrictness
strictness [AddAnn]
ann (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
lhs)
                           Located RdrName
fun LexicalFixity
is_infix [LHsExpr 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)
            Nothing -> SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind SDoc
msg LHsExpr GhcPs
lhs Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g }

checkFunBind :: SDoc
             -> SrcStrictness
             -> [AddAnn]
             -> SrcSpan
             -> Located RdrName
             -> LexicalFixity
             -> [LHsExpr GhcPs]
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind msg :: SDoc
msg strictness :: SrcStrictness
strictness ann :: [AddAnn]
ann lhs_loc :: SrcSpan
lhs_loc fun :: Located RdrName
fun is_infix :: LexicalFixity
is_infix pats :: [LHsExpr GhcPs]
pats (Located (GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L rhs_span :: SrcSpan
rhs_span grhss :: SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
grhss)
  = do  [LPat GhcPs]
ps <- SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns SDoc
msg [LHsExpr 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)
NoExt
noExt
                                        , 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 = [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 HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind fn :: Located RdrName
fn ms :: [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
NoExt
noExt,
              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)) ~ NoExt) =>
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 :: SDoc
             -> LHsExpr GhcPs
             -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
checkPatBind :: SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind msg :: SDoc
msg lhs :: LHsExpr 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 _ (_,grhss))
  = do  { LPat GhcPs
lhs <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern SDoc
msg LHsExpr GhcPs
lhs
        ; ([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
NoExt
noExt 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 _ (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 l :: SrcSpan
l _)
  = SrcSpan -> SDoc -> P (Located RdrName)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l ((String -> SDoc
text "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 ":: ...")
                      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
         = "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
         = "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
         = "Perhaps you meant to use PatternSynonyms?"
         | Bool
otherwise
         = "Should be of form <variable> :: <type>"

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

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


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


        -- The parser left-associates, so there should
        -- not be any OpApps inside the e's
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
-- Splits (f ! g a b) into (f, [(! g), a, b])
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg))
  | SrcSpanLess (Located RdrName)
RdrName
op RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR = (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
l_arg, SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
NoExt
noExt LHsExpr GhcPs
bang LHsExpr GhcPs
arg1) LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
argns)
  where
    l' :: SrcSpan
l' = LHsExpr GhcPs -> LHsExpr GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
bang LHsExpr GhcPs
arg1
    (arg1 :: LHsExpr GhcPs
arg1,argns :: [LHsExpr GhcPs]
argns) = LHsExpr GhcPs
-> [LHsExpr GhcPs] -> (LHsExpr GhcPs, [LHsExpr GhcPs])
forall p. LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang LHsExpr GhcPs
r_arg []
    split_bang :: LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) es :: [LHsExpr p]
es = LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang LHsExpr p
f (LHsExpr p
eLHsExpr p -> [LHsExpr p] -> [LHsExpr p]
forall a. a -> [a] -> [a]
:[LHsExpr p]
es)
    split_bang e :: LHsExpr p
e                       es :: [LHsExpr p]
es = (LHsExpr p
e,[LHsExpr p]
es)
splitBang _ = Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. Maybe a
Nothing

-- See Note [isFunLhs vs mergeDataCon]
isFunLhs :: LHsExpr GhcPs
      -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr 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 :: LHsExpr GhcPs
-> P (Maybe
        (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
isFunLhs e :: LHsExpr GhcPs
e = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe
        (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall a.
(HasSrcSpan a, SrcSpanLess a ~ RdrName) =>
LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e [] []
 where
   go :: LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (HsVar _ (dL->L _ f))) es :: [LHsExpr GhcPs]
es ann :: [AddAnn]
ann
       | Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
f)        = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr 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, [LHsExpr GhcPs]
es, [AddAnn]
ann))
   go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) es :: [LHsExpr GhcPs]
es       ann :: [AddAnn]
ann = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
f (LHsExpr GhcPs
eLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr GhcPs]
es) [AddAnn]
ann
   go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsPar _ e))   es :: [LHsExpr GhcPs]
es@(_:_) ann :: [AddAnn]
ann = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e [LHsExpr 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 (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang)))
                (dL->L l (HsVar _ (L _ var))))) [] ann :: [AddAnn]
ann
        | SrcSpanLess (Located RdrName)
RdrName
bang RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR
        , Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
IdP GhcPs
var)     = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr 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
IdP GhcPs
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 :: LHsExpr GhcPs
e@(L loc :: SrcSpan
loc (OpApp _ l :: LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc' :: SrcSpan
loc' (HsVar _ (dL->L _ op))) r :: LHsExpr GhcPs
r)) es :: [LHsExpr GhcPs]
es ann :: [AddAnn]
ann
        | Just (e' :: LHsExpr GhcPs
e',es' :: [LHsExpr GhcPs]
es') <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang LHsExpr GhcPs
e
        = do { Bool
bang_on <- ExtBits -> P Bool
getBit ExtBits
BangPatBit
             ; if Bool
bang_on then LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e' ([LHsExpr GhcPs]
es' [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs]
es) [AddAnn]
ann
               else Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr 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, (LHsExpr GhcPs
lLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:LHsExpr GhcPs
rLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr 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, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr 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, (LHsExpr GhcPs
lLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:LHsExpr GhcPs
rLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr GhcPs]
es), [AddAnn]
ann))
        | Bool
otherwise                     -- Infix data con; keep going
        = do { Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_l <- LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
l [LHsExpr GhcPs]
es [AddAnn]
ann
             ; case Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_l of
                 Just (op' :: a
op', Infix, j :: LHsExpr GhcPs
j : k :: LHsExpr GhcPs
k : es' :: [LHsExpr GhcPs]
es', ann' :: [AddAnn]
ann')
                   -> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. a -> Maybe a
Just (a
op', LexicalFixity
Infix, LHsExpr GhcPs
j LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: LHsExpr GhcPs
op_app LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
es', [AddAnn]
ann'))
                   where
                     op_app :: LHsExpr GhcPs
op_app = SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
NoExt
noExt LHsExpr GhcPs
k
                               (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess (Located RdrName)
op))) LHsExpr GhcPs
r)
                 _ -> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. Maybe a
Nothing }
   go _ _ _ = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [LHsExpr 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 name :: RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
  ppr (TyElOpd ty :: HsType GhcPs
ty) = HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcPs
ty
  ppr (TyElKindApp _ ki :: LHsType GhcPs
ki) = String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
  ppr TyElTilde = String -> SDoc
text "~"
  ppr TyElBang = String -> SDoc
text "!"
  ppr (TyElUnpackedness (_, _, unpk :: SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
  ppr (TyElDocPrev doc :: HsDocString
doc) = HsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDocString
doc

tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness TyElTilde = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnTilde, SrcStrictness
SrcLazy)
tyElStrictness TyElBang = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnBang, SrcStrictness
SrcStrict)
tyElStrictness _ = 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 l1 :: SrcSpan
l1 x1 :: SrcSpanLess (Located TyEl)
x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l2 :: SrcSpan
l2 x2 :: SrcSpanLess (Located TyEl)
x2) : xs :: [Located TyEl]
xs)
  | Just (strAnnId :: AnnKeywordId
strAnnId, str :: 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]
++ [\s :: SrcSpan
s -> SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
s AnnKeywordId
strAnnId SrcSpan
l1]
         , [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x1 :: SrcSpanLess (Located TyEl)
x1) : xs :: [Located TyEl]
xs)
  | Just (strAnnId :: AnnKeywordId
strAnnId, str :: 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)
         , [\s :: SrcSpan
s -> SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
s AnnKeywordId
strAnnId SrcSpan
l]
         , [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x1 :: SrcSpanLess (Located TyEl)
x1) : xs :: [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 _ = 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 l1 :: SrcSpan
l1 _) xs :: [Located TyEl]
xs =
  case [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark [Located TyEl]
xs of
    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 l2 :: SrcSpan
l2 strictMark :: SrcSpanLess (Located HsSrcBang)
strictMark, anns :: [AddAnn]
anns, xs' :: [Located TyEl]
xs') ->
      let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
          bt :: HsType GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExt
noExt 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)
HsType GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
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 l1 :: SrcSpan
l1 (TyElOpd t)) : xs :: [Located TyEl]
xs)
  | (_, t' :: LHsType GhcPs
t', addAnns :: P ()
addAnns, xs' :: [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)
HsType 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 all_xs :: [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 (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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElUnpackedness (anns, unpkSrc, unpk))):xs :: [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 :: HsType GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExt
noExt HsSrcBang
strictMark LHsType GhcPs
a
              ; SrcSpan -> [AddAnn] -> P ()
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)
HsType GhcPs
bt) }
      else SrcSpan -> SDoc -> P (LHsType GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l SDoc
unpkError
      where
        unpkSDoc :: SDoc
unpkSDoc = case SourceText
unpkSrc of
          NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
          SourceText str :: String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text " #-}"
        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 "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
== 0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "must be applied to a type."
          | Bool
otherwise =
              -- See Note [Impossible case in mergeOps clause [unpk]]
              String -> SDoc
forall a. String -> a
panic "mergeOps.UNPACK: impossible position"

    -- clause [doc]:
    -- we do not expect to encounter any docs
    go _ _ _ ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElDocPrev _)):_) =
      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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x :: SrcSpanLess a
x) : xs :: [a]
xs)
      | Just (_, str :: 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 _ (TyElOpd _)):_) = Bool
False
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElOpr _)):_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElKindApp _ _)):_) = Bool
False
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SrcSpanLess a
TyElTilde)):_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SrcSpanLess a
TyElBang)):_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElUnpackedness _)):_) = Bool
True
            guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElDocPrev _)):xs' :: [a]
xs') = [a] -> Bool
guess [a]
xs'
            guess _ = String -> Bool
forall a. String -> a
panic "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
> 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
> 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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpr op)):xs :: [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
+ 1) [] (\c :: 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 _ (TyElOpd _)) = Bool
True
        isTyElOpd _ = Bool
False

    -- clause [opr.1]: interpret 'TyElTilde' as an operator
    go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l TyElTilde):xs :: [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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l TyElBang):xs :: [a]
xs) =
      let op :: RdrName
op = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
tcClsName (String -> FastString
fsLit "!")
      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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd a)):xs :: [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)
HsType 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 k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElKindApp l a)):xs :: [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 _ acc :: [LHsTypeArg GhcPs]
acc ops_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 _ _ _ _ = String -> P (LHsType GhcPs)
forall a. String -> a
panic "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 "mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg _ (L loc :: SrcSpan
loc ki :: HsType GhcPs
ki):_)
  = (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc, String -> SDoc
text "Unexpected type application:" SDoc -> SDoc -> SDoc
<+> HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcPs
ki)
mergeOpsAcc (HsValArg ty :: LHsType GhcPs
ty : xs :: [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 lhs :: LHsType GhcPs
lhs []     = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. b -> Either a b
Right LHsType GhcPs
lhs
    go1 lhs :: LHsType GhcPs
lhs (x :: LHsTypeArg GhcPs
x:xs :: [LHsTypeArg GhcPs]
xs) = case LHsTypeArg GhcPs
x of
        HsValArg ty :: 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 loc :: SrcSpan
loc ki :: 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 _ -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [LHsTypeArg GhcPs]
xs
mergeOpsAcc (HsArgPar _: xs :: [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 l :: SrcSpan
l (TyElOpd t)):xs :: [Located TyEl]
xs)
  | (True, t' :: LHsType GhcPs
t', addAnns :: P ()
addAnns, xs' :: [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)
HsType 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 (el :: Located TyEl
el:xs1 :: [Located TyEl]
xs1)
  | Just t1 :: LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
  = [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1] [Located TyEl]
xs1
   where
     go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
        -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
     go :: [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go acc :: [LHsTypeArg GhcPs]
acc (el :: Located TyEl
el:xs :: [Located TyEl]
xs)
       | Just t :: LHsTypeArg GhcPs
t <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
       = [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go (LHsTypeArg GhcPs
tLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [Located TyEl]
xs
     go acc :: [LHsTypeArg GhcPs]
acc xs :: [Located TyEl]
xs = case [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc of
       Left _ -> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
       Right acc' :: LHsType GhcPs
acc' -> (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
acc', () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
pInfixSide _ = Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing

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

pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev = Maybe LHsDocString
-> [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
forall a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ TyEl,
 SrcSpanLess a ~ HsDocString) =>
Maybe a -> [a] -> (Maybe a, [a])
go Maybe LHsDocString
forall a. Maybe a
Nothing
  where
    go :: Maybe a -> [a] -> (Maybe a, [a])
go mTrailingDoc :: Maybe a
mTrailingDoc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElDocPrev doc)):xs :: [a]
xs) =
      Maybe a -> [a] -> (Maybe a, [a])
go (Maybe a
mTrailingDoc Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> Maybe a
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
HsDocString
doc)) [a]
xs
    go mTrailingDoc :: Maybe a
mTrailingDoc xs :: [a]
xs = (Maybe a
mTrailingDoc, [a]
xs)

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

{- Note [isFunLhs vs mergeDataCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When parsing a function LHS, we do not know whether to treat (!) as
a strictness annotation or an infix operator:

  f ! a = ...

Without -XBangPatterns, this parses as   (!) f a = ...
   with -XBangPatterns, this parses as   f (!a) = ...

So in function declarations we opted to always parse as if -XBangPatterns
were off, and then rejig in 'isFunLhs'.

There are two downsides to this approach:

1. It is not particularly elegant, as there's a point in our pipeline where
   the representation is awfully incorrect. For instance,
      f !a b !c = ...
   will be first parsed as
      (f ! a b) ! c = ...

2. There are cases that it fails to cover, for instance infix declarations:
      !a + !b = ...
   will trigger an error.

Unfortunately, we cannot define different productions in the 'happy' grammar
depending on whether -XBangPatterns are enabled.

When parsing data constructors, we face a similar issue:
  (a) data T1 = C ! D
  (b) data T2 = C ! D => ...

In (a) the first bang is a strictness annotation, but in (b) it is a type
operator. A 'happy'-based parser does not have unlimited lookahead to check for
=>, so we must first parse (C ! D) into a common representation.

If we tried to mirror the approach used in functions, we would parse both sides
of => as types, and then rejig. However, we take a different route and use an
intermediate data structure, a reversed list of 'TyEl'.
See Note [Parsing data constructors is hard] for details.

This approach does not suffer from the issues of 'isFunLhs':

1. A sequence of 'TyEl' is a dedicated intermediate representation, not an
   incorrectly parsed type. Therefore, we do not have confusing states in our
   pipeline. (Except for representing data constructors as type variables).

2. We can handle infix data constructors with strictness annotations:
    data T a b = !a :+ !b

-}


-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
--   into a data constructor.
--
-- User input: @C !A B -- ^ doc@
-- Input to 'mergeDataCon': ["doc", B, !, A, C]
-- Output: (C, PrefixCon [!A, B], "doc")
--
-- See Note [Parsing data constructors is hard]
-- See Note [isFunLhs vs mergeDataCon]
mergeDataCon
      :: [Located TyEl]
      -> P ( Located RdrName         -- constructor name
           , HsConDeclDetails GhcPs  -- constructor field information
           , Maybe LHsDocString      -- docstring to go on the constructor
           )
mergeDataCon :: [Located TyEl]
-> P (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
mergeDataCon all_xs :: [Located TyEl]
all_xs =
  do { (addAnns :: P ()
addAnns, a :: (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
a) <- Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> P (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
res
     ; P ()
addAnns
     ; (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
-> P (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
a }
  where
    -- We start by splitting off the trailing documentation comment,
    -- if any exists.
    (mTrailingDoc :: Maybe LHsDocString
mTrailingDoc, all_xs' :: [Located TyEl]
all_xs') = [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev [Located TyEl]
all_xs

    -- Determine whether the trailing documentation comment exists and is the
    -- only docstring in this constructor declaration.
    --
    -- When true, it means that it applies to the constructor itself:
    --    data T = C
    --             A
    --             B -- ^ Comment on C (singleDoc == True)
    --
    -- When false, it means that it applies to the last field:
    --    data T = C -- ^ Comment on C
    --             A -- ^ Comment on A
    --             B -- ^ Comment on B (singleDoc == False)
    singleDoc :: Bool
singleDoc = Maybe LHsDocString -> Bool
forall a. Maybe a -> Bool
isJust Maybe LHsDocString
mTrailingDoc Bool -> Bool -> Bool
&&
                [()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ () | (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElDocPrev _)) <- [Located TyEl]
all_xs' ]

    -- The result of merging the list of reversed TyEl into a
    -- data constructor, along with [AddAnn].
    res :: Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
res = [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goFirst [Located TyEl]
all_xs'

    -- Take the trailing docstring into account when interpreting
    -- the docstring near the constructor.
    --
    --    data T = C -- ^ docstring right after C
    --             A
    --             B -- ^ trailing docstring
    --
    -- 'mkConDoc' must be applied to the docstring right after C, so that it
    -- falls back to the trailing docstring when appropriate (see singleDoc).
    mkConDoc :: Maybe LHsDocString -> Maybe LHsDocString
mkConDoc mDoc :: Maybe LHsDocString
mDoc | Bool
singleDoc = Maybe LHsDocString
mDoc Maybe LHsDocString -> Maybe LHsDocString -> Maybe LHsDocString
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LHsDocString
mTrailingDoc
                  | Bool
otherwise = Maybe LHsDocString
mDoc

    -- The docstring for the last field of a data constructor.
    trailingFieldDoc :: Maybe LHsDocString
trailingFieldDoc | Bool
singleDoc = Maybe LHsDocString
forall a. Maybe a
Nothing
                     | Bool
otherwise = Maybe LHsDocString
mTrailingDoc

    goFirst :: [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goFirst [ Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
tc
           ; (P (),
 (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, [LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [], Maybe LHsDocString
mTrailingDoc)) }
    goFirst ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd (HsRecTy _ fields))):xs :: [Located TyEl]
xs)
      | (mConDoc :: Maybe LHsDocString
mConDoc, xs' :: [Located TyEl]
xs') <- [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev [Located TyEl]
xs
      , [ Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l' :: SrcSpan
l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- [Located TyEl]
xs'
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l' SrcSpanLess (Located RdrName)
RdrName
tc
           ; let mDoc :: Maybe LHsDocString
mDoc = Maybe LHsDocString
mTrailingDoc Maybe LHsDocString -> Maybe LHsDocString -> Maybe LHsDocString
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LHsDocString
mConDoc
           ; (P (),
 (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> SrcSpanLess (Located [LConDeclField GhcPs])
-> Located [LConDeclField GhcPs]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [LConDeclField GhcPs]
SrcSpanLess (Located [LConDeclField GhcPs])
fields), Maybe LHsDocString
mDoc)) }
    goFirst [Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
      = (P (),
 (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return ( () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
               , ( SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts)))
                 , [LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcPs]
ts
                 , Maybe LHsDocString
mTrailingDoc ) )
    goFirst ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd t)):xs :: [Located TyEl]
xs)
      | (_, t' :: LHsType GhcPs
t', addAnns :: P ()
addAnns, xs' :: [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)
HsType GhcPs
t) [Located TyEl]
xs
      = P ()
-> Maybe LHsDocString
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
go P ()
addAnns Maybe LHsDocString
forall a. Maybe a
Nothing [LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe LHsType GhcPs
t' Maybe LHsDocString
trailingFieldDoc] [Located TyEl]
xs'
    goFirst (L l :: SrcSpan
l (TyElKindApp _ _):_)
      = Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goInfix Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a. Semigroup a => a -> a -> a
Monoid.<> (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a b. a -> Either a b
Left (SrcSpan
l, SDoc
kindAppErr)
    goFirst xs :: [Located TyEl]
xs
      = P ()
-> Maybe LHsDocString
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
go (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe LHsDocString
mTrailingDoc [] [Located TyEl]
xs

    go :: P ()
-> Maybe LHsDocString
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
go addAnns :: P ()
addAnns mLastDoc :: Maybe LHsDocString
mLastDoc ts :: [LHsType GhcPs]
ts [ Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
      = do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
tc
           ; (P (),
 (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (P ()
addAnns, (Located RdrName
data_con, [LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcPs]
ts, Maybe LHsDocString -> Maybe LHsDocString
mkConDoc Maybe LHsDocString
mLastDoc)) }
    go addAnns :: P ()
addAnns mLastDoc :: Maybe LHsDocString
mLastDoc ts :: [LHsType GhcPs]
ts ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElDocPrev doc)):xs :: [Located TyEl]
xs) =
      P ()
-> Maybe LHsDocString
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
go P ()
addAnns (Maybe LHsDocString
mLastDoc Maybe LHsDocString -> Maybe LHsDocString -> Maybe LHsDocString
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` LHsDocString -> Maybe LHsDocString
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess LHsDocString
HsDocString
doc)) [LHsType GhcPs]
ts [Located TyEl]
xs
    go addAnns :: P ()
addAnns mLastDoc :: Maybe LHsDocString
mLastDoc ts :: [LHsType GhcPs]
ts ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd t)):xs :: [Located TyEl]
xs)
      | (_, t' :: LHsType GhcPs
t', addAnns' :: P ()
addAnns', xs' :: [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)
HsType GhcPs
t) [Located TyEl]
xs
      , LHsType GhcPs
t'' <- LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe LHsType GhcPs
t' Maybe LHsDocString
mLastDoc
      = P ()
-> Maybe LHsDocString
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
go (P ()
addAnns P () -> P () -> P ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P ()
addAnns') Maybe LHsDocString
forall a. Maybe a
Nothing (LHsType GhcPs
t''LHsType GhcPs -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. a -> [a] -> [a]
:[LHsType GhcPs]
ts) [Located TyEl]
xs'
    go _ _ _ ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElOpr _)):_) =
      -- Encountered an operator: backtrack to the beginning and attempt
      -- to parse as an infix definition.
      Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goInfix
    go _ _ _ (L l :: SrcSpan
l (TyElKindApp _ _):_) =  Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goInfix Either
  (SrcSpan, SDoc)
  (P (),
   (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a. Semigroup a => a -> a -> a
Monoid.<> (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a b. a -> Either a b
Left (SrcSpan
l, SDoc
kindAppErr)
    go _ _ _ _ = (SrcSpan, SDoc)
-> Either
     (SrcSpan, SDoc)
     (P (),
      (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
malformedErr
      where
        malformedErr :: (SrcSpan, SDoc)
malformedErr =
          ( (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
noSrcSpan ((Located TyEl -> SrcSpan) -> [Located TyEl] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc [Located TyEl]
all_xs')
          , String -> SDoc
text "Cannot parse data constructor" SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text "in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
            Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs'))

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

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

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

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

-- -------------------------------------------------------------------------
-- Checking arrow syntax.

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

checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand lc :: LHsExpr GhcPs
lc = (SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs))
-> LHsExpr GhcPs -> P (LHsCmd GhcPs)
forall a b. (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
checkCmd LHsExpr GhcPs
lc

locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap f :: SrcSpan -> a -> P b
f (Located a -> Located (SrcSpanLess (Located a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l a :: SrcSpanLess (Located a)
a) = SrcSpan -> a -> P b
f SrcSpan
l a
SrcSpanLess (Located a)
a P b -> (b -> P (Located b)) -> P (Located b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\b :: b
b -> Located b -> P (Located b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located b -> P (Located b)) -> Located b -> P (Located b)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (Located b) -> Located b
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l b
SrcSpanLess (Located b)
b)

checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
checkCmd _ (HsArrApp _ e1 :: LHsExpr GhcPs
e1 e2 :: LHsExpr GhcPs
e2 haat :: HsArrAppType
haat b :: Bool
b) =
    HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdArrApp GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> HsArrAppType
-> Bool
-> HsCmd GhcPs
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp XCmdArrApp GhcPs
NoExt
noExt LHsExpr GhcPs
e1 LHsExpr GhcPs
e2 HsArrAppType
haat Bool
b
checkCmd _ (HsArrForm _ e :: LHsExpr GhcPs
e mf :: Maybe Fixity
mf args :: [LHsCmdTop GhcPs]
args) =
    HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdArrForm GhcPs
-> LHsExpr GhcPs
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcPs]
-> HsCmd GhcPs
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcPs
NoExt
noExt LHsExpr GhcPs
e LexicalFixity
Prefix Maybe Fixity
mf [LHsCmdTop GhcPs]
args
checkCmd _ (HsApp _ e1 :: LHsExpr GhcPs
e1 e2 :: LHsExpr GhcPs
e2) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e1 P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (HsCmd GhcPs)) -> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdApp GhcPs -> LHsCmd GhcPs -> LHsExpr GhcPs -> HsCmd GhcPs
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcPs
NoExt
noExt LHsCmd GhcPs
c LHsExpr GhcPs
e2)
checkCmd _ (HsLam _ mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg) =
    MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup MatchGroup GhcPs (LHsExpr GhcPs)
mg P (MatchGroup GhcPs (LHsCmd GhcPs))
-> (MatchGroup GhcPs (LHsCmd GhcPs) -> P (HsCmd GhcPs))
-> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\mg' :: MatchGroup GhcPs (LHsCmd GhcPs)
mg' -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdLam GhcPs -> MatchGroup GhcPs (LHsCmd GhcPs) -> HsCmd GhcPs
forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcPs
NoExt
noExt MatchGroup GhcPs (LHsCmd GhcPs)
mg')
checkCmd _ (HsPar _ e :: LHsExpr GhcPs
e) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (HsCmd GhcPs)) -> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdPar GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcPs
NoExt
noExt LHsCmd GhcPs
c)
checkCmd _ (HsCase _ e :: LHsExpr GhcPs
e mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg) =
    MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup MatchGroup GhcPs (LHsExpr GhcPs)
mg P (MatchGroup GhcPs (LHsCmd GhcPs))
-> (MatchGroup GhcPs (LHsCmd GhcPs) -> P (HsCmd GhcPs))
-> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\mg' :: MatchGroup GhcPs (LHsCmd GhcPs)
mg' -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdCase GhcPs
-> LHsExpr GhcPs -> MatchGroup GhcPs (LHsCmd GhcPs) -> HsCmd GhcPs
forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcPs
NoExt
noExt LHsExpr GhcPs
e MatchGroup GhcPs (LHsCmd GhcPs)
mg')
checkCmd _ (HsIf _ cf :: Maybe (SyntaxExpr GhcPs)
cf ep :: LHsExpr GhcPs
ep et :: LHsExpr GhcPs
et ee :: LHsExpr GhcPs
ee) = do
    LHsCmd GhcPs
pt <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
et
    LHsCmd GhcPs
pe <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
ee
    HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdIf GhcPs
-> Maybe (SyntaxExpr GhcPs)
-> LHsExpr GhcPs
-> LHsCmd GhcPs
-> LHsCmd GhcPs
-> HsCmd GhcPs
forall id.
XCmdIf id
-> Maybe (SyntaxExpr id)
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcPs
NoExt
noExt Maybe (SyntaxExpr GhcPs)
cf LHsExpr GhcPs
ep LHsCmd GhcPs
pt LHsCmd GhcPs
pe
checkCmd _ (HsLet _ lb :: LHsLocalBinds GhcPs
lb e :: LHsExpr GhcPs
e) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (HsCmd GhcPs)) -> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdLet GhcPs -> LHsLocalBinds GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcPs
NoExt
noExt LHsLocalBinds GhcPs
lb LHsCmd GhcPs
c)
checkCmd _ (HsDo _ DoExpr (Located [ExprLStmt GhcPs]
-> Located (SrcSpanLess (Located [ExprLStmt GhcPs]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l stmts :: SrcSpanLess (Located [ExprLStmt GhcPs])
stmts)) =
    (ExprLStmt GhcPs -> P (CmdLStmt GhcPs))
-> [ExprLStmt GhcPs] -> P [CmdLStmt GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt [ExprLStmt GhcPs]
SrcSpanLess (Located [ExprLStmt GhcPs])
stmts P [CmdLStmt GhcPs]
-> ([CmdLStmt GhcPs] -> P (HsCmd GhcPs)) -> P (HsCmd GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (\ss :: [CmdLStmt GhcPs]
ss -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdDo GhcPs -> Located [CmdLStmt GhcPs] -> HsCmd GhcPs
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo XCmdDo GhcPs
NoExt
noExt (SrcSpan
-> SrcSpanLess (Located [CmdLStmt GhcPs])
-> Located [CmdLStmt GhcPs]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [CmdLStmt GhcPs]
SrcSpanLess (Located [CmdLStmt GhcPs])
ss) )

checkCmd _ (OpApp _ eLeft :: LHsExpr GhcPs
eLeft op :: LHsExpr GhcPs
op eRight :: LHsExpr GhcPs
eRight) = do
    -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
    LHsCmd GhcPs
c1 <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
eLeft
    LHsCmd GhcPs
c2 <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
eRight
    let arg1 :: LHsCmdTop GhcPs
arg1 = SrcSpan -> SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LHsCmd GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsCmd GhcPs
c1) (SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs)
-> SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs
forall a b. (a -> b) -> a -> b
$ XCmdTop GhcPs -> LHsCmd GhcPs -> HsCmdTop GhcPs
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop XCmdTop GhcPs
NoExt
noExt LHsCmd GhcPs
c1
        arg2 :: LHsCmdTop GhcPs
arg2 = SrcSpan -> SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LHsCmd GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsCmd GhcPs
c2) (SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs)
-> SrcSpanLess (LHsCmdTop GhcPs) -> LHsCmdTop GhcPs
forall a b. (a -> b) -> a -> b
$ XCmdTop GhcPs -> LHsCmd GhcPs -> HsCmdTop GhcPs
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop XCmdTop GhcPs
NoExt
noExt LHsCmd GhcPs
c2
    HsCmd GhcPs -> P (HsCmd GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcPs -> P (HsCmd GhcPs)) -> HsCmd GhcPs -> P (HsCmd GhcPs)
forall a b. (a -> b) -> a -> b
$ XCmdArrForm GhcPs
-> LHsExpr GhcPs
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcPs]
-> HsCmd GhcPs
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcPs
NoExt
noExt LHsExpr GhcPs
op LexicalFixity
Infix Maybe Fixity
forall a. Maybe a
Nothing [LHsCmdTop GhcPs
arg1, LHsCmdTop GhcPs
arg2]

checkCmd l :: SrcSpan
l e :: HsExpr GhcPs
e = SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
forall a. SrcSpan -> HsExpr GhcPs -> P a
cmdFail SrcSpan
l HsExpr GhcPs
e

checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt = (SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs))
-> ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
forall a b. (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
checkCmdStmt

checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
checkCmdStmt _ (LastStmt x :: XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
x e :: LHsExpr GhcPs
e s :: Bool
s r :: SyntaxExpr GhcPs
r) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (CmdStmt GhcPs)) -> P (CmdStmt GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdStmt GhcPs -> P (CmdStmt GhcPs))
-> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall a b. (a -> b) -> a -> b
$ XLastStmt GhcPs GhcPs (LHsCmd GhcPs)
-> LHsCmd GhcPs -> Bool -> SyntaxExpr GhcPs -> CmdStmt GhcPs
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcPs GhcPs (LHsCmd GhcPs)
XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsCmd GhcPs
c Bool
s SyntaxExpr GhcPs
r)
checkCmdStmt _ (BindStmt x :: XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
x pat :: LPat GhcPs
pat e :: LHsExpr GhcPs
e b :: SyntaxExpr GhcPs
b f :: SyntaxExpr GhcPs
f) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (CmdStmt GhcPs)) -> P (CmdStmt GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdStmt GhcPs -> P (CmdStmt GhcPs))
-> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcPs GhcPs (LHsCmd GhcPs)
-> LPat GhcPs
-> LHsCmd GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> CmdStmt GhcPs
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcPs GhcPs (LHsCmd GhcPs)
XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
x LPat GhcPs
pat LHsCmd GhcPs
c SyntaxExpr GhcPs
b SyntaxExpr GhcPs
f)
checkCmdStmt _ (BodyStmt x :: XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
x e :: LHsExpr GhcPs
e t :: SyntaxExpr GhcPs
t g :: SyntaxExpr GhcPs
g) =
    LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e P (LHsCmd GhcPs)
-> (LHsCmd GhcPs -> P (CmdStmt GhcPs)) -> P (CmdStmt GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\c :: LHsCmd GhcPs
c -> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdStmt GhcPs -> P (CmdStmt GhcPs))
-> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsCmd GhcPs)
-> LHsCmd GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> CmdStmt GhcPs
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcPs GhcPs (LHsCmd GhcPs)
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsCmd GhcPs
c SyntaxExpr GhcPs
t SyntaxExpr GhcPs
g)
checkCmdStmt _ (LetStmt x :: XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
x bnds :: LHsLocalBinds GhcPs
bnds) = CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdStmt GhcPs -> P (CmdStmt GhcPs))
-> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall a b. (a -> b) -> a -> b
$ XLetStmt GhcPs GhcPs (LHsCmd GhcPs)
-> LHsLocalBinds GhcPs -> CmdStmt GhcPs
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs (LHsCmd GhcPs)
XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsLocalBinds GhcPs
bnds
checkCmdStmt _ stmt :: ExprStmt GhcPs
stmt@(RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [ExprLStmt GhcPs]
stmts }) = do
    [CmdLStmt GhcPs]
ss <- (ExprLStmt GhcPs -> P (CmdLStmt GhcPs))
-> [ExprLStmt GhcPs] -> P [CmdLStmt GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt [ExprLStmt GhcPs]
stmts
    CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdStmt GhcPs -> P (CmdStmt GhcPs))
-> CmdStmt GhcPs -> P (CmdStmt GhcPs)
forall a b. (a -> b) -> a -> b
$ ExprStmt GhcPs
stmt { recS_ext :: XRecStmt GhcPs GhcPs (LHsCmd GhcPs)
recS_ext = XRecStmt GhcPs GhcPs (LHsCmd GhcPs)
NoExt
noExt, recS_stmts :: [CmdLStmt GhcPs]
recS_stmts = [CmdLStmt GhcPs]
ss }
checkCmdStmt _ (XStmtLR _) = String -> P (CmdStmt GhcPs)
forall a. String -> a
panic "checkCmdStmt"
checkCmdStmt l :: SrcSpan
l stmt :: ExprStmt GhcPs
stmt = SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
forall a. SrcSpan -> ExprStmt GhcPs -> P a
cmdStmtFail SrcSpan
l ExprStmt GhcPs
stmt

checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
                   -> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Located (SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l ms :: SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
ms) }) = do
    [Located (Match GhcPs (LHsCmd GhcPs))]
ms' <- (LMatch GhcPs (LHsExpr GhcPs)
 -> P (Located (Match GhcPs (LHsCmd GhcPs))))
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> P [Located (Match GhcPs (LHsCmd GhcPs))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpan
 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs)
-> P (Located (Match GhcPs (LHsCmd GhcPs)))
forall a b. (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap ((SrcSpan
  -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs)))
 -> LMatch GhcPs (LHsExpr GhcPs)
 -> P (Located (Match GhcPs (LHsCmd GhcPs))))
-> (SrcSpan
    -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs)
-> P (Located (Match GhcPs (LHsCmd GhcPs)))
forall a b. (a -> b) -> a -> b
$ (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs)))
-> SrcSpan
-> Match GhcPs (LHsExpr GhcPs)
-> P (Match GhcPs (LHsCmd GhcPs))
forall a b. a -> b -> a
const Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs))
convert) [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
ms
    MatchGroup GhcPs (LHsCmd GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (LHsCmd GhcPs)
 -> P (MatchGroup GhcPs (LHsCmd GhcPs)))
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs)
mg { mg_ext :: XMG GhcPs (LHsCmd GhcPs)
mg_ext = XMG GhcPs (LHsCmd GhcPs)
NoExt
noExt
                , mg_alts :: Located [Located (Match GhcPs (LHsCmd GhcPs))]
mg_alts = SrcSpan
-> SrcSpanLess (Located [Located (Match GhcPs (LHsCmd GhcPs))])
-> Located [Located (Match GhcPs (LHsCmd GhcPs))]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [Located (Match GhcPs (LHsCmd GhcPs))]
SrcSpanLess (Located [Located (Match GhcPs (LHsCmd GhcPs))])
ms' }
    where convert :: Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsCmd GhcPs))
convert match :: Match GhcPs (LHsExpr GhcPs)
match@(Match { m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss }) = do
            GRHSs GhcPs (LHsCmd GhcPs)
grhss' <- GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs GRHSs GhcPs (LHsExpr GhcPs)
grhss
            Match GhcPs (LHsCmd GhcPs) -> P (Match GhcPs (LHsCmd GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsCmd GhcPs) -> P (Match GhcPs (LHsCmd GhcPs)))
-> Match GhcPs (LHsCmd GhcPs) -> P (Match GhcPs (LHsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs)
match { m_ext :: XCMatch GhcPs (LHsCmd GhcPs)
m_ext = XCMatch GhcPs (LHsCmd GhcPs)
NoExt
noExt, m_grhss :: GRHSs GhcPs (LHsCmd GhcPs)
m_grhss = GRHSs GhcPs (LHsCmd GhcPs)
grhss'}
          convert (XMatch _) = String -> P (Match GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic "checkCmdMatchGroup.XMatch"
checkCmdMatchGroup (XMatchGroup {}) = String -> P (MatchGroup GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic "checkCmdMatchGroup"

checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs (GRHSs x :: XCGRHSs GhcPs (LHsExpr GhcPs)
x grhss :: [LGRHS GhcPs (LHsExpr GhcPs)]
grhss binds :: LHsLocalBinds GhcPs
binds) = do
    [LGRHS GhcPs (LHsCmd GhcPs)]
grhss' <- (LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)))
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> P [LGRHS GhcPs (LHsCmd GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
checkCmdGRHS [LGRHS GhcPs (LHsExpr GhcPs)]
grhss
    GRHSs GhcPs (LHsCmd GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHSs GhcPs (LHsCmd GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs)))
-> GRHSs GhcPs (LHsCmd GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ XCGRHSs GhcPs (LHsCmd GhcPs)
-> [LGRHS GhcPs (LHsCmd GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsCmd GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (LHsCmd GhcPs)
XCGRHSs GhcPs (LHsExpr GhcPs)
x [LGRHS GhcPs (LHsCmd GhcPs)]
grhss' LHsLocalBinds GhcPs
binds
checkCmdGRHSs (XGRHSs _) = String -> P (GRHSs GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic "checkCmdGRHSs"

checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
checkCmdGRHS = (SrcSpan
 -> GRHS GhcPs (LHsExpr GhcPs) -> P (GRHS GhcPs (LHsCmd GhcPs)))
-> LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
forall a b. (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap ((SrcSpan
  -> GRHS GhcPs (LHsExpr GhcPs) -> P (GRHS GhcPs (LHsCmd GhcPs)))
 -> LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)))
-> (SrcSpan
    -> GRHS GhcPs (LHsExpr GhcPs) -> P (GRHS GhcPs (LHsCmd GhcPs)))
-> LGRHS GhcPs (LHsExpr GhcPs)
-> P (LGRHS GhcPs (LHsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ (GRHS GhcPs (LHsExpr GhcPs) -> P (GRHS GhcPs (LHsCmd GhcPs)))
-> SrcSpan
-> GRHS GhcPs (LHsExpr GhcPs)
-> P (GRHS GhcPs (LHsCmd GhcPs))
forall a b. a -> b -> a
const GRHS GhcPs (LHsExpr GhcPs) -> P (GRHS GhcPs (LHsCmd GhcPs))
forall p.
(XCGRHS p (LHsExpr GhcPs) ~ XCGRHS p (LHsCmd GhcPs)) =>
GRHS p (LHsExpr GhcPs) -> P (GRHS p (LHsCmd GhcPs))
convert
  where
    convert :: GRHS p (LHsExpr GhcPs) -> P (GRHS p (LHsCmd GhcPs))
convert (GRHS x :: XCGRHS p (LHsExpr GhcPs)
x stmts :: [GuardLStmt p]
stmts e :: LHsExpr GhcPs
e) = do
        LHsCmd GhcPs
c <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e
--        cmdStmts <- mapM checkCmdLStmt stmts
        GRHS p (LHsCmd GhcPs) -> P (GRHS p (LHsCmd GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GRHS p (LHsCmd GhcPs) -> P (GRHS p (LHsCmd GhcPs)))
-> GRHS p (LHsCmd GhcPs) -> P (GRHS p (LHsCmd GhcPs))
forall a b. (a -> b) -> a -> b
$ XCGRHS p (LHsCmd GhcPs)
-> [GuardLStmt p] -> LHsCmd GhcPs -> GRHS p (LHsCmd GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS p (LHsCmd GhcPs)
XCGRHS p (LHsExpr GhcPs)
x {- cmdStmts -} [GuardLStmt p]
stmts LHsCmd GhcPs
c
    convert (XGRHS _) = String -> P (GRHS p (LHsCmd GhcPs))
forall a. String -> a
panic "checkCmdGRHS"


cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
cmdFail loc :: SrcSpan
loc e :: HsExpr GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text "Parse error in command:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
cmdStmtFail :: SrcSpan -> ExprStmt GhcPs -> P a
cmdStmtFail loc :: SrcSpan
loc e :: ExprStmt GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc
                    (String -> SDoc
text "Parse error in command statement:" SDoc -> SDoc -> SDoc
<+> ExprStmt GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprStmt GhcPs
e)

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

-- | Check if a fixity is valid. We support bypassing the usual bound checks
-- for some special operators.
checkPrecP
        :: Located (SourceText,Int)             -- ^ precedence
        -> Located (OrdList (Located RdrName))  -- ^ operators
        -> P ()
checkPrecP :: Located (SourceText, Int)
-> Located (OrdList (Located RdrName)) -> P ()
checkPrecP (Located (SourceText, Int)
-> Located (SrcSpanLess (Located (SourceText, Int)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (_,i)) (Located (OrdList (Located RdrName))
-> Located (SrcSpanLess (Located (OrdList (Located RdrName))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ ol :: SrcSpanLess (Located (OrdList (Located RdrName)))
ol)
 | 0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPrecedence = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 | (Located RdrName -> Bool) -> OrdList (Located RdrName) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Located RdrName -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ RdrName) => a -> Bool
specialOp OrdList (Located RdrName)
SrcSpanLess (Located (OrdList (Located RdrName)))
ol = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 | Bool
otherwise = SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text ("Precedence out of range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i))
  where
    specialOp :: a -> Bool
specialOp op :: a
op = a -> SrcSpanLess a
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc a
op RdrName -> [RdrName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ RdrName
eqTyCon_RDR
                                   , TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
funTyCon ]

mkRecConstrOrUpdate
        :: LHsExpr GhcPs
        -> SrcSpan
        -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
        -> P (HsExpr GhcPs)

mkRecConstrOrUpdate :: LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
-> P (HsExpr GhcPs)
mkRecConstrOrUpdate (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsVar _ (dL->L _ c))) _ (fs :: [LHsRecField GhcPs (LHsExpr GhcPs)]
fs,dd :: Bool
dd)
  | RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c
  = HsExpr GhcPs -> P (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
-> HsRecFields GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
mkRdrRecordCon (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
c) ([LHsRecField GhcPs (LHsExpr GhcPs)]
-> Bool -> HsRecFields GhcPs (LHsExpr GhcPs)
forall id arg. [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields [LHsRecField GhcPs (LHsExpr GhcPs)]
fs Bool
dd))
mkRecConstrOrUpdate exp :: LHsExpr GhcPs
exp@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l _) _ (fs :: [LHsRecField GhcPs (LHsExpr GhcPs)]
fs,dd :: Bool
dd)
  | Bool
dd        = SrcSpan -> SDoc -> P (HsExpr GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text "You cannot use `..' in a record update")
  | Bool
otherwise = HsExpr GhcPs -> P (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd LHsExpr GhcPs
exp ((LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdField GhcPs)
-> [LHsRecField GhcPs (LHsExpr GhcPs)] -> [LHsRecUpdField GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map ((HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
 -> HsRecUpdField GhcPs)
-> LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdField GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field) [LHsRecField GhcPs (LHsExpr GhcPs)]
fs))

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

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

mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs :: [LHsRecField id arg]
fs False = HsRecFields :: forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField id arg]
rec_flds = [LHsRecField id arg]
fs, rec_dotdot :: Maybe Int
rec_dotdot = Maybe Int
forall a. Maybe a
Nothing }
mk_rec_fields fs :: [LHsRecField id arg]
fs True  = HsRecFields :: forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField id arg]
rec_flds = [LHsRecField id arg]
fs
                                     , rec_dotdot :: Maybe Int
rec_dotdot = Int -> Maybe Int
forall a. a -> Maybe a
Just ([LHsRecField id arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsRecField id arg]
fs) }

mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field :: HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field (HsRecField (Located (FieldOcc GhcPs)
-> Located (SrcSpanLess (Located (FieldOcc GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (FieldOcc _ rdr)) arg :: LHsExpr GhcPs
arg pun :: Bool
pun)
  = Located (AmbiguousFieldOcc GhcPs)
-> LHsExpr GhcPs -> Bool -> HsRecUpdField GhcPs
forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField (SrcSpan
-> AmbiguousFieldOcc GhcPs -> Located (AmbiguousFieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcPs -> Located RdrName -> AmbiguousFieldOcc GhcPs
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous XUnambiguous GhcPs
NoExt
noExt Located RdrName
rdr)) LHsExpr GhcPs
arg Bool
pun
mk_rec_upd_field (HsRecField (Located (FieldOcc GhcPs)
-> Located (SrcSpanLess (Located (FieldOcc GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XFieldOcc _)) _ _)
  = String -> HsRecUpdField GhcPs
forall a. String -> a
panic "mk_rec_upd_field"
mk_rec_upd_field (HsRecField _ _ _)
  = String -> HsRecUpdField GhcPs
forall a. String -> a
panic "mk_rec_upd_field: Impossible Match" -- due to #15884

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

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

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

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

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



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

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

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

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

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


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

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

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

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

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

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

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

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

    wrapped :: [Located ImpExpQcSpec] -> [LIEWrappedName RdrName]
wrapped = (Located ImpExpQcSpec -> LIEWrappedName RdrName)
-> [Located ImpExpQcSpec] -> [LIEWrappedName RdrName]
forall a b. (a -> b) -> [a] -> [b]
map ((SrcSpanLess (Located ImpExpQcSpec)
 -> SrcSpanLess (LIEWrappedName RdrName))
-> Located ImpExpQcSpec -> LIEWrappedName RdrName
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> SrcSpanLess b) -> a -> b
onHasSrcSpan SrcSpanLess (Located ImpExpQcSpec)
-> SrcSpanLess (LIEWrappedName RdrName)
ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec)

mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
             -> P (Located RdrName)
mkTypeImpExp :: Located RdrName -> P (Located RdrName)
mkTypeImpExp name :: Located RdrName
name =
  do Bool
allowed <- ExtBits -> P Bool
getBit ExtBits
ExplicitNamespacesBit
     if Bool
allowed
       then Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RdrName -> NameSpace -> RdrName
`setRdrNameSpace` NameSpace
tcClsName) Located RdrName
name)
       else SrcSpan -> SDoc -> P (Located RdrName)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located RdrName
name)
              (String -> SDoc
text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")

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

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

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

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

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

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

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

failOpDocPrev :: SrcSpan -> P a
failOpDocPrev :: SrcSpan -> P a
failOpDocPrev loc :: SrcSpan
loc = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text "Unexpected documentation comment."

failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound (Located SrcStrictness
-> Located (SrcSpanLess (Located SrcStrictness))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ str :: SrcSpanLess (Located SrcStrictness)
str) (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ty :: SrcSpanLess (LHsType GhcPs)
ty) = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text "Strictness annotation applied to a compound type." SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text "Did you mean to add parentheses?" SDoc -> SDoc -> SDoc
$$
          Int -> SDoc -> SDoc
nest 2 (SrcStrictness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located SrcStrictness)
SrcStrictness
str SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ty))

failOpStrictnessPosition :: Located SrcStrictness -> P a
failOpStrictnessPosition :: Located SrcStrictness -> P a
failOpStrictnessPosition (Located SrcStrictness
-> Located (SrcSpanLess (Located SrcStrictness))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc _) = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
msg
  where
    msg :: SDoc
msg = String -> SDoc
text "Strictness annotation cannot appear in this position."

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

parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc span :: SrcSpan
span s :: SDoc
s = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
failSpanMsgP SrcSpan
span SDoc
s

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

data SumOrTuple
  = Sum ConTag Arity (LHsExpr GhcPs)
  | Tuple [LHsTupArg GhcPs]

mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)

-- Tuple
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
mkSumOrTuple boxity :: Boxity
boxity _ (Tuple es :: [LHsTupArg GhcPs]
es) = HsExpr GhcPs -> P (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
NoExt
noExt [LHsTupArg GhcPs]
es Boxity
boxity)

-- Sum
mkSumOrTuple Unboxed _ (Sum alt :: Int
alt arity :: Int
arity e :: LHsExpr GhcPs
e) =
    HsExpr GhcPs -> P (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitSum GhcPs -> Int -> Int -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcPs
NoExt
noExt Int
alt Int
arity LHsExpr GhcPs
e)
mkSumOrTuple Boxed l :: SrcSpan
l (Sum alt :: Int
alt arity :: Int
arity (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ e :: SrcSpanLess (LHsExpr GhcPs)
e)) =
    SrcSpan -> SDoc -> P (HsExpr GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Boxed sums not supported:") 2
                      (Int -> Int -> HsExpr GhcPs -> SDoc
ppr_boxed_sum Int
alt Int
arity SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e))
  where
    ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
    ppr_boxed_sum :: Int -> Int -> HsExpr GhcPs -> SDoc
ppr_boxed_sum alt :: Int
alt arity :: Int
arity e :: HsExpr GhcPs
e =
      String -> SDoc
text "(" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) SDoc -> SDoc -> SDoc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alt)
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text ")"

    ppr_bars :: Int -> SDoc
ppr_bars n :: Int
n = [SDoc] -> SDoc
hsep (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate Int
n (Char -> SDoc
Outputable.char '|'))

mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x :: LHsType GhcPs
x op :: Located RdrName
op y :: LHsType GhcPs
y =
  let loc :: SrcSpan
loc = LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
x SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located RdrName
op SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
y
  in SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (LHsType GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p)
-> Located (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy LHsType GhcPs
x Located RdrName
Located (IdP GhcPs)
op LHsType GhcPs
y)

mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy t :: LHsType GhcPs
t doc :: LHsDocString
doc =
  let loc :: SrcSpan
loc = LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
t SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` LHsDocString -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsDocString
doc
  in SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XDocTy GhcPs -> LHsType GhcPs -> LHsDocString -> HsType GhcPs
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy XDocTy GhcPs
NoExt
noExt LHsType GhcPs
t LHsDocString
doc)

mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t :: LHsType GhcPs
t = LHsType GhcPs
-> (LHsDocString -> LHsType GhcPs)
-> Maybe LHsDocString
-> LHsType GhcPs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LHsType GhcPs
t (LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy LHsType GhcPs
t)

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

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

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