{-# 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 "HsVersions.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 loc :: SrcSpan
loc d :: SrcSpanLess (LTyClDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD (GhcPass p)
NoExt
noExt SrcSpanLess (LTyClDecl (GhcPass p))
TyClDecl (GhcPass p)
d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (LInstDecl (GhcPass p)
-> Located (SrcSpanLess (LInstDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc d :: SrcSpanLess (LInstDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD (GhcPass p)
NoExt
noExt SrcSpanLess (LInstDecl (GhcPass p))
InstDecl (GhcPass p)
d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
mkClassDecl loc :: SrcSpan
loc (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (mcxt, tycl_hdr)) fds :: Located (a, [LHsFunDep GhcPs])
fds where_cls :: OrdList (LHsDecl GhcPs)
where_cls
= do { (binds :: LHsBinds GhcPs
binds, sigs :: [LSig GhcPs]
sigs, ats :: [LFamilyDecl GhcPs]
ats, at_insts :: [LTyFamInstDecl GhcPs]
at_insts, _, docs :: [LDocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; (cls :: Located RdrName
cls, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (tyvars :: LHsQTyVars GhcPs
tyvars,annst :: [AddAnn]
annst) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text "class") SDoc
whereDots Located RdrName
cls [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
annst
; (at_defs :: [LTyFamDefltEqn GhcPs]
at_defs, annsi :: [P ()]
annsi) <- (LTyFamInstDecl GhcPs -> P (LTyFamDefltEqn GhcPs, P ()))
-> [LTyFamInstDecl GhcPs] -> P ([LTyFamDefltEqn GhcPs], [P ()])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-> P (LTyFamDefltEqn GhcPs, P ())
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-> P (LTyFamDefltEqn GhcPs, P ()))
-> (LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()))
-> LTyFamInstDecl GhcPs
-> P (LTyFamDefltEqn GhcPs, P ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
mkATDefault) [LTyFamInstDecl GhcPs]
at_insts
; [P ()] -> P ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [P ()]
annsi
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltEqn pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = XClassDecl GhcPs
NoExt
noExt, tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = (a, [Located (FunDep (Located RdrName))])
-> [Located (FunDep (Located RdrName))]
forall a b. (a, b) -> b
snd (Located (a, [Located (FunDep (Located RdrName))])
-> SrcSpanLess (Located (a, [Located (FunDep (Located RdrName))]))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (a, [Located (FunDep (Located RdrName))])
Located (a, [LHsFunDep GhcPs])
fds)
, tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [LSig GhcPs]
sigs
, tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
binds
, tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: [LTyFamDefltEqn GhcPs]
tcdATDefs = [LTyFamDefltEqn GhcPs]
at_defs
, tcdDocs :: [LDocDecl]
tcdDocs = [LDocDecl]
docs })) }
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
| FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon = Located (IdP GhcPs)
tc, feqn_bndrs :: forall pass pats rhs.
FamEqn pass pats rhs -> Maybe [LHsTyVarBndr pass]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs, feqn_pats :: forall pass pats rhs. FamEqn pass pats rhs -> pats
feqn_pats = [LHsTypeArg GhcPs]
pats
, feqn_fixity :: forall pass pats rhs. FamEqn pass pats rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity, feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs = LHsType GhcPs
rhs } <- FamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
e
= do { (tvs :: LHsQTyVars GhcPs
tvs, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text "default") SDoc
equalsDots Located RdrName
Located (IdP GhcPs)
tc [LHsTypeArg GhcPs]
pats
; let f :: LTyFamDefltEqn GhcPs
f = SrcSpan
-> SrcSpanLess (LTyFamDefltEqn GhcPs) -> LTyFamDefltEqn GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsQTyVars GhcPs) (LHsType GhcPs)
feqn_ext = XCFamEqn GhcPs (LHsQTyVars GhcPs) (LHsType GhcPs)
NoExt
noExt
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = ASSERT( isNothing bndrs )
Maybe [LHsTyVarBndr GhcPs]
forall a. Maybe a
Nothing
, feqn_pats :: LHsQTyVars GhcPs
feqn_pats = LHsQTyVars GhcPs
tvs
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: LHsType GhcPs
feqn_rhs = LHsType GhcPs
rhs })
; (LTyFamDefltEqn GhcPs, P ())
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LTyFamDefltEqn GhcPs
f, SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns) }
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault"
mkATDefault (LTyFamInstDecl GhcPs
-> Located (SrcSpanLess (LTyFamInstDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault"
mkATDefault _ = String -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
forall a. String -> a
panic "mkATDefault: Impossible Match"
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData loc :: SrcSpan
loc new_or_data :: NewOrData
new_or_data cType :: Maybe (Located CType)
cType (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (mcxt, tycl_hdr))
ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: HsDeriving GhcPs
maybe_deriv
= do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (NewOrData -> SDoc
forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
NoExt
noExt,
tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn new_or_data :: NewOrData
new_or_data cType :: Maybe (Located CType)
cType mcxt :: Maybe (LHsContext GhcPs)
mcxt ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: HsDeriving GhcPs
maybe_deriv
= do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExt
noExt
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
, dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
cxt
, dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
data_cons
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs)
mkTySynonym loc :: SrcSpan
loc lhs :: LHsType GhcPs
lhs rhs :: LHsType GhcPs
rhs
= do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (String -> SDoc
text "type") SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = XSynDecl GhcPs
NoExt
noExt
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs, [AddAnn])
mkTyFamInstEqn bndrs :: Maybe [LHsTyVarBndr GhcPs]
bndrs lhs :: LHsType GhcPs
lhs rhs :: LHsType GhcPs
rhs
= do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
-> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
feqn_ext = XCFamEqn GhcPs [LHsTypeArg GhcPs] (LHsType GhcPs)
NoExt
noExt
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: LHsType GhcPs
feqn_rhs = LHsType GhcPs
rhs }),
[AddAnn]
ann) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs],
LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst loc :: SrcSpan
loc new_or_data :: NewOrData
new_or_data cType :: Maybe (Located CType)
cType (mcxt :: Maybe (LHsContext GhcPs)
mcxt, bndrs :: Maybe [LHsTyVarBndr GhcPs]
bndrs, tycl_hdr :: LHsType GhcPs
tycl_hdr)
ksig :: Maybe (LHsType GhcPs)
ksig data_cons :: [LConDecl GhcPs]
data_cons maybe_deriv :: HsDeriving GhcPs
maybe_deriv
= do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; (AddAnn -> P ()) -> [AddAnn] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\a :: AddAnn
a -> AddAnn
a SrcSpan
loc) [AddAnn]
ann
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcPs
NoExt
noExt (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl (FamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs [LHsTypeArg GhcPs] (HsDataDefn GhcPs)
NoExt
noExt
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn }))))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs)
mkTyFamInst loc :: SrcSpan
loc eqn :: TyFamInstEqn GhcPs
eqn
= LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcPs
NoExt
noExt (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> 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 loc :: SrcSpan
loc info :: FamilyInfo GhcPs
info lhs :: LHsType GhcPs
lhs ksig :: Located (FamilyResultSig GhcPs)
ksig injAnn :: Maybe (LInjectivityAnn GhcPs)
injAnn
= do { (tc :: Located RdrName
tc, tparams :: [LHsTypeArg GhcPs]
tparams, fixity :: LexicalFixity
fixity, ann :: [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (tyvars :: LHsQTyVars GhcPs
tyvars, anns :: [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP (FamilyInfo GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamilyInfo GhcPs
info) SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExt
noExt (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl
{ fdExt :: XCFamilyDecl GhcPs
fdExt = XCFamilyDecl GhcPs
NoExt
noExt
, fdInfo :: FamilyInfo GhcPs
fdInfo = FamilyInfo GhcPs
info, fdLName :: Located (IdP GhcPs)
fdLName = Located RdrName
Located (IdP GhcPs)
tc
, fdTyVars :: LHsQTyVars GhcPs
fdTyVars = LHsQTyVars GhcPs
tyvars
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdResultSig :: Located (FamilyResultSig GhcPs)
fdResultSig = Located (FamilyResultSig GhcPs)
ksig
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injAnn }))) }
where
equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
DataFamily -> SDoc
empty
OpenTypeFamily -> SDoc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc expr :: SrcSpanLess (LHsExpr GhcPs)
expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| Bool
otherwise
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExt
noExt (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExt
noExt (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice SpliceDecoration
NoParens LHsExpr GhcPs
lexpr))
SpliceExplicitFlag
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc :: SrcSpan
loc tycon :: Located RdrName
tycon roles :: [Located (Maybe FastString)]
roles
= do { [Located (Maybe Role)]
roles' <- (Located (Maybe FastString) -> P (Located (Maybe Role)))
-> [Located (Maybe FastString)] -> P [Located (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs))
-> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs)
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [Located (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
tycon [Located (Maybe Role)]
roles' }
where
role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]
parse_role :: Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc_role :: SrcSpan
loc_role Nothing) = Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role SrcSpanLess (Located (Maybe Role))
forall a. Maybe a
Nothing
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc_role :: SrcSpan
loc_role (Just role))
= case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
Just found_role :: Role
found_role -> Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role (SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role))
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
Nothing ->
let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
SrcSpan -> SDoc -> P (Located (Maybe Role))
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc_role
(String -> SDoc
text "Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
[Role] -> SDoc
forall a. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)
parse_role _ = String -> P (Located (Maybe Role))
forall a. String -> a
panic "parse_role: Impossible Match"
suggestions :: [a] -> SDoc
suggestions [] = SDoc
empty
suggestions [r :: a
r] = String -> SDoc
text "Perhaps you meant" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r)
suggestions list :: [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Perhaps you meant one of these:")
2 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [a]
list)
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls decls :: OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (ValD x b)) : ds :: [LHsDecl GhcPs]
ds)
= SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
x SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds'
where (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l' :: SrcSpan
l' b' :: SrcSpanLess (LHsBind GhcPs)
b', ds' :: [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go (d :: LHsDecl GhcPs
d : ds :: [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding :: OrdList (LHsDecl GhcPs)
binding
= do { (mbs :: LHsBinds GhcPs
mbs, sigs :: [LSig GhcPs]
sigs, fam_ds :: [LFamilyDecl GhcPs]
fam_ds, tfam_insts :: [LTyFamInstDecl GhcPs]
tfam_insts
, dfam_insts :: [LDataFamInstDecl GhcPs]
dfam_insts, _) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBinds GhcPs -> P (HsValBinds GhcPs))
-> HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBinds GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExt
noExt LHsBinds GhcPs
mbs [LSig GhcPs]
sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs fb :: OrdList (LHsDecl GhcPs)
fb = [LHsDecl GhcPs]
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall a a a a a.
(HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a,
HasSrcSpan a, SrcSpanLess a ~ Sig GhcPs,
SrcSpanLess a ~ FamilyDecl GhcPs,
SrcSpanLess a ~ TyFamInstDecl GhcPs,
SrcSpanLess a ~ DataFamInstDecl GhcPs, SrcSpanLess a ~ DocDecl) =>
[LHsDecl GhcPs] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
fb)
where
go :: [LHsDecl GhcPs] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [] = (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
forall a. Bag a
emptyBag, [], [], [], [], [])
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (ValD _ b)) : ds :: [LHsDecl GhcPs]
ds)
= do { (bs :: LHsBinds GhcPs
bs, ss :: [a]
ss, ts :: [a]
ts, tfis :: [a]
tfis, dfis :: [a]
dfis, docs :: [a]
docs) <- [LHsDecl GhcPs] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds'
; (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBind GhcPs
b' LHsBind GhcPs -> LHsBinds GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a -> Bag a
`consBag` LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) }
where
(b' :: LHsBind GhcPs
b', ds' :: [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l decl :: SrcSpanLess (LHsDecl GhcPs)
decl) : ds :: [LHsDecl GhcPs]
ds)
= do { (bs :: LHsBinds GhcPs
bs, ss :: [a]
ss, ts :: [a]
ts, tfis :: [a]
tfis, dfis :: [a]
dfis, docs :: [a]
docs) <- [LHsDecl GhcPs] -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds
; case SrcSpanLess (LHsDecl GhcPs)
decl of
SigD _ s
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
Sig GhcPs
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
TyClD _ (FamDecl _ t)
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
FamilyDecl GhcPs
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
TyFamInstDecl GhcPs
tfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tfis, [a]
dfis, [a]
docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DataFamInstDecl GhcPs
dfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
dfis, [a]
docs)
DocD _ d
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DocDecl
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
docs)
SpliceD _ d
-> SrcSpan -> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a]))
-> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "at the top level:")
2 (SpliceDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl GhcPs
d)
_ -> String -> SDoc -> P (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "cvBindsAndSigs" (HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl) }
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 loc1 :: SrcSpan
loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs1) } }))
binds :: [LHsDecl GhcPs]
binds
| [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1
= [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1 SrcSpan
loc1 [LHsDecl GhcPs]
binds []
where
go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc
((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs2) } })))
: binds :: [LHsDecl GhcPs]
binds) _
| SrcSpanLess (Located RdrName)
RdrName
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
f2 = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go ([LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs2 [LMatch GhcPs (LHsExpr GhcPs)]
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
(SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds []
go mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 (DocD {})) : binds :: [LHsDecl GhcPs]
binds) doc_decls :: [LHsDecl GhcPs]
doc_decls
= let doc_decls' :: [LHsDecl GhcPs]
doc_decls' = LHsDecl GhcPs
doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls'
go mtchs :: [LMatch GhcPs (LHsExpr GhcPs)]
mtchs loc :: SrcSpan
loc binds :: [LHsDecl GhcPs]
binds doc_decls :: [LHsDecl GhcPs]
doc_decls
= ( SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
, ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
getMonoBind bind :: LHsBind GhcPs
bind binds :: [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = String -> Bool
forall a. String -> a
panic "RdrHsSyn:has_args"
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (Match { m_pats = args })) : _) = Bool -> Bool
not ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args)
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XMatch _)) : _) = String -> Bool
forall a. String -> a
panic "has_args"
has_args (_ : _) = String -> Bool
forall a. String -> a
panic "has_args:Impossible Match"
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon loc :: SrcSpan
loc tc :: RdrName
tc
| OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
|| OccName -> Bool
isDataOcc OccName
occ
, FastString -> Bool
isLexCon (OccName -> FastString
occNameFS OccName
occ)
= Located RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))
| Bool
otherwise
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
msg)
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
msg :: SDoc
msg = String -> SDoc
text "Not a data constructor:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc patsyn_name :: SrcSpanLess (Located RdrName)
patsyn_name) (Located (OrdList (LHsDecl GhcPs))
-> Located (SrcSpanLess (Located (OrdList (LHsDecl GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ decls :: SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls) =
do { [LMatch GhcPs (LHsExpr GhcPs)]
matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls)
; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
matches) (AddAnn
wrongNumberErr SrcSpan
loc)
; MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs)))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
matches }
where
fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc decl :: SrcSpanLess (LHsDecl GhcPs)
decl@(ValD _ (PatBind _
pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
rhs _))) =
do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SrcSpanLess (Located RdrName)
RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl
; Match GhcPs (LHsExpr GhcPs)
match <- case HsConPatDetails GhcPs
details of
PrefixCon pats :: [LPat GhcPs]
pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExt
noExt
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext RdrName
ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs { mc_fun :: Located RdrName
mc_fun = Located RdrName
Located (IdP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
InfixCon p1 :: LPat GhcPs
p1 p2 :: LPat GhcPs
p2 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExt
noExt
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt
, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs
p1, LPat GhcPs
p2]
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext RdrName
ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs { mc_fun :: Located RdrName
mc_fun = Located RdrName
Located (IdP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (LHsExpr GhcPs))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat
; LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
Match GhcPs (LHsExpr GhcPs)
match }
fromDecl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc decl :: SrcSpanLess (LHsDecl GhcPs)
decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a a. Outputable a => SrcSpan -> a -> P a
extraDeclErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl
extraDeclErr :: SrcSpan -> a -> P a
extraDeclErr loc :: SrcSpan
loc decl :: a
decl =
SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc
$$
a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl
wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr loc :: SrcSpan
loc decl :: HsDecl GhcPs
decl =
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "pattern synonym 'where' clause must bind the pattern synonym's name"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located RdrName)
RdrName
patsyn_name) SDoc -> SDoc -> SDoc
$$ HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDecl GhcPs
decl
wrongNumberErr :: AddAnn
wrongNumberErr loc :: SrcSpan
loc =
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanLess (Located RdrName)
RdrName
patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr loc :: SrcSpan
loc pat :: LPat GhcPs
pat =
SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
LPat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcPs
pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 :: Located RdrName
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 name :: Located RdrName
name mb_forall :: Maybe [LHsTyVarBndr GhcPs]
mb_forall mb_cxt :: Maybe (LHsContext GhcPs)
mb_cxt args :: HsConDeclDetails GhcPs
args
= ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = XConDeclH98 GhcPs
NoExt
noExt
, con_name :: Located (IdP GhcPs)
con_name = Located RdrName
Located (IdP GhcPs)
name
, con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr GhcPs]
mb_forall
, con_ex_tvs :: [LHsTyVarBndr GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr GhcPs]
mb_forall Maybe [LHsTyVarBndr GhcPs]
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. Maybe a -> a -> a
`orElse` []
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
, con_args :: HsConDeclDetails GhcPs
con_args = HsConDeclDetails GhcPs
args'
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
where
args' :: HsConDeclDetails GhcPs
args' = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
-> (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl names :: [Located RdrName]
names ty :: LHsType GhcPs
ty
= (ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> LHsQTyVars pass
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext = XConDeclGADT GhcPs
NoExt
noExt
, con_names :: [Located (IdP GhcPs)]
con_names = [Located RdrName]
[Located (IdP GhcPs)]
names
, con_forall :: Located Bool
con_forall = SrcSpan -> SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
ty'
, con_qvars :: LHsQTyVars GhcPs
con_qvars = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tvs
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
, con_args :: HsConDeclDetails GhcPs
con_args = HsConDeclDetails GhcPs
args'
, con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
, [AddAnn]
anns1 [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
anns2)
where
(ty' :: LHsType GhcPs
ty'@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l _),anns1 :: [AddAnn]
anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn])
forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType GhcPs
ty []
(tvs :: [LHsTyVarBndr GhcPs]
tvs, rho :: LHsType GhcPs
rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy LHsType GhcPs
ty'
(mcxt :: Maybe (LHsContext GhcPs)
mcxt, tau :: LHsType GhcPs
tau, anns2 :: [AddAnn]
anns2) = LHsType GhcPs
-> [AddAnn] -> (Maybe (LHsContext GhcPs), LHsType GhcPs, [AddAnn])
forall pass.
LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType GhcPs
rho []
split_rho :: LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann :: [AddAnn]
ann
= (LHsContext pass -> Maybe (LHsContext pass)
forall a. a -> Maybe a
Just LHsContext pass
cxt, LHsType pass
tau, [AddAnn]
ann)
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsParTy _ ty)) ann :: [AddAnn]
ann
= LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType pass
ty ([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
split_rho tau :: LHsType pass
tau ann :: [AddAnn]
ann
= (Maybe (LHsContext pass)
forall a. Maybe a
Nothing, LHsType pass
tau, [AddAnn]
ann)
(args :: HsConDeclDetails GhcPs
args, res_ty :: LHsType GhcPs
res_ty) = LHsType GhcPs -> (HsConDeclDetails GhcPs, LHsType GhcPs)
forall rec pass arg.
(HasSrcSpan rec, SrcSpanLess rec ~ [LConDeclField pass]) =>
LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau LHsType GhcPs
tau
args' :: HsConDeclDetails GhcPs
args' = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs HsConDeclDetails GhcPs
args
split_tau :: LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
= (rec -> HsConDetails arg rec
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan -> SrcSpanLess rec -> rec
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LConDeclField pass]
SrcSpanLess rec
rf), LHsType pass
res_ty)
split_tau tau :: LHsType pass
tau
= ([arg] -> HsConDetails arg rec
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [], LHsType pass
tau)
peel_parens :: LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsParTy _ ty)) ann :: [AddAnn]
ann = LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType pass
ty
([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
peel_parens ty :: LHsType pass
ty ann :: [AddAnn]
ann = (LHsType pass
ty, [AddAnn]
ann)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs details :: HsConDeclDetails GhcPs
details
= case HsConDeclDetails GhcPs
details of
PrefixCon as :: [LHsType GhcPs]
as -> [LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> LHsType GhcPs)
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
SrcSpanLess p ~ HsType pass) =>
p -> p
go [LHsType GhcPs]
as)
RecCon r :: Located [LConDeclField GhcPs]
r -> Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon Located [LConDeclField GhcPs]
r
InfixCon a1 :: LHsType GhcPs
a1 a2 :: LHsType GhcPs
a2 -> LHsType GhcPs -> LHsType GhcPs -> HsConDeclDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
SrcSpanLess p ~ HsType pass) =>
p -> p
go LHsType GhcPs
a1) (LHsType GhcPs -> LHsType GhcPs
forall p pass.
(HasSrcSpan p, XBangTy pass ~ NoExt, XDocTy pass ~ NoExt,
SrcSpanLess p ~ HsType pass) =>
p -> p
go LHsType GhcPs
a2)
where
go :: p -> p
go (p -> Located (SrcSpanLess p)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
SrcSpan -> SrcSpanLess p -> p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy pass
NoExt
noExt HsSrcBang
s (LHsType pass
-> LHsDocString -> SrcSpanLess (LHsType pass) -> LHsType pass
forall a b c.
(HasSrcSpan a, HasSrcSpan b, HasSrcSpan c) =>
a -> b -> SrcSpanLess c -> c
addCLoc LHsType pass
lty LHsDocString
lds (XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy XDocTy pass
NoExt
noExt LHsType pass
lty LHsDocString
lds)))
go lty :: p
lty = p
lty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual occ :: OccName
occ) ns :: NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual m :: ModuleName
m occ :: OccName
occ) ns :: NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig m :: Module
m occ :: OccName
occ) ns :: NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact n :: Name
n) ns :: NameSpace
ns
| Just thing :: TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
n
= TyThing -> NameSpace -> RdrName
setWiredInNameSpace TyThing
thing NameSpace
ns
| 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 tc :: TyCon
tc) ns :: NameSpace
ns
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= TyCon -> RdrName
ty_con_data_con TyCon
tc
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
setWiredInNameSpace (AConLike (RealDataCon dc :: DataCon
dc)) ns :: NameSpace
ns
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= DataCon -> RdrName
data_con_ty_con DataCon
dc
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
setWiredInNameSpace thing :: TyThing
thing ns :: NameSpace
ns
= String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic "setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con tc :: TyCon
tc
| TyCon -> Bool
isTupleTyCon TyCon
tc
, Just dc :: DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
listTyConKey
= Name -> RdrName
Exact Name
nilDataConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
srcDataName (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc))
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con dc :: DataCon
dc
| let tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
, TyCon -> Bool
isTupleTyCon TyCon
tc
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey
= Name -> RdrName
Exact Name
listTyConName
| Bool
otherwise
= 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 n :: Name
n)
| Just arity :: Int
arity <- Name -> Maybe Int
cTupleTyConNameArity_maybe Name
n
= Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ TupleSort -> Int -> Name
tupleTyConName TupleSort
BoxedTuple Int
arity
filterCTuple rdr :: RdrName
rdr = RdrName
rdr
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVarsP pp_what :: SDoc
pp_what equals_or_where :: SDoc
equals_or_where tc :: Located RdrName
tc tparms :: [LHsTypeArg GhcPs]
tparms
= do { let checkedTvs :: Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkedTvs = SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars SDoc
pp_what SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparms
; Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
-> P (LHsQTyVars GhcPs, [AddAnn])
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkedTvs }
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (loc :: SrcSpan
loc, doc :: SDoc
doc)) = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
doc
eitherToP (Right thing :: a
thing) = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return a
thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc)
( LHsQTyVars GhcPs
, [AddAnn] )
checkTyVars :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
checkTyVars pp_what :: SDoc
pp_what equals_or_where :: SDoc
equals_or_where tc :: Located RdrName
tc tparms :: [LHsTypeArg GhcPs]
tparms
= do { (tvs :: [LHsTyVarBndr GhcPs]
tvs, anns :: [[AddAnn]]
anns) <- ([(LHsTyVarBndr GhcPs, [AddAnn])]
-> ([LHsTyVarBndr GhcPs], [[AddAnn]]))
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
-> Either (SrcSpan, SDoc) ([LHsTyVarBndr GhcPs], [[AddAnn]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(LHsTyVarBndr GhcPs, [AddAnn])]
-> ([LHsTyVarBndr GhcPs], [[AddAnn]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
-> Either (SrcSpan, SDoc) ([LHsTyVarBndr GhcPs], [[AddAnn]]))
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
-> Either (SrcSpan, SDoc) ([LHsTyVarBndr GhcPs], [[AddAnn]])
forall a b. (a -> b) -> a -> b
$ (LHsTypeArg GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]))
-> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc) [(LHsTyVarBndr GhcPs, [AddAnn])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTypeArg GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
check [LHsTypeArg GhcPs]
tparms
; (LHsQTyVars GhcPs, [AddAnn])
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tvs, [[AddAnn]] -> [AddAnn]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AddAnn]]
anns) }
where
check :: LHsTypeArg GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
check (HsTypeArg _ ki :: LHsType GhcPs
ki@(L loc :: SrcSpan
loc _))
= (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan
loc,
[SDoc] -> SDoc
vcat [ String -> SDoc
text "Unexpected type application" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
, String -> SDoc
text "In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what SDoc -> SDoc -> SDoc
<+>
PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)])
check (HsValArg ty :: LHsType GhcPs
ty) = [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens [] LHsType GhcPs
ty
check (HsArgPar sp :: SrcSpan
sp) = (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan
sp, [SDoc] -> SDoc
vcat [String -> SDoc
text "Malformed" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)])
chkParens :: [AddAnn] -> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens :: [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens acc :: [AddAnn]
acc (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsParTy _ ty)) = [AddAnn]
-> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
chkParens (SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l
[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
acc) LHsType GhcPs
ty
chkParens acc :: [AddAnn]
acc ty :: LHsType GhcPs
ty = case LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk LHsType GhcPs
ty of
Left err :: (SrcSpan, SDoc)
err -> (SrcSpan, SDoc)
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
Right tv :: LHsTyVarBndr GhcPs
tv -> (LHsTyVarBndr GhcPs, [AddAnn])
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
forall a b. b -> Either a b
Right (LHsTyVarBndr GhcPs
tv, [AddAnn] -> [AddAnn]
forall a. [a] -> [a]
reverse [AddAnn]
acc)
chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
| RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv = LHsTyVarBndr GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
NoExt
noExt (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv SrcSpanLess (Located RdrName)
tv) LHsType GhcPs
k))
chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsTyVar _ _ (dL->L ltv tv)))
| RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv = LHsTyVarBndr GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
NoExt
noExt (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
ltv SrcSpanLess (Located RdrName)
tv)))
chk t :: LHsType GhcPs
t@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc _)
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc,
[SDoc] -> SDoc
vcat [ String -> SDoc
text "Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
, String -> SDoc
text "In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
, [SDoc] -> SDoc
vcat[ (String -> SDoc
text "A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "declaration should have form"))
, Int -> SDoc -> SDoc
nest 2
(SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> SDoc
tc'
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text ([LHsTypeArg GhcPs] -> [String] -> [String]
forall b a. [b] -> [a] -> [a]
takeList [LHsTypeArg GhcPs]
tparms [String]
allNameStrings))
SDoc -> SDoc -> SDoc
<+> SDoc
equals_or_where) ] ])
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 "where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text "= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just c :: LHsContext GhcPs
c)
= do Bool
allowed <- ExtBits -> P Bool
getBit ExtBits
DatatypeContextsBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc (LHsContext GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsContext GhcPs
c)
(String -> SDoc
text "Illegal datatype context (use DatatypeContexts):"
SDoc -> SDoc -> SDoc
<+> LHsContext GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
LHsContext (GhcPass p) -> SDoc
pprLHsContext LHsContext GhcPs
c)
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> LRuleBndr GhcPs)
-> [LRuleTyTmVar] -> [LRuleBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar v :: Located RdrName
v Nothing) = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr XCRuleBndr GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
v
cvt_one (RuleTyTmVar v :: Located RdrName
v (Just sig :: LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> LHsSigWcType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr GhcPs)
-> [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> HsTyVarBndr GhcPs)
-> LRuleTyTmVar -> LHsTyVarBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one (RuleTyTmVar v :: Located RdrName
v Nothing) = XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
NoExt
noExt ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v)
cvt_one (RuleTyTmVar v :: Located RdrName
v (Just sig :: LHsType GhcPs
sig))
= XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
NoExt
noExt ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v) LHsType GhcPs
sig
tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual occ :: OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
tm_to_ty _ = String -> RdrName
forall a. String -> a
panic "mkRuleTyVarBndrs"
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = (LHsTyVarBndr GhcPs -> P ()) -> [LHsTyVarBndr GhcPs] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Located RdrName -> P ()
forall a. (HasSrcSpan a, SrcSpanLess a ~ RdrName) => a -> P ()
check (Located RdrName -> P ())
-> (LHsTyVarBndr GhcPs -> Located RdrName)
-> LHsTyVarBndr GhcPs
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr GhcPs -> RdrName)
-> LHsTyVarBndr GhcPs -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr GhcPs -> RdrName
forall pass. HsTyVarBndr pass -> IdP pass
hsTyVarName)
where check :: a -> P ()
check (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Unqual occ)) = do
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` ["forall","family","role"])
(SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ "parse error on input "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
check _ = String -> P ()
forall a. String -> a
panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax :: Located a -> P (Located a)
checkRecordSyntax lr :: Located a
lr@(Located a -> Located (SrcSpanLess (Located a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc r :: SrcSpanLess (Located a)
r)
= do Bool
allowed <- ExtBits -> P Bool
getBit ExtBits
TraditionalRecordSyntaxBit
if Bool
allowed
then Located a -> P (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
lr
else SrcSpan -> SDoc -> P (Located a)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc
(String -> SDoc
text "Illegal record syntax (use TraditionalRecordSyntax):"
SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
SrcSpanLess (Located a)
r)
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts@(Located ([AddAnn], [LConDecl GhcPs])
-> Located (SrcSpanLess (Located ([AddAnn], [LConDecl GhcPs])))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L span :: SrcSpan
span (_, []))
= 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 "Illegal keyword 'where' in data declaration"
, String -> SDoc
text "Perhaps you intended to use GADTs or a similar language"
, String -> SDoc
text "extension to enable syntax: data T where"
]
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts = Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[AddAnn])
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr is_cls :: Bool
is_cls ty :: LHsType GhcPs
ty
= LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [] [] LexicalFixity
Prefix
where
goL :: LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l ty :: SrcSpanLess (LHsType GhcPs)
ty) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix = SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ty [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
go :: SrcSpan
-> HsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go lp :: SrcSpan
lp (HsParTy _ (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsStarTy _ isUni))) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix
= do { AddAnn
warnStarBndr SrcSpan
l
; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
; (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (OccName -> RdrName
Unqual OccName
name), [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp)) }
go l :: SrcSpan
l (HsTyVar _ _ (Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ tc :: SrcSpanLess (Located RdrName)
tc)) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
tc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, [AddAnn]
ann)
go _ (HsOpTy _ t1 :: LHsType GhcPs
t1 ltc :: Located (IdP GhcPs)
ltc@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ tc :: SrcSpanLess (Located RdrName)
tc) t2 :: LHsType GhcPs
t2) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann _fix :: LexicalFixity
_fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, [AddAnn]
ann)
go l :: SrcSpan
l (HsParTy _ ty :: LHsType GhcPs
ty) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l) LexicalFixity
fix
go _ (HsAppTy _ t1 :: LHsType GhcPs
t1 t2 :: LHsType GhcPs
t2) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
t1 (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go _ (HsAppKindTy l :: XAppKindTy GhcPs
l ty :: LHsType GhcPs
ty ki :: LHsType GhcPs
ki) acc :: [LHsTypeArg GhcPs]
acc ann :: [AddAnn]
ann fix :: LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go l :: SrcSpan
l (HsTupleTy _ HsBoxedOrConstraintTuple ts :: [LHsType GhcPs]
ts) [] ann :: [AddAnn]
ann fix :: LexicalFixity
fix
= (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (Name -> RdrName
nameRdrName Name
tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> [LHsTypeArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, [AddAnn]
ann)
where
arity :: Int
arity = [LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts
tup_name :: Name
tup_name | Bool
is_cls = Int -> Name
cTupleTyConName Int
arity
| Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
go l :: SrcSpan
l _ _ _ _
= SrcSpan
-> SDoc
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (String -> SDoc
text "Malformed head of type or class declaration:"
SDoc -> SDoc -> SDoc
<+> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ty)
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments expr :: LHsExpr GhcPs
expr = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
expr of
HsDo _ DoExpr _ -> String -> P ()
check "do block"
HsDo _ MDoExpr _ -> String -> P ()
check "mdo block"
HsLam {} -> String -> P ()
check "lambda expression"
HsCase {} -> String -> P ()
check "case expression"
HsLamCase {} -> String -> P ()
check "lambda-case expression"
HsLet {} -> String -> P ()
check "let expression"
HsIf {} -> String -> P ()
check "if expression"
HsProc {} -> String -> P ()
check "proc expression"
_ -> () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
check :: String -> P ()
check element :: String
element = do
Bool
blockArguments <- ExtBits -> P Bool
getBit ExtBits
BlockArgumentsBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
expr) (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "Unexpected " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text " in function application:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 (LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
expr)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "You could write it with parentheses"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "Or perhaps you meant to enable BlockArguments?"
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
checkContext (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l orig_t :: SrcSpanLess (LHsType GhcPs)
orig_t)
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [] (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t)
where
check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check anns :: [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lp :: SrcSpan
lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
= ([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 anns :: [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lp1 :: 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 _anns :: [AddAnn]
_anns t :: LHsType GhcPs
t = SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
t P ()
-> P ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t])
msg :: SDoc
msg = String -> SDoc
text "data constructor context"
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg :: SDoc
msg ty :: LHsType GhcPs
ty = LHsType GhcPs -> P ()
go LHsType GhcPs
ty
where
go :: LHsType GhcPs -> P ()
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsAppKindTy _ ty ki)) = LHsType GhcPs -> P ()
go LHsType GhcPs
ty P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
ki
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsAppTy _ t1 t2)) = LHsType GhcPs -> P ()
go LHsType GhcPs
t1 P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
t2
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
[ String -> SDoc
text "Unexpected haddock", SDoc -> SDoc
quotes (LHsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsDocString
ds)
, String -> SDoc
text "on", SDoc
msg, SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t) ]
go _ = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern msg :: SDoc
msg e :: LHsExpr GhcPs
e = SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns msg :: SDoc
msg es :: [LHsExpr GhcPs]
es = (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern SDoc
msg) [LHsExpr GhcPs]
es
checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat msg :: SDoc
msg e :: LHsExpr GhcPs
e@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l _) = SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat SDoc
msg SrcSpan
l LHsExpr GhcPs
e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat _ loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l e :: SrcSpanLess (LHsExpr GhcPs)
e@(HsVar _ (dL->L _ c))) args :: [LPat GhcPs]
args
| RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c = LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
c) ([LPat GhcPs] -> HsConPatDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LPat GhcPs]
args)))
| Bool -> Bool
not ([LPat GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec SrcSpanLess (Located RdrName)
RdrName
c =
SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail (String -> SDoc
text "Perhaps you intended to use RecursiveDo") SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e
checkPat msg :: SDoc
msg loc :: SrcSpan
loc e :: LHsExpr GhcPs
e args :: [LPat GhcPs]
args
| Just (e' :: LHsExpr GhcPs
e', args' :: [LHsExpr GhcPs]
args') <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang LHsExpr GhcPs
e
= do { [LPat GhcPs]
args'' <- SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns SDoc
msg [LHsExpr GhcPs]
args'
; SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat SDoc
msg SrcSpan
loc LHsExpr GhcPs
e' ([LPat GhcPs]
args'' [LPat GhcPs] -> [LPat GhcPs] -> [LPat GhcPs]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs]
args) }
checkPat msg :: SDoc
msg loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) args :: [LPat GhcPs]
args
= do LPat GhcPs
p <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs)
checkPat SDoc
msg SrcSpan
loc LHsExpr GhcPs
f (LPat GhcPs
p LPat GhcPs -> [LPat GhcPs] -> [LPat GhcPs]
forall a. a -> [a] -> [a]
: [LPat GhcPs]
args)
checkPat msg :: SDoc
msg loc :: SrcSpan
loc (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ e :: SrcSpanLess (LHsExpr GhcPs)
e) []
= do LPat GhcPs
p <- SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
checkAPat SDoc
msg SrcSpan
loc SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LPat GhcPs)
LPat GhcPs
p)
checkPat msg :: SDoc
msg loc :: SrcSpan
loc e :: LHsExpr GhcPs
e _
= SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
e)
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
checkAPat msg :: SDoc
msg loc :: SrcSpan
loc e0 :: HsExpr GhcPs
e0 = do
Bool
nPlusKPatterns <- ExtBits -> P Bool
getBit ExtBits
NPlusKPatternsBit
case HsExpr GhcPs
e0 of
EWildPat _ -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> LPat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExt
noExt)
HsVar _ x :: Located (IdP GhcPs)
x -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcPs
NoExt
noExt Located (IdP GhcPs)
x)
HsLit _ (HsStringPrim _ _)
-> SrcSpan -> SDoc -> P (LPat GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text "Illegal unboxed string literal in pattern:"
SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)
HsLit _ l :: HsLit GhcPs
l -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitPat GhcPs -> HsLit GhcPs -> LPat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcPs
NoExt
noExt HsLit GhcPs
l)
HsOverLit _ pos_lit :: HsOverLit GhcPs
pos_lit -> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> LPat GhcPs
mkNPat (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
pos_lit) Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing)
NegApp _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsOverLit _ pos_lit)) _
-> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> LPat GhcPs
mkNPat (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
pos_lit) (SyntaxExpr GhcPs -> Maybe (SyntaxExpr GhcPs)
forall a. a -> Maybe a
Just SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr))
SectionR _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lb :: SrcSpan
lb (HsVar _ (dL->L _ bang))) e :: LHsExpr GhcPs
e
| SrcSpanLess (Located RdrName)
RdrName
bang RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR
-> do { SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat SrcSpan
loc HsExpr GhcPs
e0
; LPat GhcPs
e' <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
; SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
loc AnnKeywordId
AnnBang SrcSpan
lb
; LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBangPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XBangPat p -> Pat p -> Pat p
BangPat XBangPat GhcPs
NoExt
noExt LPat GhcPs
e') }
ELazyPat _ e :: LHsExpr GhcPs
e -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XLazyPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XLazyPat p -> Pat p -> Pat p
LazyPat XLazyPat GhcPs
NoExt
noExt))
EAsPat _ n :: Located (IdP GhcPs)
n e :: LHsExpr GhcPs
e -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XAsPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs -> LPat GhcPs
forall p. XAsPat p -> Located (IdP p) -> Pat p -> Pat p
AsPat XAsPat GhcPs
NoExt
noExt) Located (IdP GhcPs)
n)
EViewPat _ expr :: LHsExpr GhcPs
expr patE :: LHsExpr GhcPs
patE -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
patE P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\p :: LPat GhcPs
p -> XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XViewPat p -> LHsExpr p -> Pat p -> Pat p
ViewPat XViewPat GhcPs
NoExt
noExt LHsExpr GhcPs
expr LPat GhcPs
p))
ExprWithTySig _ e :: LHsExpr GhcPs
e t :: LHsSigWcType (NoGhcTc GhcPs)
t -> do LPat GhcPs
e <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSigPat GhcPs
-> LPat GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> LPat GhcPs
forall p. XSigPat p -> Pat p -> LHsSigWcType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
NoExt
noExt LPat GhcPs
e LHsSigWcType (NoGhcTc GhcPs)
t)
OpApp _ (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L nloc :: SrcSpan
nloc (HsVar _ (dL->L _ n)))
(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsVar _ (dL->L _ plus)))
(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lloc :: SrcSpan
lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (SrcSpanLess (Located RdrName)
RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
-> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> Located (HsOverLit GhcPs) -> LPat GhcPs
mkNPlusKPat (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
nloc SrcSpanLess (Located RdrName)
n) (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lloc SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
lit))
OpApp _ l :: LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L cl :: SrcSpan
cl (HsVar _ (dL->L _ c))) r :: LHsExpr GhcPs
r
| OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
c) -> do
LPat GhcPs
l <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
l
LPat GhcPs
r <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
r
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
cl SrcSpanLess (Located RdrName)
c) (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
l LPat GhcPs
r))
OpApp {} -> SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc HsExpr GhcPs
e0
ExplicitList _ _ es :: [LHsExpr GhcPs]
es -> do [LPat GhcPs]
ps <- (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg) [LHsExpr GhcPs]
es
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XListPat GhcPs -> [LPat GhcPs] -> LPat GhcPs
forall p. XListPat p -> [Pat p] -> Pat p
ListPat XListPat GhcPs
NoExt
noExt [LPat GhcPs]
ps)
HsPar _ e :: LHsExpr GhcPs
e -> SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
e P (LPat GhcPs) -> (LPat GhcPs -> P (LPat GhcPs)) -> P (LPat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> P (LPat GhcPs))
-> (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> P (LPat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> Pat p -> Pat p
ParPat XParPat GhcPs
NoExt
noExt))
ExplicitTuple _ es :: [LHsTupArg GhcPs]
es b :: Boxity
b
| (LHsTupArg GhcPs -> Bool) -> [LHsTupArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcPs -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcPs]
es -> do [LPat GhcPs]
ps <- (LHsExpr GhcPs -> P (LPat GhcPs))
-> [LHsExpr GhcPs] -> P [LPat GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg)
[LHsExpr GhcPs
e | (LHsTupArg GhcPs -> Located (SrcSpanLess (LHsTupArg GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (Present _ e)) <- [LHsTupArg GhcPs]
es]
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> LPat GhcPs
forall p. XTuplePat p -> [Pat p] -> Boxity -> Pat p
TuplePat XTuplePat GhcPs
NoExt
noExt [LPat GhcPs]
ps Boxity
b)
| Bool
otherwise -> SrcSpan -> SDoc -> P (LPat GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc (String -> SDoc
text "Illegal tuple section in pattern:"
SDoc -> SDoc -> SDoc
$$ HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e0)
ExplicitSum _ alt :: Int
alt arity :: Int
arity expr :: LHsExpr GhcPs
expr -> do
LPat GhcPs
p <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg LHsExpr GhcPs
expr
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSumPat GhcPs -> LPat GhcPs -> Int -> Int -> LPat GhcPs
forall p. XSumPat p -> Pat p -> Int -> Int -> Pat p
SumPat XSumPat GhcPs
NoExt
noExt LPat GhcPs
p Int
alt Int
arity)
RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = Located (IdP GhcPs)
c, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecFields fs :: [LHsRecField GhcPs (LHsExpr GhcPs)]
fs dd :: Maybe Int
dd }
-> do [LHsRecField GhcPs (LPat GhcPs)]
fs <- (LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs)))
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> P [LHsRecField GhcPs (LPat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SDoc
-> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField SDoc
msg) [LHsRecField GhcPs (LHsExpr GhcPs)]
fs
LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcPs)
c (HsRecFields GhcPs (LPat GhcPs) -> HsConPatDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon ([LHsRecField GhcPs (LPat GhcPs)]
-> Maybe Int -> HsRecFields GhcPs (LPat GhcPs)
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields [LHsRecField GhcPs (LPat GhcPs)]
fs Maybe Int
dd)))
HsSpliceE _ s :: HsSplice GhcPs
s | Bool -> Bool
not (HsSplice GhcPs -> Bool
forall id. HsSplice id -> Bool
isTypedSplice HsSplice GhcPs
s)
-> LPat GhcPs -> P (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSplicePat GhcPs -> HsSplice GhcPs -> LPat GhcPs
forall p. XSplicePat p -> HsSplice p -> Pat p
SplicePat XSplicePat GhcPs
NoExt
noExt HsSplice GhcPs
s)
_ -> SDoc -> SrcSpan -> HsExpr GhcPs -> P (LPat GhcPs)
forall a. SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail SDoc
msg SrcSpan
loc HsExpr GhcPs
e0
placeHolderPunRhs :: LHsExpr GhcPs
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 "+")
bang_RDR :: RdrName
bang_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "!")
pun_RDR :: RdrName
pun_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "pun-right-hand-side")
isBangRdr :: RdrName -> Bool
isBangRdr :: RdrName -> Bool
isBangRdr (Unqual occ :: OccName
occ) = OccName -> FastString
occNameFS OccName
occ FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit "!"
isBangRdr _ = Bool
False
checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: SDoc
-> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField msg :: SDoc
msg (LHsRecField GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LHsRecField GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l fld :: SrcSpanLess (LHsRecField GhcPs (LHsExpr GhcPs))
fld) = do LPat GhcPs
p <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat SDoc
msg (HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs) -> LHsExpr GhcPs
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg SrcSpanLess (LHsRecField GhcPs (LHsExpr GhcPs))
HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
fld)
LHsRecField GhcPs (LPat GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LHsRecField GhcPs (LPat GhcPs))
-> LHsRecField GhcPs (LPat GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (LHsRecField GhcPs (LHsExpr GhcPs))
HsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)
fld { hsRecFieldArg :: LPat GhcPs
hsRecFieldArg = LPat GhcPs
p }))
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg :: SDoc
msg loc :: SrcSpan
loc e :: HsExpr GhcPs
e = SrcSpan -> SDoc -> P a
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
loc SDoc
err
where err :: SDoc
err = String -> SDoc
text "Parse error in pattern:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
SDoc -> SDoc -> SDoc
$$ SDoc
msg
patIsRec :: RdrName -> Bool
patIsRec :: RdrName -> Bool
patIsRec e :: RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "rec")
checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkValDef msg :: SDoc
msg _strictness :: SrcStrictness
_strictness lhs :: LHsExpr GhcPs
lhs (Just sig :: LHsType GhcPs
sig) grhss :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
= SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind SDoc
msg (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LHsExpr GhcPs -> LHsType GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
lhs LHsType GhcPs
sig)
(XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
NoExt
noExt LHsExpr GhcPs
lhs (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig))) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
checkValDef msg :: SDoc
msg strictness :: SrcStrictness
strictness lhs :: LHsExpr GhcPs
lhs Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g@(Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (_,grhss))
= do { Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_fun <- LHsExpr GhcPs
-> P (Maybe
(Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
isFunLhs LHsExpr GhcPs
lhs
; case Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
mb_fun of
Just (fun :: Located RdrName
fun, is_infix :: LexicalFixity
is_infix, pats :: [LHsExpr GhcPs]
pats, ann :: [AddAnn]
ann) ->
SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind SDoc
msg SrcStrictness
strictness [AddAnn]
ann (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
lhs)
Located RdrName
fun LexicalFixity
is_infix [LHsExpr GhcPs]
pats (SrcSpan
-> SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
GRHSs GhcPs (LHsExpr GhcPs)
grhss)
Nothing -> SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind SDoc
msg LHsExpr GhcPs
lhs Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g }
checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind msg :: SDoc
msg strictness :: SrcStrictness
strictness ann :: [AddAnn]
ann lhs_loc :: SrcSpan
lhs_loc fun :: Located RdrName
fun is_infix :: LexicalFixity
is_infix pats :: [LHsExpr GhcPs]
pats (Located (GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L rhs_span :: SrcSpan
rhs_span grhss :: SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
grhss)
= do [LPat GhcPs]
ps <- SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns SDoc
msg [LHsExpr GhcPs]
pats
let match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lhs_loc SrcSpan
rhs_span
([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 fn :: Located RdrName
fn ms :: [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
NoExt
noExt,
fun_id :: Located (IdP GhcPs)
fun_id = Located RdrName
Located (IdP GhcPs)
fn,
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms,
fun_co_fn :: HsWrapper
fun_co_fn = HsWrapper
idHsWrapper,
fun_tick :: [Tickish Id]
fun_tick = [] }
checkPatBind :: SDoc
-> LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind :: SDoc
-> LHsExpr GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind msg :: SDoc
msg lhs :: LHsExpr GhcPs
lhs (Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (_,grhss))
= do { LPat GhcPs
lhs <- SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern SDoc
msg LHsExpr GhcPs
lhs
; ([AddAnn], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([Tickish Id], [[Tickish Id]])
-> HsBind GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExt
noExt LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss
([],[])) }
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsVar _ lrdr@(dL->L _ v)))
| RdrName -> Bool
isUnqual SrcSpanLess (Located RdrName)
RdrName
v
, Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
v))
= Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
Located (IdP GhcPs)
lrdr
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l _)
= SrcSpan -> SDoc -> P (Located RdrName)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l ((String -> SDoc
text "Invalid type signature:" SDoc -> SDoc -> SDoc
<+>
LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text ":: ...")
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
hint)
where
hint :: String
hint | RdrName
IdP GhcPs
foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= "Perhaps you meant to use ForeignFunctionInterface?"
| RdrName
IdP GhcPs
default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= "Perhaps you meant to use DefaultSignatures?"
| RdrName
IdP GhcPs
pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= "Perhaps you meant to use PatternSynonyms?"
| Bool
otherwise
= "Should be of form <variable> :: <type>"
looks_like :: IdP p -> LHsExpr p -> Bool
looks_like s :: IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsVar _ (dL->L _ v))) = SrcSpanLess (Located (IdP p))
IdP p
v IdP p -> IdP p -> Bool
forall a. Eq a => a -> a -> Bool
== IdP p
s
looks_like s :: IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ lhs _)) = IdP p -> LHsExpr p -> Bool
looks_like IdP p
s LHsExpr p
lhs
looks_like _ _ = Bool
False
foreign_RDR :: RdrName
foreign_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "foreign")
default_RDR :: RdrName
default_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "default")
pattern_RDR :: RdrName
pattern_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit "pattern")
checkDoAndIfThenElse :: LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> P ()
checkDoAndIfThenElse :: LHsExpr GhcPs
-> Bool -> LHsExpr GhcPs -> Bool -> LHsExpr GhcPs -> P ()
checkDoAndIfThenElse guardExpr :: LHsExpr GhcPs
guardExpr semiThen :: Bool
semiThen thenExpr :: LHsExpr GhcPs
thenExpr semiElse :: Bool
semiElse elseExpr :: LHsExpr GhcPs
elseExpr
| Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse
= do Bool
doAndIfThenElse <- ExtBits -> P Bool
getBit ExtBits
DoAndIfThenElseBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ do
SrcSpan -> SDoc -> P ()
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc (LHsExpr GhcPs -> LHsExpr GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
guardExpr LHsExpr GhcPs
elseExpr)
(String -> SDoc
text "Unexpected semi-colons in conditional:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 SDoc
expr
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "Perhaps you meant to use DoAndIfThenElse?")
| Bool
otherwise = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where pprOptSemi :: Bool -> SDoc
pprOptSemi True = SDoc
semi
pprOptSemi False = SDoc
empty
expr :: SDoc
expr = String -> SDoc
text "if" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
guardExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiThen SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "then" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
thenExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiElse SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "else" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
elseExpr
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 _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg))
| SrcSpanLess (Located RdrName)
RdrName
op RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR = (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
l_arg, SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
NoExt
noExt LHsExpr GhcPs
bang LHsExpr GhcPs
arg1) LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
argns)
where
l' :: SrcSpan
l' = LHsExpr GhcPs -> LHsExpr GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
bang LHsExpr GhcPs
arg1
(arg1 :: LHsExpr GhcPs
arg1,argns :: [LHsExpr GhcPs]
argns) = LHsExpr GhcPs
-> [LHsExpr GhcPs] -> (LHsExpr GhcPs, [LHsExpr GhcPs])
forall p. LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang LHsExpr GhcPs
r_arg []
split_bang :: LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) es :: [LHsExpr p]
es = LHsExpr p -> [LHsExpr p] -> (LHsExpr p, [LHsExpr p])
split_bang LHsExpr p
f (LHsExpr p
eLHsExpr p -> [LHsExpr p] -> [LHsExpr p]
forall a. a -> [a] -> [a]
:[LHsExpr p]
es)
split_bang e :: LHsExpr p
e es :: [LHsExpr p]
es = (LHsExpr p
e,[LHsExpr p]
es)
splitBang _ = Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. Maybe a
Nothing
isFunLhs :: LHsExpr GhcPs
-> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
isFunLhs :: LHsExpr GhcPs
-> P (Maybe
(Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
isFunLhs e :: LHsExpr GhcPs
e = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe
(Located RdrName, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall a.
(HasSrcSpan a, SrcSpanLess a ~ RdrName) =>
LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e [] []
where
go :: LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (HsVar _ (dL->L _ f))) es :: [LHsExpr GhcPs]
es ann :: [AddAnn]
ann
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
f) = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
SrcSpanLess (Located RdrName)
f, LexicalFixity
Prefix, [LHsExpr GhcPs]
es, [AddAnn]
ann))
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsApp _ f e)) es :: [LHsExpr GhcPs]
es ann :: [AddAnn]
ann = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
f (LHsExpr GhcPs
eLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr GhcPs]
es) [AddAnn]
ann
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (HsPar _ e)) es :: [LHsExpr GhcPs]
es@(_:_) ann :: [AddAnn]
ann = LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e [LHsExpr GhcPs]
es ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
go (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang)))
(dL->L l (HsVar _ (L _ var))))) [] ann :: [AddAnn]
ann
| SrcSpanLess (Located RdrName)
RdrName
bang RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
bang_RDR
, Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
IdP GhcPs
var) = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
IdP GhcPs
var, LexicalFixity
Prefix, [], [AddAnn]
ann))
go e :: LHsExpr GhcPs
e@(L loc :: SrcSpan
loc (OpApp _ l :: LHsExpr GhcPs
l (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc' :: SrcSpan
loc' (HsVar _ (dL->L _ op))) r :: LHsExpr GhcPs
r)) es :: [LHsExpr GhcPs]
es ann :: [AddAnn]
ann
| Just (e' :: LHsExpr GhcPs
e',es' :: [LHsExpr GhcPs]
es') <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang LHsExpr GhcPs
e
= do { Bool
bang_on <- ExtBits -> P Bool
getBit ExtBits
BangPatBit
; if Bool
bang_on then LHsExpr GhcPs
-> [LHsExpr GhcPs]
-> [AddAnn]
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
go LHsExpr GhcPs
e' ([LHsExpr GhcPs]
es' [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs]
es) [AddAnn]
ann
else Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess a
SrcSpanLess (Located RdrName)
op, LexicalFixity
Infix, (LHsExpr GhcPs
lLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:LHsExpr GhcPs
rLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr GhcPs]
es), [AddAnn]
ann)) }
| 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 (op' :: a
op', Infix, j :: LHsExpr GhcPs
j : k :: LHsExpr GhcPs
k : es' :: [LHsExpr GhcPs]
es', ann' :: [AddAnn]
ann')
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. a -> Maybe a
Just (a
op', LexicalFixity
Infix, LHsExpr GhcPs
j LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: LHsExpr GhcPs
op_app LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
es', [AddAnn]
ann'))
where
op_app :: LHsExpr GhcPs
op_app = SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
NoExt
noExt LHsExpr GhcPs
k
(SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess (Located RdrName)
op))) LHsExpr GhcPs
r)
_ -> Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. Maybe a
Nothing }
go _ _ _ = Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
-> P (Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [LHsExpr GhcPs], [AddAnn])
forall a. Maybe a
Nothing
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 name :: RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
ppr (TyElOpd ty :: HsType GhcPs
ty) = HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcPs
ty
ppr (TyElKindApp _ ki :: LHsType GhcPs
ki) = String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
ppr TyElTilde = String -> SDoc
text "~"
ppr TyElBang = String -> SDoc
text "!"
ppr (TyElUnpackedness (_, _, unpk :: SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
ppr (TyElDocPrev doc :: HsDocString
doc) = HsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDocString
doc
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness TyElTilde = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnTilde, SrcStrictness
SrcLazy)
tyElStrictness TyElBang = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnBang, SrcStrictness
SrcStrict)
tyElStrictness _ = Maybe (AnnKeywordId, SrcStrictness)
forall a. Maybe a
Nothing
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 l1 :: SrcSpan
l1 x1 :: SrcSpanLess (Located TyEl)
x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l2 :: SrcSpan
l2 x2 :: SrcSpanLess (Located TyEl)
x2) : xs :: [Located TyEl]
xs)
| Just (strAnnId :: AnnKeywordId
strAnnId, str :: SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
, TyElUnpackedness (unpkAnns, prag, unpk) <- SrcSpanLess (Located TyEl)
x2
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
str)
, [AddAnn]
unpkAnns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [\s :: SrcSpan
s -> SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
s AnnKeywordId
strAnnId SrcSpan
l1]
, [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x1 :: SrcSpanLess (Located TyEl)
x1) : xs :: [Located TyEl]
xs)
| Just (strAnnId :: AnnKeywordId
strAnnId, str :: SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
str)
, [\s :: SrcSpan
s -> SrcSpan -> AnnKeywordId -> AddAnn
addAnnotation SrcSpan
s AnnKeywordId
strAnnId SrcSpan
l]
, [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x1 :: SrcSpanLess (Located TyEl)
x1) : xs :: [Located TyEl]
xs)
| TyElUnpackedness (anns, prag, unpk) <- SrcSpanLess (Located TyEl)
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
, [AddAnn]
anns
, [Located TyEl]
xs )
pStrictMark _ = Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. Maybe a
Nothing
pBangTy
:: LHsType GhcPs
-> [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 l1 :: SrcSpan
l1 _) xs :: [Located TyEl]
xs =
case [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark [Located TyEl]
xs of
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
Just (Located HsSrcBang -> Located (SrcSpanLess (Located HsSrcBang))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l2 :: SrcSpan
l2 strictMark :: SrcSpanLess (Located HsSrcBang)
strictMark, anns :: [AddAnn]
anns, xs' :: [Located TyEl]
xs') ->
let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
bt :: HsType GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExt
noExt SrcSpanLess (Located HsSrcBang)
HsSrcBang
strictMark LHsType GhcPs
lt
in (Bool
True, SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bl SrcSpanLess (LHsType GhcPs)
HsType GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
bl [AddAnn]
anns, [Located TyEl]
xs')
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l1 :: SrcSpan
l1 (TyElOpd t)) : xs :: [Located TyEl]
xs)
| (_, t' :: LHsType GhcPs
t', addAnns :: P ()
addAnns, xs' :: [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
HsType GhcPs
t) [Located TyEl]
xs
, [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs'
= P ()
addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
t'
mergeOps all_xs :: [Located TyEl]
all_xs = Int
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
forall a t.
(HasSrcSpan a, Num t, Ord t, SrcSpanLess a ~ TyEl) =>
t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (0 :: Int) [] LHsType GhcPs -> LHsType GhcPs
forall a. a -> a
id [Located TyEl]
all_xs
where
go :: t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElUnpackedness (anns, unpkSrc, unpk))):xs :: [a]
xs) =
if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
then do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs))
-> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc
; let a :: LHsType GhcPs
a = LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc'
strictMark :: HsSrcBang
strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
unpkSrc SrcUnpackedness
unpk SrcStrictness
NoSrcStrict
bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l (LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
a)
bt :: HsType GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExt
noExt HsSrcBang
strictMark LHsType GhcPs
a
; SrcSpan -> [AddAnn] -> P ()
addAnnsAt SrcSpan
bl [AddAnn]
anns
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bl SrcSpanLess (LHsType GhcPs)
HsType GhcPs
bt) }
else SrcSpan -> SDoc -> P (LHsType GhcPs)
forall a. SrcSpan -> SDoc -> P a
parseErrorSDoc SrcSpan
l SDoc
unpkError
where
unpkSDoc :: SDoc
unpkSDoc = case SourceText
unpkSrc of
NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
SourceText str :: String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text " #-}"
unpkError :: SDoc
unpkError
| Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "cannot appear inside a type."
| [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
&& t
k t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "must be applied to a type."
| Bool
otherwise =
String -> SDoc
forall a. String -> a
panic "mergeOps.UNPACK: impossible position"
go _ _ _ ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElDocPrev _)):_) =
SrcSpan -> P (LHsType GhcPs)
forall a. SrcSpan -> P a
failOpDocPrev SrcSpan
l
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l x :: SrcSpanLess a
x) : xs :: [a]
xs)
| Just (_, str :: SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess a
TyEl
x
, let guess :: [a] -> Bool
guess [] = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElOpd _)):_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElOpr _)):_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElKindApp _ _)):_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SrcSpanLess a
TyElTilde)):_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (SrcSpanLess a
TyElBang)):_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElUnpackedness _)):_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElDocPrev _)):xs' :: [a]
xs') = [a] -> Bool
guess [a]
xs'
guess _ = String -> Bool
forall a. String -> a
panic "mergeOps.go.guess: Impossible Match"
in [a] -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => [a] -> Bool
guess [a]
xs
= if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& (t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
|| [LHsTypeArg GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTypeArg GhcPs]
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1)
then do { LHsType GhcPs
a <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; Located SrcStrictness -> LHsType GhcPs -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
a) }
else Located SrcStrictness -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> P a
failOpStrictnessPosition (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str)
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpr op)):xs :: [a]
xs) =
if [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
|| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => a -> Bool
isTyElOpd [a]
xs)
then Located RdrName -> P (LHsType GhcPs)
forall a. Located RdrName -> P a
failOpFewArgs (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op)
else do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ 1) [] (\c :: LHsType GhcPs
c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
c (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc')) [a]
xs }
where
isTyElOpd :: a -> Bool
isTyElOpd (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElOpd _)) = Bool
True
isTyElOpd _ = Bool
False
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l TyElTilde):xs :: [a]
xs) =
let op :: RdrName
op = RdrName
eqTyCon_RDR
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l TyElBang):xs :: [a]
xs) =
let op :: RdrName
op = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
tcClsName (String -> FastString
fsLit "!")
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (TyElOpd a)):xs :: [a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsType GhcPs
a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go k :: t
k acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyElKindApp l a)):xs :: [a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go _ acc :: [LHsTypeArg GhcPs]
acc ops_acc :: LHsType GhcPs -> LHsType GhcPs
ops_acc [] = do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc') }
go _ _ _ _ = String -> P (LHsType GhcPs)
forall a. String -> a
panic "mergeOps.go: Impossible Match"
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAc