{-# 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,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
filterCTuple,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
mkATDefault,
checkBlockArguments,
checkPrecP,
checkContext,
checkPattern,
bang_RDR,
isBangRdr,
checkPatterns,
checkMonadComp,
checkCommand,
checkValDef,
checkValSigLhs,
checkDoAndIfThenElse,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
parseErrorSDoc, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
forallSym,
starSym,
warnStarIsType,
failOpFewArgs,
SumOrTuple (..), mkSumOrTuple
) where
import GhcPrelude
import HsSyn
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 "GhclibHsVersions.h"
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (LTyClDecl (GhcPass p)
-> Located (SrcSpanLess (LTyClDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LTyClDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD (GhcPass p)
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 SrcSpan
loc SrcSpanLess (LInstDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD (GhcPass p)
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 SrcSpan
loc (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (mcxt, tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls
= do { (LHsBinds GhcPs
binds, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
ats, [LTyFamInstDecl GhcPs]
at_insts, [LDataFamInstDecl GhcPs]
_, [LDocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; (Located RdrName
cls, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars,[AddAnn]
annst) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text String
"class") SDoc
whereDots Located RdrName
cls [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
annst
; ([LTyFamDefltEqn GhcPs]
at_defs, [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 ())
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 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 { (LHsQTyVars GhcPs
tvs, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text String
"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 SrcSpan
_ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic String
"mkATDefault"
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyFamInstDecl (XHsImplicitBndrs _))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic String
"mkATDefault"
mkATDefault LTyFamInstDecl GhcPs
_ = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic String
"mkATDefault: Impossible Match"
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (mcxt, tycl_hdr))
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [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
; 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 NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
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
-> LHsType GhcPs
-> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text String
"type") SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; 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 Maybe [LHsTyVarBndr GhcPs]
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn GhcPs [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 SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Maybe (LHsContext GhcPs)
mcxt, Maybe [LHsTyVarBndr GhcPs]
bndrs, LHsType GhcPs
tycl_hdr)
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; (AddAnn -> P ()) -> [AddAnn] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\AddAnn
a -> AddAnn
a SrcSpan
loc) [AddAnn]
ann
; 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 SrcSpan
loc TyFamInstEqn GhcPs
eqn
= LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcPs
NoExt
noExt (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info LHsType GhcPs
lhs Located (FamilyResultSig GhcPs)
ksig Maybe (LInjectivityAnn GhcPs)
injAnn
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [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
; 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
FamilyInfo GhcPs
DataFamily -> SDoc
empty
FamilyInfo GhcPs
OpenTypeFamily -> SDoc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcPs)
expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
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
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc Located RdrName
tycon [Located (Maybe FastString)]
roles
= do { [Located (Maybe Role)]
roles' <- (Located (Maybe FastString) -> P (Located (Maybe Role)))
-> [Located (Maybe FastString)] -> P [Located (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs))
-> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs)
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [Located (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcPs
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 SrcSpan
loc_role SrcSpanLess (Located (Maybe FastString))
Nothing) = Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role SrcSpanLess (Located (Maybe Role))
forall a. Maybe a
Nothing
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc_role (Just role))
= case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
Just Role
found_role -> Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role (SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role))
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
Maybe Role
Nothing ->
let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
SrcSpan -> SDoc -> P (Located (Maybe Role))
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc_role
(String -> SDoc
text String
"Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
[Role] -> SDoc
forall a. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)
parse_role Located (Maybe FastString)
_ = String -> P (Located (Maybe Role))
forall a. String -> a
panic String
"parse_role: Impossible Match"
suggestions :: [a] -> SDoc
suggestions [] = SDoc
empty
suggestions [a
r] = String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r)
suggestions [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Perhaps you meant one of these:")
Int
2 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [a]
list)
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ValD x b)) : [LHsDecl GhcPs]
ds)
= SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
x SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds'
where (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l' SrcSpanLess (LHsBind GhcPs)
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup OrdList (LHsDecl GhcPs)
binding
= do { (LHsBinds GhcPs
mbs, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
fam_ds, [LTyFamInstDecl GhcPs]
tfam_insts
, [LDataFamInstDecl GhcPs]
dfam_insts, [LDocDecl]
_) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBinds GhcPs -> P (HsValBinds GhcPs))
-> HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBinds GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExt
noExt LHsBinds GhcPs
mbs [LSig GhcPs]
sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
fb = [LHsDecl GhcPs]
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall 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 SrcSpan
l (ValD _ b)) : [LHsDecl GhcPs]
ds)
= do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [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
(LHsBind GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsDecl GhcPs)
decl) : [LHsDecl GhcPs]
ds)
= do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) <- [LHsDecl GhcPs] -> 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 String
"Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"at the top level:")
Int
2 (SpliceDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl GhcPs
d)
SrcSpanLess (LHsDecl GhcPs)
_ -> String -> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cvBindsAndSigs" (HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl) }
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs1) } }))
[LHsDecl GhcPs]
binds
| [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1
= [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1 SrcSpan
loc1 [LHsDecl GhcPs]
binds []
where
go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc
((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs2) } })))
: [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
| SrcSpanLess (Located RdrName)
RdrName
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
f2 = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go ([LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs2 [LMatch GhcPs (LHsExpr GhcPs)]
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
(SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds []
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
= let doc_decls' :: [LHsDecl GhcPs]
doc_decls' = LHsDecl GhcPs
doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls'
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
= ( SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
, ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
getMonoBind LHsBind GhcPs
bind [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = String -> Bool
forall a. String -> a
panic String
"RdrHsSyn:has_args"
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_pats = args })) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args)
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XMatch _)) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = String -> Bool
forall a. String -> a
panic String
"has_args"
has_args (LMatch GhcPs (LHsExpr GhcPs)
_ : [LMatch GhcPs (LHsExpr GhcPs)]
_) = String -> Bool
forall a. String -> a
panic String
"has_args:Impossible Match"
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
loc RdrName
tc
| OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
|| OccName -> Bool
isDataOcc OccName
occ
, FastString -> Bool
isLexCon (OccName -> FastString
occNameFS OccName
occ)
= Located RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))
| Bool
otherwise
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
msg)
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
msg :: SDoc
msg = String -> SDoc
text String
"Not a data constructor:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
patsyn_name) (Located (OrdList (LHsDecl GhcPs))
-> Located (SrcSpanLess (Located (OrdList (LHsDecl GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls) =
do { [LMatch GhcPs (LHsExpr GhcPs)]
matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls)
; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
matches) (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 SrcSpan
loc decl :: SrcSpanLess (LHsDecl GhcPs)
decl@(ValD _ (PatBind _
pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
rhs _))) =
do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SrcSpanLess (Located RdrName)
RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl
; Match GhcPs (LHsExpr GhcPs)
match <- case HsConPatDetails GhcPs
details of
PrefixCon [LPat GhcPs]
pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
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 LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
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 SrcSpan
loc 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 SrcSpan
loc 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 String
"pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc
$$
a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl
wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause must bind the pattern synonym's name"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located RdrName)
RdrName
patsyn_name) SDoc -> SDoc -> SDoc
$$ HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDecl GhcPs
decl
wrongNumberErr :: AddAnn
wrongNumberErr 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 String
"pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanLess (Located RdrName)
RdrName
patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
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 Located RdrName
name Maybe [LHsTyVarBndr GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDeclDetails GhcPs
args
= ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = XConDeclH98 GhcPs
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
-> (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
names LHsType GhcPs
ty
= (ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> LHsQTyVars pass
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext = XConDeclGADT GhcPs
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 SrcSpan
l SrcSpanLess (LHsType GhcPs)
_),[AddAnn]
anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn])
forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType GhcPs
ty []
([LHsTyVarBndr GhcPs]
tvs, LHsType GhcPs
rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy LHsType GhcPs
ty'
(Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tau, [AddAnn]
anns2) = LHsType GhcPs
-> [AddAnn] -> (Maybe (LHsContext GhcPs), LHsType GhcPs, [AddAnn])
forall pass.
LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType GhcPs
rho []
split_rho :: LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) [AddAnn]
ann
= (LHsContext pass -> Maybe (LHsContext pass)
forall a. a -> Maybe a
Just LHsContext pass
cxt, LHsType pass
tau, [AddAnn]
ann)
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann
= LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType pass
ty ([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
split_rho LHsType pass
tau [AddAnn]
ann
= (Maybe (LHsContext pass)
forall a. Maybe a
Nothing, LHsType pass
tau, [AddAnn]
ann)
(HsConDeclDetails GhcPs
args, LHsType GhcPs
res_ty) = LHsType GhcPs -> (HsConDeclDetails GhcPs, LHsType GhcPs)
forall rec pass arg.
(HasSrcSpan rec, SrcSpanLess rec ~ [LConDeclField pass]) =>
LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau LHsType GhcPs
tau
args' :: HsConDeclDetails GhcPs
args' = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
args
split_tau :: LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
= (rec -> HsConDetails arg rec
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan -> SrcSpanLess rec -> rec
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LConDeclField pass]
SrcSpanLess rec
rf), LHsType pass
res_ty)
split_tau LHsType pass
tau
= ([arg] -> HsConDetails arg rec
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [], LHsType pass
tau)
peel_parens :: LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann = LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType pass
ty
([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
peel_parens LHsType pass
ty [AddAnn]
ann = (LHsType pass
ty, [AddAnn]
ann)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
details
= case HsConDeclDetails GhcPs
details of
PrefixCon [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 Located [LConDeclField GhcPs]
r -> Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon Located [LConDeclField GhcPs]
r
InfixCon LHsType GhcPs
a1 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 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 p
lty = p
lty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual OccName
occ) NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual ModuleName
m OccName
occ) NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig Module
m OccName
occ) NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact Name
n) NameSpace
ns
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
n
= TyThing -> NameSpace -> RdrName
setWiredInNameSpace TyThing
thing NameSpace
ns
| Name -> Bool
isExternalName Name
n
= Module -> OccName -> RdrName
Orig (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n) OccName
occ
| Bool
otherwise
= Name -> RdrName
Exact (Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt (Name -> Unique
nameUnique Name
n) OccName
occ (Name -> SrcSpan
nameSrcSpan Name
n))
where
occ :: OccName
occ = NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns (Name -> OccName
nameOccName Name
n)
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon TyCon
tc) NameSpace
ns
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= TyCon -> RdrName
ty_con_data_con TyCon
tc
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
setWiredInNameSpace (AConLike (RealDataCon DataCon
dc)) NameSpace
ns
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= DataCon -> RdrName
data_con_ty_con DataCon
dc
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
setWiredInNameSpace TyThing
thing NameSpace
ns
= String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con TyCon
tc
| TyCon -> Bool
isTupleTyCon TyCon
tc
, Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
listTyConKey
= Name -> RdrName
Exact Name
nilDataConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
srcDataName (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc))
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con DataCon
dc
| let tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
, TyCon -> Bool
isTupleTyCon TyCon
tc
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey
= Name -> RdrName
Exact Name
listTyConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tcClsName (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))
filterCTuple :: RdrName -> RdrName
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact Name
n)
| Just Int
arity <- Name -> Maybe Int
cTupleTyConNameArity_maybe Name
n
= Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ TupleSort -> Int -> Name
tupleTyConName TupleSort
BoxedTuple Int
arity
filterCTuple RdrName
rdr = RdrName
rdr
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP SDoc
pp_what SDoc
equals_or_where Located RdrName
tc [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
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (SrcSpan
loc, SDoc
doc)) = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
doc
eitherToP (Right a
thing) = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return a
thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc)
( LHsQTyVars GhcPs
, [AddAnn] )
checkTyVars :: 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
= do { ([LHsTyVarBndr GhcPs]
tvs, [[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 SrcSpan
_ ki :: LHsType GhcPs
ki@(L SrcSpan
loc HsKind GhcPs
_))
= (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan
loc,
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type application" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
, String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what SDoc -> SDoc -> SDoc
<+>
PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)])
check (HsValArg LHsType GhcPs
ty) = [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens [] LHsType GhcPs
ty
check (HsArgPar 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 String
"Malformed" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)])
chkParens :: [AddAnn] -> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens :: [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens [AddAnn]
acc (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) = [AddAnn]
-> LHsType GhcPs
-> 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 [AddAnn]
acc LHsType GhcPs
ty = case LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk LHsType GhcPs
ty of
Left (SrcSpan, SDoc)
err -> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
Right 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)
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 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 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 SrcSpan
loc SrcSpanLess (LHsType GhcPs)
_)
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc,
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
, String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
, [SDoc] -> SDoc
vcat[ (String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration should have form"))
, Int -> SDoc -> SDoc
nest Int
2
(SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> SDoc
tc'
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text ([LHsTypeArg GhcPs] -> [String] -> [String]
forall b a. [b] -> [a] -> [a]
takeList [LHsTypeArg GhcPs]
tparms [String]
allNameStrings))
SDoc -> SDoc -> SDoc
<+> SDoc
equals_or_where) ] ])
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
whereDots :: SDoc
whereDots = String -> SDoc
text String
"where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text String
"= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
Nothing = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just LHsContext GhcPs
c)
= do Bool
allowed <- ExtBits -> P Bool
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 String
"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))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> LRuleBndr GhcPs)
-> [LRuleTyTmVar] -> [LRuleBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr XCRuleBndr GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
v
cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> LHsSigWcType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr GhcPs)
-> [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> HsTyVarBndr GhcPs)
-> LRuleTyTmVar -> LHsTyVarBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing) = XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
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 Located RdrName
v (Just LHsType GhcPs
sig))
= XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
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
tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
tm_to_ty RdrName
_ = String -> RdrName
forall a. String -> a
panic String
"mkRuleTyVarBndrs"
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 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` [String
"forall",String
"family",String
"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
$ String
"parse error on input "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
check a
_ = String -> P ()
forall a. String -> a
panic String
"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 SrcSpan
loc 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 String
"Illegal record syntax (use TraditionalRecordSyntax):"
SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
SrcSpanLess (Located a)
r)
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts@(Located ([AddAnn], [LConDecl GhcPs])
-> Located (SrcSpanLess (Located ([AddAnn], [LConDecl GhcPs])))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
span (_, []))
= do Bool
gadtSyntax <- ExtBits -> P Bool
getBit ExtBits
GadtSyntaxBit
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 String
"Illegal keyword 'where' in data declaration"
, String -> SDoc
text String
"Perhaps you intended to use GADTs or a similar language"
, String -> SDoc
text String
"extension to enable syntax: data T where"
]
checkEmptyGADTs Located ([AddAnn], [LConDecl GhcPs])
gadts = Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[AddAnn])
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
= LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [] [] LexicalFixity
Prefix
where
goL :: LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
ty [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
go :: SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
lp (HsParTy XParTy GhcPs
_ (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsStarTy _ isUni))) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
= do { 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 SrcSpan
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
tc)) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (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 SrcSpan
_ (HsOpTy XOpTy GhcPs
_ LHsType GhcPs
t1 ltc :: Located (IdP GhcPs)
ltc@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
tc) LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
_fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, [AddAnn]
ann)
go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l) LexicalFixity
fix
go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
t1 (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddAnn]
ann LexicalFixity
fix
= (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (Name -> RdrName
nameRdrName Name
tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> [LHsTypeArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, [AddAnn]
ann)
where
arity :: Int
arity = [LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts
tup_name :: Name
tup_name | Bool
is_cls = Int -> Name
cTupleTyConName Int
arity
| Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
go SrcSpan
l HsKind GhcPs
_ [LHsTypeArg GhcPs]
_ [AddAnn]
_ LexicalFixity
_
= SrcSpan
-> SDoc
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text String
"Malformed head of type or class declaration:"
SDoc -> SDoc -> SDoc
<+> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ty)
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments 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 String
"do block"
HsDo _ MDoExpr _ -> String -> P ()
check String
"mdo block"
HsLam {} -> String -> P ()
check String
"lambda expression"
HsCase {} -> String -> P ()
check String
"case expression"
HsLamCase {} -> String -> P ()
check String
"lambda-case expression"
HsLet {} -> String -> P ()
check String
"let expression"
HsIf {} -> String -> P ()
check String
"if expression"
HsProc {} -> String -> P ()
check String
"proc expression"
SrcSpanLess (LHsExpr GhcPs)
_ -> () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
check :: String -> P ()
check 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 String
"Unexpected " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" in function application:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
expr)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"You could write it with parentheses"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Or perhaps you meant to enable BlockArguments?"
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
checkContext (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t)
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [] (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t)
where
check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
= ([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)
check [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lp1 (HsParTy _ ty))
= [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)
check [AddAnn]
_anns LHsType GhcPs
t = SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
t P ()
-> P ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t])
msg :: SDoc
msg = String -> SDoc
text String
"data constructor context"
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
ty = LHsType GhcPs -> P ()
go LHsType GhcPs
ty
where
go :: LHsType GhcPs -> P ()
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppKindTy _ ty ki)) = LHsType GhcPs -> P ()
go LHsType GhcPs
ty P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
ki
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppTy _ t1 t2)) = LHsType GhcPs -> P ()
go LHsType GhcPs
t1 P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
t2
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P ()
forall 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 String
"Unexpected haddock", SDoc -> SDoc
quotes (LHsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsDocString
ds)
, String -> SDoc
text String
"on", SDoc
msg, SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t) ]
go LHsType GhcPs
_ = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern SDoc
msg 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 SDoc
msg [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 SDoc
msg e :: LHsExpr GhcPs
e@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
_) = 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 SDoc
_ SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l e :: SrcSpanLess (LHsExpr GhcPs)
e@(HsVar _ (dL->L _ c))) [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 String
"Perhaps you intended to use RecursiveDo") SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e
checkPat SDoc
msg SrcSpan
loc LHsExpr GhcPs
e [LPat GhcPs]
args
| Just (LHsExpr GhcPs
e', [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 SDoc
msg SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsApp _ f e)) [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 SDoc
msg SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ 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 SDoc
msg SrcSpan
loc LHsExpr GhcPs
e [LPat GhcPs]
_
= 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 SDoc
msg SrcSpan
loc HsExpr GhcPs
e0 = do
Bool
nPlusKPatterns <- ExtBits -> P Bool
getBit ExtBits
NPlusKPatternsBit
case HsExpr GhcPs
e0 of
EWildPat XEWildPat GhcPs
_ -> 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 XVar GhcPs
_ 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 XLitE GhcPs
_ (HsStringPrim XHsStringPrim GhcPs
_ ByteString
_)
-> SrcSpan -> SDoc -> P (LPat GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text String
"Illegal unboxed string literal in pattern:"
SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)
HsLit XLitE GhcPs
_ 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)
HsOverLit XOverLitE GhcPs
_ 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 XNegApp GhcPs
_ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsOverLit _ pos_lit)) SyntaxExpr GhcPs
_
-> 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 XSectionR GhcPs
_ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lb (HsVar _ (dL->L _ bang))) LHsExpr GhcPs
e
| 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 XELazyPat GhcPs
_ 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 XEAsPat GhcPs
_ Located (IdP GhcPs)
n 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)
EViewPat XEViewPat GhcPs
_ LHsExpr GhcPs
expr 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
. (\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 XExprWithTySig GhcPs
_ LHsExpr GhcPs
e 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)
OpApp XOpApp GhcPs
_ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
nloc (HsVar _ (dL->L _ n)))
(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ (dL->L _ plus)))
(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L 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 XOpApp GhcPs
_ LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
cl (HsVar _ (dL->L _ c))) 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 XExplicitList GhcPs
_ Maybe (SyntaxExpr GhcPs)
_ [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 XPar GhcPs
_ 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 XExplicitTuple GhcPs
_ [LHsTupArg GhcPs]
es 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 SrcSpan
_ (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 String
"Illegal tuple section in pattern:"
SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)
ExplicitSum XExplicitSum GhcPs
_ Int
alt Int
arity 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 [LHsRecField GhcPs (LHsExpr GhcPs)]
fs 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 XSpliceE GhcPs
_ 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)
HsExpr GhcPs
_ -> 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
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 String
"+")
bang_RDR :: RdrName
bang_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"!")
pun_RDR :: RdrName
pun_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pun-right-hand-side")
isBangRdr :: RdrName -> Bool
isBangRdr :: RdrName -> Bool
isBangRdr (Unqual OccName
occ) = OccName -> FastString
occNameFS OccName
occ FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit String
"!"
isBangRdr RdrName
_ = Bool
False
checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: SDoc
-> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField SDoc
msg (LHsRecField GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LHsRecField GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l 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 SDoc
msg SrcSpan
loc 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 String
"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 RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"rec")
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 SDoc
msg SrcStrictness
_strictness LHsExpr GhcPs
lhs (Just LHsType GhcPs
sig) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
= 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 SDoc
msg SrcStrictness
strictness LHsExpr GhcPs
lhs Maybe (LHsType GhcPs)
Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g@(Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (_,grhss))
= do { Maybe (Located RdrName, LexicalFixity, [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 (Located RdrName
fun, LexicalFixity
is_infix, [LHsExpr GhcPs]
pats, [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)
Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
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 SDoc
msg SrcStrictness
strictness [AddAnn]
ann SrcSpan
lhs_loc Located RdrName
fun LexicalFixity
is_infix [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 SrcSpan
rhs_span 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
([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 })])
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
fn [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
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 SDoc
msg 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 SrcSpan
_ (_,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 SrcSpan
_ (HsVar _ lrdr@(dL->L _ v)))
| RdrName -> Bool
isUnqual SrcSpanLess (Located RdrName)
RdrName
v
, Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
v))
= Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
Located (IdP GhcPs)
lrdr
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
_)
= SrcSpan -> SDoc -> P (Located RdrName)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l ((String -> SDoc
text String
"Invalid type signature:" SDoc -> SDoc -> SDoc
<+>
LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":: ...")
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
hint)
where
hint :: String
hint | RdrName
IdP GhcPs
foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use ForeignFunctionInterface?"
| RdrName
IdP GhcPs
default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use DefaultSignatures?"
| RdrName
IdP GhcPs
pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use PatternSynonyms?"
| Bool
otherwise
= String
"Should be of form <variable> :: <type>"
looks_like :: IdP p -> LHsExpr p -> Bool
looks_like IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ (dL->L _ v))) = SrcSpanLess (Located (IdP p))
IdP p
v IdP p -> IdP p -> Bool
forall a. Eq a => a -> a -> Bool
== IdP p
s
looks_like IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsApp _ lhs _)) = IdP p -> LHsExpr p -> Bool
looks_like IdP p
s LHsExpr p
lhs
looks_like IdP p
_ LHsExpr p
_ = Bool
False
foreign_RDR :: RdrName
foreign_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"foreign")
default_RDR :: RdrName
default_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"default")
pattern_RDR :: RdrName
pattern_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pattern")
checkDoAndIfThenElse :: LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> P ()
checkDoAndIfThenElse :: LHsExpr GhcPs
-> Bool -> LHsExpr GhcPs -> Bool -> LHsExpr GhcPs -> P ()
checkDoAndIfThenElse LHsExpr GhcPs
guardExpr Bool
semiThen LHsExpr GhcPs
thenExpr Bool
semiElse 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 String
"Unexpected semi-colons in conditional:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
expr
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Perhaps you meant to use DoAndIfThenElse?")
| Bool
otherwise = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where pprOptSemi :: Bool -> SDoc
pprOptSemi Bool
True = SDoc
semi
pprOptSemi Bool
False = SDoc
empty
expr :: SDoc
expr = String -> SDoc
text String
"if" SDoc -> SDoc -> SDoc
<+> 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 String
"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 String
"else" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
elseExpr
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
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 SrcSpan
_ (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
(LHsExpr GhcPs
arg1,[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 SrcSpan
_ (HsApp _ f e)) [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 LHsExpr p
e [LHsExpr p]
es = (LHsExpr p
e,[LHsExpr p]
es)
splitBang LHsExpr GhcPs
_ = Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. Maybe a
Nothing
isFunLhs :: LHsExpr GhcPs
-> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
isFunLhs :: LHsExpr GhcPs
-> P (Maybe
(Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
isFunLhs 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 SrcSpan
loc (HsVar _ (dL->L _ f))) [LHsExpr GhcPs]
es [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 SrcSpan
_ (HsApp _ f e)) [LHsExpr GhcPs]
es [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 SrcSpan
l (HsPar _ e)) es :: [LHsExpr GhcPs]
es@(LHsExpr GhcPs
_:[LHsExpr GhcPs]
_) [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)
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang)))
(dL->L l (HsVar _ (L _ var))))) [] [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))
go e :: LHsExpr GhcPs
e@(L SrcSpan
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc' (HsVar _ (dL->L _ op))) LHsExpr GhcPs
r)) [LHsExpr GhcPs]
es [AddAnn]
ann
| Just (LHsExpr GhcPs
e',[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)) }
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
op)
= 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
= 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 (a
op', LexicalFixity
Infix, LHsExpr GhcPs
j : LHsExpr GhcPs
k : [LHsExpr GhcPs]
es', [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])
_ -> 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 LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ [AddAnn]
_ = 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
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
| TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
instance Outputable TyEl where
ppr :: TyEl -> SDoc
ppr (TyElOpr RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
ppr (TyElOpd HsKind GhcPs
ty) = HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ty
ppr (TyElKindApp SrcSpan
_ LHsType GhcPs
ki) = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
ppr TyEl
TyElTilde = String -> SDoc
text String
"~"
ppr TyEl
TyElBang = String -> SDoc
text String
"!"
ppr (TyElUnpackedness ([AddAnn]
_, SourceText
_, SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
ppr (TyElDocPrev HsDocString
doc) = HsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDocString
doc
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness TyEl
TyElTilde = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnTilde, SrcStrictness
SrcLazy)
tyElStrictness TyEl
TyElBang = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnBang, SrcStrictness
SrcStrict)
tyElStrictness TyEl
_ = Maybe (AnnKeywordId, SrcStrictness)
forall a. Maybe a
Nothing
pStrictMark
:: [Located TyEl]
-> Maybe ( Located HsSrcBang
, [AddAnn]
, [Located TyEl] )
pStrictMark :: [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (Located TyEl)
x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located TyEl)
x2) : [Located TyEl]
xs)
| Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
, TyElUnpackedness (unpkAnns, prag, unpk) <- SrcSpanLess (Located TyEl)
x2
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
str)
, [AddAnn]
unpkAnns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [\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 SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
| Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
str)
, [\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 SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
| TyElUnpackedness (anns, prag, unpk) <- SrcSpanLess (Located TyEl)
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
, [AddAnn]
anns
, [Located TyEl]
xs )
pStrictMark [Located TyEl]
_ = Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. Maybe a
Nothing
pBangTy
:: LHsType GhcPs
-> [Located TyEl]
-> ( Bool
, LHsType GhcPs
, P ()
, [Located TyEl] )
pBangTy :: LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy lt :: LHsType GhcPs
lt@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
_) [Located TyEl]
xs =
case [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark [Located TyEl]
xs of
Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
Just (Located HsSrcBang -> Located (SrcSpanLess (Located HsSrcBang))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located HsSrcBang)
strictMark, [AddAnn]
anns, [Located TyEl]
xs') ->
let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
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)
HsKind GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
bl [AddAnn]
anns, [Located TyEl]
xs')
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 (TyElOpd t)) : [Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
t) [Located TyEl]
xs
, [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs'
= P ()
addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
t'
mergeOps [Located TyEl]
all_xs = Int
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
forall a t.
(HasSrcSpan a, Num t, Ord t, SrcSpanLess a ~ TyEl) =>
t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (Int
0 :: Int) [] LHsType GhcPs -> LHsType GhcPs
forall a. a -> a
id [Located TyEl]
all_xs
where
go :: t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElUnpackedness (anns, unpkSrc, unpk))):[a]
xs) =
if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
then do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs))
-> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc
; let a :: LHsType GhcPs
a = LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc'
strictMark :: HsSrcBang
strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
unpkSrc SrcUnpackedness
unpk SrcStrictness
NoSrcStrict
bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l (LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
a)
bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
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)
HsKind 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
SourceText
NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
SourceText String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" #-}"
unpkError :: SDoc
unpkError
| Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot appear inside a type."
| [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
&& t
k t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be applied to a type."
| Bool
otherwise =
String -> SDoc
forall a. String -> a
panic String
"mergeOps.UNPACK: impossible position"
go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElDocPrev _)):[a]
_) =
SrcSpan -> P (LHsType GhcPs)
forall a. SrcSpan -> P a
failOpDocPrev SrcSpan
l
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
x) : [a]
xs)
| Just (AnnKeywordId
_, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess a
TyEl
x
, let guess :: [a] -> Bool
guess [] = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpd _)):[a]
_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpr _)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElKindApp _ _)):[a]
_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElTilde)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElBang)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElUnpackedness _)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElDocPrev _)):[a]
xs') = [a] -> Bool
guess [a]
xs'
guess [a]
_ = String -> Bool
forall a. String -> a
panic String
"mergeOps.go.guess: Impossible Match"
in [a] -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => [a] -> Bool
guess [a]
xs
= if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& (t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1 Bool -> Bool -> Bool
|| [LHsTypeArg GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTypeArg GhcPs]
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
then do { LHsType GhcPs
a <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; Located SrcStrictness -> LHsType GhcPs -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
a) }
else Located SrcStrictness -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> P a
failOpStrictnessPosition (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpr op)):[a]
xs) =
if [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
|| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => a -> Bool
isTyElOpd [a]
xs)
then Located RdrName -> P (LHsType GhcPs)
forall a. Located RdrName -> P a
failOpFewArgs (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op)
else do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [] (\LHsType GhcPs
c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
c (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc')) [a]
xs }
where
isTyElOpd :: a -> Bool
isTyElOpd (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpd _)) = Bool
True
isTyElOpd a
_ = Bool
False
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElTilde):[a]
xs) =
let op :: RdrName
op = RdrName
eqTyCon_RDR
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElBang):[a]
xs) =
let op :: RdrName
op = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
tcClsName (String -> FastString
fsLit String
"!")
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd a)):[a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElKindApp l a)):[a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go t
_ [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc [] = do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc') }
go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ [a]
_ = String -> P (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOps.go: Impossible Match"
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = String -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg SrcSpan
_ (L SrcSpan
loc HsKind GhcPs
ki):[LHsTypeArg GhcPs]
_)
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc, String -> SDoc
text String
"Unexpected type application:" SDoc -> SDoc -> SDoc
<+> HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ki)
mergeOpsAcc (HsValArg LHsType GhcPs
ty : [LHsTypeArg GhcPs]
xs) = LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
where
go1 :: LHsType GhcPs
-> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 :: LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [] = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. b -> Either a b
Right LHsType GhcPs
lhs
go1 LHsType GhcPs
lhs (LHsTypeArg GhcPs
x:[LHsTypeArg GhcPs]
xs) = case LHsTypeArg GhcPs
x of
HsValArg LHsType GhcPs
ty -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcPs
lhs LHsType GhcPs
ty) [LHsTypeArg GhcPs]
xs
HsTypeArg SrcSpan
loc LHsType GhcPs
ki -> let ty :: LHsType GhcPs
ty = XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
XAppKindTy GhcPs
loc LHsType GhcPs
lhs LHsType GhcPs
ki
in LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
HsArgPar SrcSpan
_ -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [LHsTypeArg GhcPs]
xs
mergeOpsAcc (HsArgPar SrcSpan
_: [LHsTypeArg GhcPs]
xs) = [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
xs
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd t)):[Located TyEl]
xs)
| (Bool
True, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
t) [Located TyEl]
xs
= (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs')
pInfixSide (Located TyEl
el:[Located TyEl]
xs1)
| Just LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
= [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1] [Located TyEl]
xs1
where
go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go :: [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs]
acc (Located TyEl
el:[Located TyEl]
xs)
| Just LHsTypeArg GhcPs
t <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
= [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go (LHsTypeArg GhcPs
tLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [Located TyEl]
xs
go [LHsTypeArg GhcPs]
acc [Located TyEl]
xs = case [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc of
Left (SrcSpan, SDoc)
_ -> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
Right LHsType GhcPs
acc' -> (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
acc', () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
pInfixSide [Located TyEl]
_ = Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg :: Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->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 -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
a))
pLHsTypeArg (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (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 Located TyEl
_ = 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 Maybe a
mTrailingDoc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElDocPrev doc)):[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 Maybe a
mTrailingDoc [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) b
_ = a -> Either b a
forall a b. b -> Either a b
Right a
a
orErr Maybe a
Nothing b
b = b -> Either b a
forall a b. a -> Either a b
Left b
b
mergeDataCon
:: [Located TyEl]
-> P ( Located RdrName
, HsConDeclDetails GhcPs
, Maybe LHsDocString
)
mergeDataCon :: [Located TyEl]
-> P (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)
mergeDataCon [Located TyEl]
all_xs =
do { (P ()
addAnns, (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
(Maybe LHsDocString
mTrailingDoc, [Located TyEl]
all_xs') = [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev [Located TyEl]
all_xs
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 SrcSpan
_ (TyElDocPrev _)) <- [Located TyEl]
all_xs' ]
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'
mkConDoc :: Maybe LHsDocString -> Maybe LHsDocString
mkConDoc 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
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 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 SrcSpan
l (TyElOpd (HsRecTy _ fields))):[Located TyEl]
xs)
| (Maybe LHsDocString
mConDoc, [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 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 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 SrcSpan
l (TyElOpd t)):[Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind 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 SrcSpan
l (TyElKindApp SrcSpan
_ LHsType GhcPs
_):[Located TyEl]
_)
= 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 [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 P ()
addAnns Maybe LHsDocString
mLastDoc [LHsType GhcPs]
ts [ Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->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 P ()
addAnns Maybe LHsDocString
mLastDoc [LHsType GhcPs]
ts ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElDocPrev doc)):[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 P ()
addAnns Maybe LHsDocString
mLastDoc [LHsType GhcPs]
ts ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd t)):[Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns', [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind 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 P ()
_ Maybe LHsDocString
_ [LHsType GhcPs]
_ ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpr _)):[Located TyEl]
_) =
Either
(SrcSpan, SDoc)
(P (),
(Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goInfix
go P ()
_ Maybe LHsDocString
_ [LHsType GhcPs]
_ (L SrcSpan
l (TyElKindApp SrcSpan
_ LHsType GhcPs
_):[Located TyEl]
_) = 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 P ()
_ Maybe LHsDocString
_ [LHsType GhcPs]
_ [Located TyEl]
_ = (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 String
"Cannot parse data constructor" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs'))
goInfix :: Either
(SrcSpan, SDoc)
(P (),
(Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString))
goInfix =
do { let xs0 :: [Located TyEl]
xs0 = [Located TyEl]
all_xs'
; (LHsType GhcPs
rhs_t, P ()
rhs_addAnns, [Located TyEl]
xs1) <- [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide [Located TyEl]
xs0 Maybe (LHsType GhcPs, P (), [Located TyEl])
-> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsType GhcPs, P (), [Located TyEl])
forall a b. Maybe a -> b -> Either b a
`orErr` (SrcSpan, SDoc)
malformedErr
; let (Maybe LHsDocString
mOpDoc, [Located TyEl]
xs2) = [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev [Located TyEl]
xs1
; (Located RdrName
op, [Located TyEl]
xs3) <- case [Located TyEl]
xs2 of
(Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpr op)) : [Located TyEl]
xs3 ->
do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
op
; (Located RdrName, [Located TyEl])
-> Either (SrcSpan, SDoc) (Located RdrName, [Located TyEl])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
data_con, [Located TyEl]
xs3) }
[Located TyEl]
_ -> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (Located RdrName, [Located TyEl])
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
malformedErr
; let (Maybe LHsDocString
mLhsDoc, [Located TyEl]
xs4) = [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev [Located TyEl]
xs3
; (LHsType GhcPs
lhs_t, P ()
lhs_addAnns, [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 String
"Cannot parse an infix data constructor" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs'))
kindAppErr :: SDoc
kindAppErr =
String -> SDoc
text String
"Unexpected kind application" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"in a data/newtype declaration:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Located TyEl -> SDoc) -> [Located TyEl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located TyEl -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located TyEl]
all_xs')
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
checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand 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 SrcSpan -> a -> P b
f (Located a -> Located (SrcSpanLess (Located a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l 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 -> 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 SrcSpan
_ (HsArrApp XArrApp GhcPs
_ LHsExpr GhcPs
e1 LHsExpr GhcPs
e2 HsArrAppType
haat 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 SrcSpan
_ (HsArrForm XArrForm GhcPs
_ LHsExpr GhcPs
e Maybe Fixity
mf [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 SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
e1 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
>>= (\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 SrcSpan
_ (HsLam XLam GhcPs
_ 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
>>= (\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 SrcSpan
_ (HsPar XPar GhcPs
_ 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
>>= (\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 SrcSpan
_ (HsCase XCase GhcPs
_ LHsExpr GhcPs
e 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
>>= (\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 SrcSpan
_ (HsIf XIf GhcPs
_ Maybe (SyntaxExpr GhcPs)
cf LHsExpr GhcPs
ep LHsExpr GhcPs
et 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 SrcSpan
_ (HsLet XLet GhcPs
_ LHsLocalBinds GhcPs
lb 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
>>= (\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 SrcSpan
_ (HsDo XDo GhcPs
_ HsStmtContext Name
DoExpr (Located [ExprLStmt GhcPs]
-> Located (SrcSpanLess (Located [ExprLStmt GhcPs]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l 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
>>=
(\[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 SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
eLeft LHsExpr GhcPs
op LHsExpr GhcPs
eRight) = do
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 SrcSpan
l 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 SrcSpan
_ (LastStmt XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e Bool
s 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
>>= (\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 SrcSpan
_ (BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
x LPat GhcPs
pat LHsExpr GhcPs
e SyntaxExpr GhcPs
b 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
>>= (\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 SrcSpan
_ (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e SyntaxExpr GhcPs
t 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
>>= (\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 SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
x 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 SrcSpan
_ 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 SrcSpan
_ (XStmtLR XXStmtLR GhcPs GhcPs (LHsExpr GhcPs)
_) = String -> P (CmdStmt GhcPs)
forall a. String -> a
panic String
"checkCmdStmt"
checkCmdStmt SrcSpan
l 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 SrcSpan
l 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 XXMatch GhcPs (LHsExpr GhcPs)
_) = String -> P (Match GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic String
"checkCmdMatchGroup.XMatch"
checkCmdMatchGroup (XMatchGroup {}) = String -> P (MatchGroup GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic String
"checkCmdMatchGroup"
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
x [LGRHS GhcPs (LHsExpr GhcPs)]
grhss 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 XXGRHSs GhcPs (LHsExpr GhcPs)
_) = String -> P (GRHSs GhcPs (LHsCmd GhcPs))
forall a. String -> a
panic String
"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 XCGRHS p (LHsExpr GhcPs)
x [GuardLStmt p]
stmts LHsExpr GhcPs
e) = do
LHsCmd GhcPs
c <- LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand LHsExpr GhcPs
e
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 [GuardLStmt p]
stmts LHsCmd GhcPs
c
convert (XGRHS XXGRHS p (LHsExpr GhcPs)
_) = String -> P (GRHS p (LHsCmd GhcPs))
forall a. String -> a
panic String
"checkCmdGRHS"
cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
cmdFail SrcSpan
loc HsExpr GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text String
"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 SrcSpan
loc ExprStmt GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc
(String -> SDoc
text String
"Parse error in command statement:" SDoc -> SDoc -> SDoc
<+> ExprStmt GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExprStmt GhcPs
e)
checkPrecP
:: Located (SourceText,Int)
-> Located (OrdList (Located RdrName))
-> 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 SrcSpan
l (_,i)) (Located (OrdList (Located RdrName))
-> Located (SrcSpanLess (Located (OrdList (Located RdrName))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (OrdList (Located RdrName)))
ol)
| Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPrecedence = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| (Located RdrName -> Bool) -> OrdList (Located RdrName) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Located RdrName -> Bool
forall 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 (String
"Precedence out of range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i))
where
specialOp :: a -> Bool
specialOp 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 SrcSpan
l (HsVar _ (dL->L _ c))) SrcSpan
_ ([LHsRecField GhcPs (LHsExpr GhcPs)]
fs,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 SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
_) SrcSpan
_ ([LHsRecField GhcPs (LHsExpr GhcPs)]
fs,Bool
dd)
| Bool
dd = SrcSpan -> SDoc -> P (HsExpr GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text String
"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 LHsExpr GhcPs
exp [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 Located RdrName
con 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 [LHsRecField id arg]
fs Bool
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 [LHsRecField id arg]
fs Bool
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 SrcSpan
loc (FieldOcc _ rdr)) LHsExpr GhcPs
arg Bool
pun)
= Located (AmbiguousFieldOcc GhcPs)
-> LHsExpr GhcPs -> Bool -> HsRecUpdField GhcPs
forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField (SrcSpan
-> AmbiguousFieldOcc GhcPs -> Located (AmbiguousFieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcPs -> Located RdrName -> AmbiguousFieldOcc GhcPs
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous 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 SrcSpan
_ (XFieldOcc _)) LHsExpr GhcPs
_ Bool
_)
= String -> HsRecUpdField GhcPs
forall a. String -> a
panic String
"mk_rec_upd_field"
mk_rec_upd_field (HsRecField Located (FieldOcc GhcPs)
_ LHsExpr GhcPs
_ Bool
_)
= String -> HsRecUpdField GhcPs
forall a. String -> a
panic String
"mk_rec_upd_field: Impossible Match"
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
mkInlinePragma :: SourceText
-> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
mkInlinePragma SourceText
src (InlineSpec
inl, RuleMatchInfo
match_info) Maybe Activation
mb_act
= InlinePragma :: SourceText
-> InlineSpec
-> Maybe Int
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src = SourceText
src
, inl_inline :: InlineSpec
inl_inline = InlineSpec
inl
, inl_sat :: Maybe Int
inl_sat = Maybe Int
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
act
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
match_info }
where
act :: Activation
act = case Maybe Activation
mb_act of
Just Activation
act -> Activation
act
Maybe Activation
Nothing ->
case InlineSpec
inl of
InlineSpec
NoInline -> Activation
NeverActive
InlineSpec
_other -> Activation
AlwaysActive
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkImport Located CCallConv
cconv Located Safety
safety (L SrcSpan
loc (StringLiteral SourceText
esrc FastString
entity), Located RdrName
v, LHsSigType GhcPs
ty) =
case Located CCallConv -> SrcSpanLess (Located CCallConv)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located CCallConv
cconv of
SrcSpanLess (Located CCallConv)
CCallConv -> P (HsDecl GhcPs)
mkCImport
SrcSpanLess (Located CCallConv)
CApiConv -> P (HsDecl GhcPs)
mkCImport
SrcSpanLess (Located CCallConv)
StdCallConv -> P (HsDecl GhcPs)
mkCImport
SrcSpanLess (Located CCallConv)
PrimCallConv -> P (HsDecl GhcPs)
mkOtherImport
SrcSpanLess (Located CCallConv)
JavaScriptCallConv -> P (HsDecl GhcPs)
mkOtherImport
where
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
Maybe ForeignImport
Nothing -> SrcSpan -> SDoc -> P (HsDecl GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text String
"Malformed entity string")
Just ForeignImport
importSpec -> ForeignImport -> P (HsDecl GhcPs)
returnSpec ForeignImport
importSpec
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 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
}
parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport :: Located CCallConv
-> Located Safety
-> FastString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport Located CCallConv
cconv Located Safety
safety FastString
nm String
str Located SourceText
sourceText =
[ForeignImport] -> Maybe ForeignImport
forall a. [a] -> Maybe a
listToMaybe ([ForeignImport] -> Maybe ForeignImport)
-> [ForeignImport] -> Maybe ForeignImport
forall a b. (a -> b) -> a -> b
$ ((ForeignImport, String) -> ForeignImport)
-> [(ForeignImport, String)] -> [ForeignImport]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignImport, String) -> ForeignImport
forall a b. (a, b) -> a
fst ([(ForeignImport, String)] -> [ForeignImport])
-> [(ForeignImport, String)] -> [ForeignImport]
forall a b. (a -> b) -> a -> b
$ ((ForeignImport, String) -> Bool)
-> [(ForeignImport, String)] -> [(ForeignImport, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null(String -> Bool)
-> ((ForeignImport, String) -> String)
-> (ForeignImport, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ForeignImport, String) -> String
forall a b. (a, b) -> b
snd) ([(ForeignImport, String)] -> [(ForeignImport, String)])
-> [(ForeignImport, String)] -> [(ForeignImport, String)]
forall a b. (a -> b) -> a -> b
$
ReadP ForeignImport -> ReadS ForeignImport
forall a. ReadP a -> ReadS a
readP_to_S ReadP ForeignImport
parse String
str
where
parse :: ReadP ForeignImport
parse = do
ReadP ()
skipSpaces
ForeignImport
r <- [ReadP ForeignImport] -> ReadP ForeignImport
forall a. [ReadP a] -> ReadP a
choice [
String -> ReadP String
string String
"dynamic" ReadP String -> ReadP ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing (CCallTarget -> CImportSpec
CFunction CCallTarget
DynamicTarget)),
String -> ReadP String
string String
"wrapper" ReadP String -> ReadP ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing CImportSpec
CWrapper),
do ReadP () -> ReadP ()
forall a. ReadP a -> ReadP ()
optional (String -> ReadP ()
token String
"static" ReadP () -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces)
((Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
forall a. Maybe a
Nothing (CImportSpec -> ForeignImport)
-> ReadP CImportSpec -> ReadP ForeignImport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP CImportSpec
cimp FastString
nm) ReadP ForeignImport -> ReadP ForeignImport -> ReadP ForeignImport
forall a. ReadP a -> ReadP a -> ReadP a
+++
(do String
h <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
hdr_char
ReadP ()
skipSpaces
Maybe Header -> CImportSpec -> ForeignImport
mk (Header -> Maybe Header
forall a. a -> Maybe a
Just (SourceText -> FastString -> Header
Header (String -> SourceText
SourceText String
h) (String -> FastString
mkFastString String
h)))
(CImportSpec -> ForeignImport)
-> ReadP CImportSpec -> ReadP ForeignImport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> ReadP CImportSpec
cimp FastString
nm))
]
ReadP ()
skipSpaces
ForeignImport -> ReadP ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignImport
r
token :: String -> ReadP ()
token String
str = do String
_ <- String -> ReadP String
string String
str
String
toks <- ReadP String
look
case String
toks of
Char
c : String
_
| Char -> Bool
id_char Char
c -> ReadP ()
forall a. ReadP a
pfail
String
_ -> () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mk :: Maybe Header -> CImportSpec -> ForeignImport
mk Maybe Header
h CImportSpec
n = Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
h CImportSpec
n Located SourceText
sourceText
hdr_char :: Char -> Bool
hdr_char Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
id_first_char :: Char -> Bool
id_first_char Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
id_char :: Char -> Bool
id_char Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
cimp :: FastString -> ReadP CImportSpec
cimp FastString
nm = (Char -> ReadP Char
ReadP.char Char
'&' ReadP Char -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
skipSpaces ReadP () -> ReadP CImportSpec -> ReadP CImportSpec
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FastString -> CImportSpec
CLabel (FastString -> CImportSpec)
-> ReadP FastString -> ReadP CImportSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP FastString
cid)
ReadP CImportSpec -> ReadP CImportSpec -> ReadP CImportSpec
forall a. ReadP a -> ReadP a -> ReadP a
+++ (do Bool
isFun <- case Located CCallConv -> SrcSpanLess (Located CCallConv)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located CCallConv
cconv of
SrcSpanLess (Located CCallConv)
CApiConv ->
Bool -> ReadP Bool -> ReadP Bool
forall a. a -> ReadP a -> ReadP a
option Bool
True
(do String -> ReadP ()
token String
"value"
ReadP ()
skipSpaces
Bool -> ReadP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
SrcSpanLess (Located CCallConv)
_ -> Bool -> ReadP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
FastString
cid' <- ReadP FastString
cid
CImportSpec -> ReadP CImportSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (CCallTarget -> CImportSpec
CFunction (SourceText -> FastString -> Maybe 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)))
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 SrcSpan
lc SrcSpanLess (Located CCallConv)
cconv) (Located StringLiteral
-> Located (SrcSpanLess (Located StringLiteral))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
le (StringLiteral esrc entity), Located RdrName
v, LHsSigType GhcPs
ty)
= HsDecl GhcPs -> P (HsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDecl GhcPs -> P (HsDecl GhcPs))
-> HsDecl GhcPs -> P (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD 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
mkExtName :: RdrName -> CLabelString
mkExtName :: RdrName -> FastString
mkExtName RdrName
rdrNm = String -> FastString
mkFastString (OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
rdrNm))
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 SrcSpan
l SrcSpanLess (Located ImpExpQcSpec)
specname) ImpExpSubSpec
subs =
case ImpExpSubSpec
subs of
ImpExpSubSpec
ImpExpAbs
| NameSpace -> Bool
isVarNameSpace (RdrName -> NameSpace
rdrNameSpace RdrName
name)
-> IE GhcPs -> P (IE GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (IE GhcPs -> P (IE GhcPs)) -> IE GhcPs -> P (IE GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar 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
ImpExpSubSpec
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 [Located ImpExpQcSpec]
xs ->
(\IEWrappedName RdrName
newName -> XIEThingWith GhcPs
-> LIEWrappedName (IdP GhcPs)
-> IEWildcard
-> [LIEWrappedName (IdP GhcPs)]
-> [Located (FieldLbl (IdP GhcPs))]
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith 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 [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 (\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 String
"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 String
"Expecting a type constructor but found a variable,"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"."
SDoc -> SDoc -> SDoc
$$ if OccName -> Bool
isSymOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
name
then String -> SDoc
text String
"If" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a type constructor"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"then enable ExplicitNamespaces and use the 'type' keyword."
else SDoc
empty)
else IEWrappedName RdrName -> P (IEWrappedName RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (IEWrappedName RdrName -> P (IEWrappedName RdrName))
-> IEWrappedName RdrName -> P (IEWrappedName RdrName)
forall a b. (a -> b) -> a -> b
$ ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec SrcSpanLess (Located ImpExpQcSpec)
ImpExpQcSpec
specname
ieNameVal :: ImpExpQcSpec -> RdrName
ieNameVal (ImpExpQcName Located RdrName
ln) = Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
ln
ieNameVal (ImpExpQcType 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 String
"ieNameVal got wildcard"
ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName RdrName
ieNameFromSpec (ImpExpQcName Located RdrName
ln) = Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEName Located RdrName
ln
ieNameFromSpec (ImpExpQcType Located RdrName
ln) = Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEType Located RdrName
ln
ieNameFromSpec (ImpExpQcSpec
ImpExpQcWildcard) = String -> IEWrappedName RdrName
forall a. String -> a
panic String
"ieName got wildcard"
wrapped :: [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
-> P (Located RdrName)
mkTypeImpExp :: Located RdrName -> P (Located RdrName)
mkTypeImpExp 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 String
"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 SrcSpan
_ SrcSpanLess (Located [LIE GhcPs])
specs) =
case [SrcSpan
l | (LIE GhcPs -> Located (SrcSpanLess (LIE GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->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
(SrcSpan
l:[SrcSpan]
_) -> SrcSpan -> P (Located [LIE GhcPs])
forall a. SrcSpan -> P a
importSpecError SrcSpan
l
where
importSpecError :: SrcSpan -> P a
importSpecError SrcSpan
l =
SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l
(String -> SDoc
text String
"Illegal import form, this syntax can only be used to bundle"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"pattern synonyms with types in module exports.")
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 SrcSpan
_ SrcSpanLess (Located ImpExpQcSpec)
ImpExpQcWildcard] =
([AddAnn], ImpExpSubSpec) -> P ([AddAnn], ImpExpSubSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ImpExpSubSpec
ImpExpAll)
mkImpExpSubSpec [Located ImpExpQcSpec]
xs =
if ((Located ImpExpQcSpec -> Bool) -> [Located ImpExpQcSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ImpExpQcSpec -> Bool
isImpExpQcWildcard (ImpExpQcSpec -> Bool)
-> (Located ImpExpQcSpec -> ImpExpQcSpec)
-> Located ImpExpQcSpec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ImpExpQcSpec -> ImpExpQcSpec
forall 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 ImpExpQcSpec
ImpExpQcWildcard = Bool
True
isImpExpQcWildcard ImpExpQcSpec
_ = Bool
False
warnStarIsType :: SrcSpan -> P ()
warnStarIsType :: AddAnn
warnStarIsType SrcSpan
span = WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning WarningFlag
Opt_WarnStarIsType SrcSpan
span SDoc
msg
where
msg :: SDoc
msg = String -> SDoc
text String
"Using" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"*")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(or its Unicode variant) to mean"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Data.Kind.Type")
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"relies on the StarIsType extension, which will become"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"deprecated in the future."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Suggested fix: use" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Type")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"from" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"Data.Kind") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"instead."
warnStarBndr :: SrcSpan -> P ()
warnStarBndr :: AddAnn
warnStarBndr SrcSpan
span = WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning WarningFlag
Opt_WarnStarBinder SrcSpan
span SDoc
msg
where
msg :: SDoc
msg = String -> SDoc
text String
"Found binding occurrence of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"*")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"yet StarIsType is enabled."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"NB. To use (or export) this operator in"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"modules with StarIsType,"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
" including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
failOpFewArgs :: Located RdrName -> P a
failOpFewArgs (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc 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 String
"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 SrcSpan
loc = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
msg
where
msg :: SDoc
msg = String -> SDoc
text String
"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 SrcSpan
_ SrcSpanLess (Located SrcStrictness)
str) (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc 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 String
"Strictness annotation applied to a compound type." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Did you mean to add parentheses?" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 (SrcStrictness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located SrcStrictness)
SrcStrictness
str SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsType GhcPs)
HsKind 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 SrcSpan
loc SrcSpanLess (Located SrcStrictness)
_) = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
msg
where
msg :: SDoc
msg = String -> SDoc
text String
"Strictness annotation cannot appear in this position."
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
span SDoc
s = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
failSpanMsgP SrcSpan
span SDoc
s
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat SrcSpan
span 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 String
"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)
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
mkSumOrTuple Boxity
boxity SrcSpan
_ (Tuple [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)
mkSumOrTuple Boxity
Unboxed SrcSpan
_ (Sum Int
alt Int
arity 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 Boxity
Boxed SrcSpan
l (Sum Int
alt Int
arity (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ 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 String
"Boxed sums not supported:") Int
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 Int
alt Int
arity HsExpr GhcPs
e =
String -> SDoc
text String
"(" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 String
")"
ppr_bars :: Int -> SDoc
ppr_bars Int
n = [SDoc] -> SDoc
hsep (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate Int
n (Char -> SDoc
Outputable.char Char
'|'))
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
x Located RdrName
op LHsType GhcPs
y =
let loc :: SrcSpan
loc = LHsType GhcPs -> SrcSpan
forall 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 -> HsKind GhcPs
forall (p :: Pass).
LHsType (GhcPass p)
-> Located (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy LHsType GhcPs
x Located RdrName
Located (IdP GhcPs)
op LHsType GhcPs
y)
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy LHsType GhcPs
t 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 -> HsKind 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 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)
starSym :: Bool -> String
starSym :: Bool -> String
starSym Bool
True = String
"★"
starSym Bool
False = String
"*"
forallSym :: Bool -> String
forallSym :: Bool -> String
forallSym Bool
True = String
"∀"
forallSym Bool
False = String
"forall"