{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Parser.PostProcess (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl, mkLHsSigType,
mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
filterCTuple,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
checkImportDecl,
checkExpBlockArguments, checkCmdBlockArguments,
checkPrecP,
checkContext,
checkPattern,
checkPattern_msg,
checkMonadComp,
checkValDef,
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
mkBangTy,
mkMultTy,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
forallSym,
starSym,
warnStarIsType,
warnPrepositiveQualifiedModule,
failOpFewArgs,
failOpNotEnabledImportQualifiedPost,
failOpImportQualifiedTwice,
SumOrTuple (..),
PV,
runPV,
ECP(ECP, runECP_PV),
runECP_P,
DisambInfixOp(..),
DisambECP(..),
ecpFromExp,
ecpFromCmd,
PatBuilder
) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon )
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Parser.Lexer
import GHC.Utils.Lexeme ( isLexCon )
import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey, eqTyCon_RDR,
tupleTyConName, cTupleTyConNameArity_maybe )
import GHC.Types.ForeignCall
import GHC.Builtin.Names ( allNameStrings )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList ( OrdList, fromOL )
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Parser.Annotation
import Data.List
import GHC.Driver.Session ( WarningFlag(..), DynFlags )
import GHC.Utils.Error ( Messages )
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
import Data.Kind ( Type )
#include "HsVersions.h"
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: forall (p :: Pass). LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L SrcSpan
loc TyClDecl (GhcPass p)
d) = SrcSpan
-> HsDecl (GhcPass p) -> GenLocated SrcSpan (HsDecl (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
XTyClD (GhcPass p)
noExtField TyClDecl (GhcPass p)
d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: forall (p :: Pass). LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L SrcSpan
loc InstDecl (GhcPass p)
d) = SrcSpan
-> HsDecl (GhcPass p) -> GenLocated SrcSpan (HsDecl (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
XInstD (GhcPass p)
noExtField InstDecl (GhcPass p)
d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> P (LTyClDecl GhcPs)
mkClassDecl :: forall a.
SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls LayoutInfo
layoutInfo
= do { (LHsBinds GhcPs
binds, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
ats, [LTyFamInstDecl GhcPs]
at_defs, [LDataFamInstDecl GhcPs]
_, [LDocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs
forall e. e -> Located e
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; (Located RdrName
cls, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars,[AddAnn]
annst) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text String
"class") SDoc
whereDots Located RdrName
cls [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
annst
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = LayoutInfo
XClassDecl GhcPs
layoutInfo
, tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = (a, [Located (FunDep (Located RdrName))])
-> [Located (FunDep (Located RdrName))]
forall a b. (a, b) -> b
snd (GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))])
-> (a, [Located (FunDep (Located RdrName))])
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (a, [Located (FunDep (Located RdrName))])
Located (a, [LHsFunDep GhcPs])
fds)
, tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [LSig GhcPs]
sigs
, tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
binds
, tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs
, tcdDocs :: [LDocDecl]
tcdDocs = [LDocDecl]
docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (L SrcSpan
_ (Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tycl_hdr))
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (NewOrData -> SDoc
forall a. Outputable a => a -> SDoc
ppr NewOrData
new_or_data) SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = NoExtField
XDataDecl GhcPs
noExtField,
tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([LHsType GhcPs] -> LHsContext GhcPs
forall e. e -> Located e
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
, dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
cxt
, dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
data_cons
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> P (LTyClDecl GhcPs)
mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs)
mkTySynonym SrcSpan
loc LHsType GhcPs
lhs LHsType GhcPs
rhs
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (String -> SDoc
text String
"type") SDoc
equalsDots Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = NoExtField
XSynDecl GhcPs
noExtField
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [Located RdrName]
-> LHsKind GhcPs
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig :: SrcSpan
-> Located [Located RdrName]
-> LHsType GhcPs
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig SrcSpan
loc Located [Located RdrName]
lhs LHsType GhcPs
rhs =
do { [Located RdrName]
vs <- (Located RdrName -> P (Located RdrName))
-> [Located RdrName] -> P [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located RdrName -> P (Located RdrName)
forall {m :: * -> *}.
MonadP m =>
Located RdrName -> m (Located RdrName)
check_lhs_name (Located [Located RdrName] -> [Located RdrName]
forall l e. GenLocated l e -> e
unLoc Located [Located RdrName]
lhs)
; Located RdrName
v <- [Located RdrName] -> P (Located RdrName)
check_singular_lhs ([Located RdrName] -> [Located RdrName]
forall a. [a] -> [a]
reverse [Located RdrName]
vs)
; LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs))
-> LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs)
-> StandaloneKindSig GhcPs -> LStandaloneKindSig GhcPs
forall a b. (a -> b) -> a -> b
$ XStandaloneKindSig GhcPs
-> Located (IdP GhcPs)
-> LHsSigType GhcPs
-> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
XStandaloneKindSig GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
rhs) }
where
check_lhs_name :: Located RdrName -> m (Located RdrName)
check_lhs_name v :: Located RdrName
v@(Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc->RdrName
name) =
if RdrName -> Bool
isUnqual RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc RdrName
name)
then Located RdrName -> m (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
v
else SrcSpan -> SDoc -> m (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
v) (SDoc -> m (Located RdrName)) -> SDoc -> m (Located RdrName)
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Expected an unqualified type constructor:") Int
2 (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
v)
check_singular_lhs :: [Located RdrName] -> P (Located RdrName)
check_singular_lhs [Located RdrName]
vs =
case [Located RdrName]
vs of
[] -> String -> P (Located RdrName)
forall a. String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
[Located RdrName
v] -> Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
v
[Located RdrName]
_ -> SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located [Located RdrName] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [Located RdrName]
lhs) (SDoc -> P (Located RdrName)) -> SDoc -> P (Located RdrName)
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Standalone kind signatures do not support multiple names at the moment:")
Int
2 ((Located RdrName -> SDoc) -> [Located RdrName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located RdrName]
vs)
, String -> SDoc
text String
"See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs, [AddAnn])
mkTyFamInstEqn Maybe [LHsTyVarBndr () GhcPs]
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs)
feqn_ext = NoExtField
XCFamEqn GhcPs (LHsType GhcPs)
noExtField
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr () GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: LHsType GhcPs
feqn_rhs = LHsType GhcPs
rhs }),
[AddAnn]
ann) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs]
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs],
LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Maybe (LHsContext GhcPs)
mcxt, Maybe [LHsTyVarBndr () GhcPs]
bndrs, LHsType GhcPs
tycl_hdr)
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD NoExtField
XDataFamInstD GhcPs
noExtField (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl (FamEqn GhcPs (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = NoExtField
XCFamEqn GhcPs (HsDataDefn GhcPs)
noExtField
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr () GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn }))))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn
= LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> InstDecl GhcPs -> LInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD NoExtField
XTyFamInstD GhcPs
noExtField (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl SrcSpan
loc FamilyInfo GhcPs
info LHsType GhcPs
lhs Located (FamilyResultSig GhcPs)
ksig Maybe (LInjectivityAnn GhcPs)
injAnn
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (LHsQTyVars GhcPs
tyvars, [AddAnn]
anns) <- SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars (FamilyInfo GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamilyInfo GhcPs
info) SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparams
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
anns
; LTyClDecl GhcPs -> P (LTyClDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TyClDecl GhcPs -> LTyClDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcPs
noExtField (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl
{ fdExt :: XCFamilyDecl GhcPs
fdExt = NoExtField
XCFamilyDecl GhcPs
noExtField
, fdInfo :: FamilyInfo GhcPs
fdInfo = FamilyInfo GhcPs
info, fdLName :: Located (IdP GhcPs)
fdLName = Located RdrName
Located (IdP GhcPs)
tc
, fdTyVars :: LHsQTyVars GhcPs
fdTyVars = LHsQTyVars GhcPs
tyvars
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdResultSig :: Located (FamilyResultSig GhcPs)
fdResultSig = Located (FamilyResultSig GhcPs)
ksig
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injAnn }))) }
where
equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
FamilyInfo GhcPs
DataFamily -> SDoc
empty
FamilyInfo GhcPs
OpenTypeFamily -> SDoc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(L SrcSpan
loc HsExpr GhcPs
expr)
| HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsUntypedSplice {}) <- HsExpr GhcPs
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| HsSpliceE XSpliceE GhcPs
_ splice :: HsSplice GhcPs
splice@(HsQuasiQuote {}) <- HsExpr GhcPs
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| Bool
otherwise
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD NoExtField
XSpliceD GhcPs
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl NoExtField
XSpliceDecl GhcPs
noExtField (SrcSpan -> HsSplice GhcPs -> Located (HsSplice GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice SpliceDecoration
BareSplice LHsExpr GhcPs
lexpr))
SpliceExplicitFlag
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc Located RdrName
tycon [Located (Maybe FastString)]
roles
= do { [GenLocated SrcSpan (Maybe Role)]
roles' <- (Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role)))
-> [Located (Maybe FastString)]
-> P [GenLocated SrcSpan (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs))
-> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs)
-> RoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [GenLocated SrcSpan (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [GenLocated SrcSpan (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
XCRoleAnnotDecl GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
tycon [GenLocated SrcSpan (Maybe Role)]
roles' }
where
role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]
parse_role :: Located (Maybe FastString) -> P (GenLocated SrcSpan (Maybe Role))
parse_role (L SrcSpan
loc_role Maybe FastString
Nothing) = GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role)))
-> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc_role Maybe Role
forall a. Maybe a
Nothing
parse_role (L SrcSpan
loc_role (Just FastString
role))
= case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
Just Role
found_role -> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role)))
-> GenLocated SrcSpan (Maybe Role)
-> P (GenLocated SrcSpan (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc_role (Maybe Role -> GenLocated SrcSpan (Maybe Role))
-> Maybe Role -> GenLocated SrcSpan (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
Maybe Role
Nothing ->
let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
SrcSpan -> SDoc -> P (GenLocated SrcSpan (Maybe Role))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc_role
(String -> SDoc
text String
"Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
[Role] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)
suggestions :: [a] -> SDoc
suggestions [] = SDoc
empty
suggestions [a
r] = String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r)
suggestions [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Perhaps you meant one of these:")
Int
2 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [a]
list)
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs = (LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs))
-> [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr LHsTyVarBndr Specificity GhcPs
bndr = case LHsTyVarBndr Specificity GhcPs
bndr of
(L SrcSpan
loc (UserTyVar XUserTyVar GhcPs
xtv Specificity
flag Located (IdP GhcPs)
idp)) -> (Specificity -> SrcSpan -> P ()
check_spec Specificity
flag SrcSpan
loc)
P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs)
-> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
xtv () Located (IdP GhcPs)
idp)
(L SrcSpan
loc (KindedTyVar XKindedTyVar GhcPs
xtv Specificity
flag Located (IdP GhcPs)
idp LHsType GhcPs
k)) -> (Specificity -> SrcSpan -> P ()
check_spec Specificity
flag SrcSpan
loc)
P () -> P (LHsTyVarBndr () GhcPs) -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs)
-> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
xtv () Located (IdP GhcPs)
idp LHsType GhcPs
k)
where
check_spec :: Specificity -> SrcSpan -> P ()
check_spec :: Specificity -> SrcSpan -> P ()
check_spec Specificity
SpecifiedSpec SrcSpan
_ = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_spec Specificity
InferredSpec SrcSpan
loc = SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc
(String -> SDoc
text String
"Inferred type variables are not allowed here")
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup OrdList (LHsDecl GhcPs)
binding
= do { (LHsBinds GhcPs
mbs, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
fam_ds, [LTyFamInstDecl GhcPs]
tfam_insts
, [LDataFamInstDecl GhcPs]
dfam_insts, [LDocDecl]
_) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBinds GhcPs -> P (HsValBinds GhcPs))
-> HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBinds GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds NoExtField
XValBinds GhcPs GhcPs
noExtField LHsBinds GhcPs
mbs [LSig GhcPs]
sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
fb = do
[LHsDecl GhcPs]
fb' <- [LHsDecl GhcPs] -> P [LHsDecl GhcPs]
forall {f :: * -> *} {p}.
(MonadP f, Outputable (SpliceDecl p)) =>
[GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
drop_bad_decls (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
fb)
(LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsDecl GhcPs]
-> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
partitionBindsAndSigs ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
fb'))
where
drop_bad_decls :: [GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
drop_bad_decls [] = [GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
drop_bad_decls (L SrcSpan
l (SpliceD XSpliceD p
_ SpliceDecl p
d) : [GenLocated SrcSpan (HsDecl p)]
ds) = do
SrcSpan -> SDoc -> f ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> f ()) -> SDoc -> f ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"at the top level:")
Int
2 (SpliceDecl p -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl p
d)
[GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
drop_bad_decls [GenLocated SrcSpan (HsDecl p)]
ds
drop_bad_decls (GenLocated SrcSpan (HsDecl p)
d:[GenLocated SrcSpan (HsDecl p)]
ds) = (GenLocated SrcSpan (HsDecl p)
dGenLocated SrcSpan (HsDecl p)
-> [GenLocated SrcSpan (HsDecl p)]
-> [GenLocated SrcSpan (HsDecl p)]
forall a. a -> [a] -> [a]
:) ([GenLocated SrcSpan (HsDecl p)]
-> [GenLocated SrcSpan (HsDecl p)])
-> f [GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated SrcSpan (HsDecl p)]
-> f [GenLocated SrcSpan (HsDecl p)]
drop_bad_decls [GenLocated SrcSpan (HsDecl p)]
ds
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (L SrcSpan
loc1 (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = fun_id1 :: Located (IdP GhcPs)
fun_id1@(L SrcSpan
_ IdP GhcPs
f1)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1) } }))
[LHsDecl GhcPs]
binds
| [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1
= [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs1 SrcSpan
loc1 [LHsDecl GhcPs]
binds []
where
go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc
((L SrcSpan
loc2 (ValD XValD GhcPs
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = (L SrcSpan
_ IdP GhcPs
f2)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs2) } })))
: [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
| RdrName
IdP GhcPs
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
IdP GhcPs
f2 = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go ([LMatch GhcPs (LHsExpr GhcPs)]
mtchs2 [LMatch GhcPs (LHsExpr GhcPs)]
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
(SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds []
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(L SrcSpan
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
= let doc_decls' :: [LHsDecl GhcPs]
doc_decls' = LHsDecl GhcPs
doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls'
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
= ( SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
, ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
getMonoBind LHsBind GhcPs
bind [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [] = []
getMonoBindAll (L SrcSpan
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
b) : [LHsDecl GhcPs]
ds) =
let (L SrcSpan
l' HsBindLR GhcPs GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsBindLR GhcPs GhcPs
b) [LHsDecl GhcPs]
ds
in SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l' (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
noExtField HsBindLR GhcPs GhcPs
b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds'
getMonoBindAll (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [LHsDecl GhcPs]
ds
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = String -> Bool
forall a. String -> a
panic String
"GHC.Parser.PostProcess.has_args"
has_args (L SrcSpan
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcPs]
args }) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
loc RdrName
tc
| OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
|| OccName -> Bool
isDataOcc OccName
occ
, FastString -> Bool
isLexCon (OccName -> FastString
occNameFS OccName
occ)
= Located RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))
| Bool
otherwise
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
msg)
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
msg :: SDoc
msg = String -> SDoc
text String
"Not a data constructor:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L SrcSpan
loc RdrName
patsyn_name) (L SrcSpan
_ OrdList (LHsDecl GhcPs)
decls) =
do { [LMatch GhcPs (LHsExpr GhcPs)]
matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
matches) (SrcSpan -> P ()
wrongNumberErr SrcSpan
loc)
; MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs)))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
matches }
where
fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (L SrcSpan
loc decl :: HsDecl GhcPs
decl@(ValD XValD GhcPs
_ (PatBind XPatBind GhcPs GhcPs
_
pat :: LPat GhcPs
pat@(L SrcSpan
_ (ConPat NoExtField
XConPat GhcPs
NoExtField ln :: Located (ConLikeP GhcPs)
ln@(L SrcSpan
_ ConLikeP GhcPs
name) HsConPatDetails GhcPs
details))
GRHSs GhcPs (LHsExpr GhcPs)
rhs ([Tickish Id], [[Tickish Id]])
_))) =
do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName
ConLikeP GhcPs
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl
; Match GhcPs (LHsExpr GhcPs)
match <- case HsConPatDetails GhcPs
details of
PrefixCon [LPat GhcPs]
pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext GhcPs
ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun = Located (IdP GhcPs)
Located (ConLikeP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
InfixCon LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt
, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs
p1, LPat GhcPs
p2]
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext GhcPs
ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun = Located (IdP GhcPs)
Located (ConLikeP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (LHsExpr GhcPs))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat
; LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Match GhcPs (LHsExpr GhcPs)
match }
fromDecl (L SrcSpan
loc HsDecl GhcPs
decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
forall {m :: * -> *} {a} {a}.
(MonadP m, Outputable a) =>
SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc HsDecl GhcPs
decl
extraDeclErr :: SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc a
decl =
SrcSpan -> SDoc -> m a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> m a) -> SDoc -> m a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc
$$
a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl
wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause must bind the pattern synonym's name"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
patsyn_name) SDoc -> SDoc -> SDoc
$$ HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDecl GhcPs
decl
wrongNumberErr :: SrcSpan -> P ()
wrongNumberErr SrcSpan
loc =
SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName
patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
Located (Pat GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (Pat GhcPs)
LPat GhcPs
pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 :: Located RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
name Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
args
= ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = NoExtField
XConDeclH98 GhcPs
noExtField
, con_name :: Located (IdP GhcPs)
con_name = Located RdrName
Located (IdP GhcPs)
name
, con_forall :: Located Bool
con_forall = Bool -> Located Bool
forall e. e -> Located e
noLoc (Bool -> Located Bool) -> Bool -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall
, con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr Specificity GhcPs]
mb_forall Maybe [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall a. Maybe a -> a -> a
`orElse` []
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
, con_args :: HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
con_args = HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
args
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
-> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
names LHsType GhcPs
ty = do
let (HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
args, LHsType GhcPs
res_ty, [AddAnn]
anns)
| L SrcSpan
_ (HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
_w (L SrcSpan
loc (HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
rf)) LHsType GhcPs
res_ty) <- LHsType GhcPs
body_ty
= (GenLocated SrcSpan [LConDeclField GhcPs]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> [LConDeclField GhcPs]
-> GenLocated SrcSpan [LConDeclField GhcPs]
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc [LConDeclField GhcPs]
rf), LHsType GhcPs
res_ty, [])
| Bool
otherwise
= let ([HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type, [AddAnn]
anns) = LHsType GhcPs
-> ([HsScaled GhcPs (LHsType GhcPs)], LHsType GhcPs, [AddAnn])
forall (p :: Pass).
LHsType (GhcPass p)
-> ([HsScaled (GhcPass p) (LHsType (GhcPass p))],
LHsType (GhcPass p), [AddAnn])
splitHsFunType LHsType GhcPs
body_ty
in ([HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [HsScaled GhcPs (LHsType GhcPs)]
arg_types, LHsType GhcPs
res_type, [AddAnn]
anns)
(ConDecl GhcPs, [AddAnn]) -> P (ConDecl GhcPs, [AddAnn])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext = NoExtField
XConDeclGADT GhcPs
noExtField
, con_names :: [Located (IdP GhcPs)]
con_names = [Located RdrName]
[Located (IdP GhcPs)]
names
, con_forall :: Located Bool
con_forall = SrcSpan -> Bool -> Located Bool
forall l e. l -> e -> GenLocated l e
L (LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
ty) (Bool -> Located Bool) -> Bool -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr Specificity GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs
, con_qvars :: [LHsTyVarBndr Specificity GhcPs]
con_qvars = [LHsTyVarBndr Specificity GhcPs]
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
, con_args :: HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
con_args = HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
args
, con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
, [AddAnn]
anns )
where
(Maybe [LHsTyVarBndr Specificity GhcPs]
mtvs, Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
body_ty) = LHsType GhcPs
-> (Maybe [LHsTyVarBndr Specificity GhcPs],
Maybe (LHsContext GhcPs), LHsType GhcPs)
forall pass.
LHsType pass
-> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass),
LHsType pass)
splitLHsGadtTy LHsType GhcPs
ty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual OccName
occ) NameSpace
ns = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Qual ModuleName
m OccName
occ) NameSpace
ns = ModuleName -> OccName -> RdrName
Qual ModuleName
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Orig Module
m OccName
occ) NameSpace
ns = Module -> OccName -> RdrName
Orig Module
m (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns OccName
occ)
setRdrNameSpace (Exact Name
n) NameSpace
ns
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
n
= TyThing -> NameSpace -> RdrName
setWiredInNameSpace TyThing
thing NameSpace
ns
| Name -> Bool
isExternalName Name
n
= Module -> OccName -> RdrName
Orig (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n) OccName
occ
| Bool
otherwise
= Name -> RdrName
Exact (Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt (Name -> Unique
nameUnique Name
n) OccName
occ (Name -> SrcSpan
nameSrcSpan Name
n))
where
occ :: OccName
occ = NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
ns (Name -> OccName
nameOccName Name
n)
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon TyCon
tc) NameSpace
ns
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= TyCon -> RdrName
ty_con_data_con TyCon
tc
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
setWiredInNameSpace (AConLike (RealDataCon DataCon
dc)) NameSpace
ns
| NameSpace -> Bool
isTcClsNameSpace NameSpace
ns
= DataCon -> RdrName
data_con_ty_con DataCon
dc
| NameSpace -> Bool
isDataConNameSpace NameSpace
ns
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
setWiredInNameSpace TyThing
thing NameSpace
ns
= String -> SDoc -> RdrName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setWiredinNameSpace" (NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con TyCon
tc
| TyCon -> Bool
isTupleTyCon TyCon
tc
, Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
= Name -> RdrName
Exact (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc)
| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
listTyConKey
= Name -> RdrName
Exact Name
nilDataConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
srcDataName (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc))
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con DataCon
dc
| let tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
, TyCon -> Bool
isTupleTyCon TyCon
tc
= Name -> RdrName
Exact (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nilDataConKey
= Name -> RdrName
Exact Name
listTyConName
| Bool
otherwise
= OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tcClsName (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))
filterCTuple :: RdrName -> RdrName
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact Name
n)
| Just Int
arity <- Name -> Maybe Int
cTupleTyConNameArity_maybe Name
n
= Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ TupleSort -> Int -> Name
tupleTyConName TupleSort
BoxedTuple Int
arity
filterCTuple RdrName
rdr = RdrName
rdr
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP :: forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (SrcSpan
loc, SDoc
doc)) = SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc SDoc
doc
eitherToP (Right a
thing) = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return a
thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P ( LHsQTyVars GhcPs
, [AddAnn] )
checkTyVars :: SDoc
-> SDoc
-> Located RdrName
-> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
checkTyVars SDoc
pp_what SDoc
equals_or_where Located RdrName
tc [LHsTypeArg GhcPs]
tparms
= do { ([LHsTyVarBndr () GhcPs]
tvs, [[AddAnn]]
anns) <- ([(LHsTyVarBndr () GhcPs, [AddAnn])]
-> ([LHsTyVarBndr () GhcPs], [[AddAnn]]))
-> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> P ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall a b. [(a, b)] -> ([a], [b])
unzip (P [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> P ([LHsTyVarBndr () GhcPs], [[AddAnn]]))
-> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
-> P ([LHsTyVarBndr () GhcPs], [[AddAnn]])
forall a b. (a -> b) -> a -> b
$ (LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> [LHsTypeArg GhcPs] -> P [(LHsTyVarBndr () GhcPs, [AddAnn])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
check [LHsTypeArg GhcPs]
tparms
; (LHsQTyVars GhcPs, [AddAnn]) -> P (LHsQTyVars GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr () GhcPs]
tvs, [[AddAnn]] -> [AddAnn]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AddAnn]]
anns) }
where
check :: LHsTypeArg GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
check (HsTypeArg SrcSpan
_ ki :: LHsType GhcPs
ki@(L SrcSpan
loc HsKind GhcPs
_))
= SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type application" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
, String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what SDoc -> SDoc -> SDoc
<+>
PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)]
check (HsValArg LHsType GhcPs
ty) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens [] LHsType GhcPs
ty
check (HsArgPar SrcSpan
sp) = SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
sp (SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn]))
-> SDoc -> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [String -> SDoc
text String
"Malformed" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
tc)]
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens [AddAnn]
acc (L SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens (SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
acc) LHsType GhcPs
ty
chkParens [AddAnn]
acc LHsType GhcPs
ty = do
LHsTyVarBndr () GhcPs
tv <- LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk LHsType GhcPs
ty
(LHsTyVarBndr () GhcPs, [AddAnn])
-> P (LHsTyVarBndr () GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsTyVarBndr () GhcPs
tv, [AddAnn] -> [AddAnn]
forall a. [a] -> [a]
reverse [AddAnn]
acc)
chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk (L SrcSpan
l (HsKindSig XKindSig GhcPs
_ (L SrcSpan
lv (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tv))) LHsType GhcPs
k))
| RdrName -> Bool
isRdrTyVar RdrName
IdP GhcPs
tv = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar NoExtField
XKindedTyVar GhcPs
noExtField () (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv RdrName
IdP GhcPs
tv) LHsType GhcPs
k))
chk (L SrcSpan
l (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
ltv IdP GhcPs
tv)))
| RdrName -> Bool
isRdrTyVar RdrName
IdP GhcPs
tv = LHsTyVarBndr () GhcPs -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsTyVarBndr () GhcPs -> LHsTyVarBndr () GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar NoExtField
XUserTyVar GhcPs
noExtField () (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
ltv RdrName
IdP GhcPs
tv)))
chk t :: LHsType GhcPs
t@(L SrcSpan
loc HsKind GhcPs
_)
= SrcSpan -> SDoc -> P (LHsTyVarBndr () GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P (LHsTyVarBndr () GhcPs))
-> SDoc -> P (LHsTyVarBndr () GhcPs)
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
, String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
, [SDoc] -> SDoc
vcat[ (String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration should have form"))
, Int -> SDoc -> SDoc
nest Int
2
(SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> SDoc
tc'
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text ([LHsTypeArg GhcPs] -> [String] -> [String]
forall b a. [b] -> [a] -> [a]
takeList [LHsTypeArg GhcPs]
tparms [String]
allNameStrings))
SDoc -> SDoc -> SDoc
<+> SDoc
equals_or_where) ] ]
tc' :: SDoc
tc' = Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Located RdrName -> SDoc) -> Located RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ (RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
filterCTuple Located RdrName
tc
whereDots, equalsDots :: SDoc
whereDots :: SDoc
whereDots = String -> SDoc
text String
"where ..."
equalsDots :: SDoc
equalsDots = String -> SDoc
text String
"= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
Nothing = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDatatypeContext (Just LHsContext GhcPs
c)
= do Bool
allowed <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DatatypeContextsBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (LHsContext GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsContext GhcPs
c)
(String -> SDoc
text String
"Illegal datatype context (use DatatypeContexts):"
SDoc -> SDoc -> SDoc
<+> LHsContext GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LHsContext (GhcPass p) -> SDoc
pprLHsContext LHsContext GhcPs
c)
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> LRuleBndr GhcPs)
-> [LRuleTyTmVar] -> [LRuleBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr NoExtField
XCRuleBndr GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v
cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig NoExtField
XRuleBndrSig GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType LHsType GhcPs
sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr () GhcPs)
-> [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> HsTyVarBndr () GhcPs)
-> LRuleTyTmVar -> LHsTyVarBndr () GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> HsTyVarBndr () GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> HsTyVarBndr () GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing)
= XUserTyVar GhcPs
-> () -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar NoExtField
XUserTyVar GhcPs
noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v)
cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig))
= XKindedTyVar GhcPs
-> ()
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar NoExtField
XKindedTyVar GhcPs
noExtField () ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v) LHsType GhcPs
sig
tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
tm_to_ty RdrName
_ = String -> RdrName
forall a. String -> a
panic String
"mkRuleTyVarBndrs"
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames :: forall flag. [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = (GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> P ())
-> [GenLocated SrcSpan (HsTyVarBndr flag GhcPs)] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Located RdrName -> P ()
forall {f :: * -> *}. MonadP f => Located RdrName -> f ()
check (Located RdrName -> P ())
-> (GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName)
-> GenLocated SrcSpan (HsTyVarBndr flag GhcPs)
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr flag GhcPs -> RdrName)
-> GenLocated SrcSpan (HsTyVarBndr flag GhcPs) -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr flag GhcPs -> RdrName
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
where check :: Located RdrName -> f ()
check (L SrcSpan
loc (Unqual OccName
occ)) = do
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String
"forall",String
"family",String
"role"])
(SrcSpan -> SDoc -> f ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"parse error on input "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
check Located RdrName
_ = String -> f ()
forall a. String -> a
panic String
"checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax :: forall (m :: * -> *) a.
(MonadP m, Outputable a) =>
Located a -> m (Located a)
checkRecordSyntax lr :: Located a
lr@(L SrcSpan
loc a
r)
= do Bool
allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> m ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
loc (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Illegal record syntax (use TraditionalRecordSyntax):" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r
Located a -> m (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
lr
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts@(L SrcSpan
span ([AddAnn]
_, []))
= do Bool
gadtSyntax <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
GadtSyntaxBit
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gadtSyntax (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
span (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Illegal keyword 'where' in data declaration"
, String -> SDoc
text String
"Perhaps you intended to use GADTs or a similar language"
, String -> SDoc
text String
"extension to enable syntax: data T where"
]
Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
checkEmptyGADTs Located ([AddAnn], [LConDecl GhcPs])
gadts = Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return Located ([AddAnn], [LConDecl GhcPs])
gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[AddAnn])
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
is_cls LHsType GhcPs
ty
= LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [] [] LexicalFixity
Prefix
where
goL :: LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL (L SrcSpan
l HsKind GhcPs
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
l HsKind GhcPs
ty [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
go :: SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
lp (HsParTy XParTy GhcPs
_ (L SrcSpan
l (HsStarTy XStarTy GhcPs
_ Bool
isUni))) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
= do { SrcSpan -> P ()
warnStarBndr SrcSpan
l
; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
; (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (OccName -> RdrName
Unqual OccName
name), [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp)) }
go SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: Located (IdP GhcPs)
ltc@(L SrcSpan
_ IdP GhcPs
tc)) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
| RdrName -> Bool
isRdrTc RdrName
IdP GhcPs
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, [AddAnn]
ann)
go SrcSpan
_ (HsOpTy XOpTy GhcPs
_ LHsType GhcPs
t1 ltc :: Located (IdP GhcPs)
ltc@(L SrcSpan
_ IdP GhcPs
tc) LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
_fix
| RdrName -> Bool
isRdrTc RdrName
IdP GhcPs
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, [AddAnn]
ann)
go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l) LexicalFixity
fix
go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
t1 (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddAnn]
ann LexicalFixity
fix
= (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Name -> RdrName
nameRdrName Name
tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> [LHsTypeArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, [AddAnn]
ann)
where
arity :: Int
arity = [LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts
tup_name :: Name
tup_name | Bool
is_cls = Int -> Name
cTupleTyConName Int
arity
| Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
go SrcSpan
l HsKind GhcPs
_ [LHsTypeArg GhcPs]
_ [AddAnn]
_ LexicalFixity
_
= SrcSpan
-> SDoc
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (String -> SDoc
text String
"Malformed head of type or class declaration:"
SDoc -> SDoc -> SDoc
<+> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ty)
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(LHsExpr GhcPs -> PV ()
checkExpBlockArguments, LHsCmd GhcPs -> PV ()
checkCmdBlockArguments) = (LHsExpr GhcPs -> PV ()
checkExpr, LHsCmd GhcPs -> PV ()
checkCmd)
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr LHsExpr GhcPs
expr = do
case LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
expr of
HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
m) Located [ExprLStmt GhcPs]
_ -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (Maybe ModuleName -> SDoc -> SDoc
prependQualified Maybe ModuleName
m (String -> SDoc
text String
"do block")) LHsExpr GhcPs
expr
HsDo XDo GhcPs
_ (MDoExpr Maybe ModuleName
m) Located [ExprLStmt GhcPs]
_ -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (Maybe ModuleName -> SDoc -> SDoc
prependQualified Maybe ModuleName
m (String -> SDoc
text String
"mdo block")) LHsExpr GhcPs
expr
HsLam {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda expression") LHsExpr GhcPs
expr
HsCase {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"case expression") LHsExpr GhcPs
expr
HsLamCase {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda-case expression") LHsExpr GhcPs
expr
HsLet {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"let expression") LHsExpr GhcPs
expr
HsIf {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"if expression") LHsExpr GhcPs
expr
HsProc {} -> SDoc -> LHsExpr GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"proc expression") LHsExpr GhcPs
expr
HsExpr GhcPs
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case LHsCmd GhcPs -> HsCmd GhcPs
forall l e. GenLocated l e -> e
unLoc LHsCmd GhcPs
cmd of
HsCmdLam {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"lambda command") LHsCmd GhcPs
cmd
HsCmdCase {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"case command") LHsCmd GhcPs
cmd
HsCmdIf {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"if command") LHsCmd GhcPs
cmd
HsCmdLet {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"let command") LHsCmd GhcPs
cmd
HsCmdDo {} -> SDoc -> LHsCmd GhcPs -> PV ()
forall a. Outputable a => SDoc -> Located a -> PV ()
check (String -> SDoc
text String
"do command") LHsCmd GhcPs
cmd
HsCmd GhcPs
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check :: Outputable a => SDoc -> Located a -> PV ()
check :: forall a. Outputable a => SDoc -> Located a -> PV ()
check SDoc
element Located a
a = do
Bool
blockArguments <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located a -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located a
a) (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unexpected " SDoc -> SDoc -> SDoc
<> SDoc
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" in function application:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (Located a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located a
a)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"You could write it with parentheses"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Or perhaps you meant to enable BlockArguments?"
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
checkContext (L SrcSpan
l HsKind GhcPs
orig_t)
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [] (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
orig_t)
where
check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns (L SrcSpan
lp (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))
= ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp,SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LHsType GhcPs]
ts)
check [AddAnn]
anns (L SrcSpan
lp1 (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty))
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns' LHsType GhcPs
ty
where anns' :: [AddAnn]
anns' = if SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
lp1 then [AddAnn]
anns
else ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp1)
check [AddAnn]
_anns LHsType GhcPs
_t = ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
orig_t])
checkImportDecl :: Maybe (Located Token)
-> Maybe (Located Token)
-> P ()
checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P ()
checkImportDecl Maybe (Located Token)
mPre Maybe (Located Token)
mPost = do
let whenJust :: Maybe a -> (a -> f ()) -> f ()
whenJust Maybe a
mg a -> f ()
f = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> f ()
f Maybe a
mg
Bool
importQualifiedPostEnabled <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ImportQualifiedPostBit
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
post)
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Located Token) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Located Token)
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpImportQualifiedTwice (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
post)
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPre ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
pre ->
SrcSpan -> P ()
warnPrepositiveQualifiedModule (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
pre)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> Located (PatBuilder GhcPs)
-> P (Located (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg SDoc
msg PV (Located (PatBuilder GhcPs))
pp = SDoc -> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
msg (PV (Located (PatBuilder GhcPs))
pp PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: Located (PatBuilder GhcPs)
e@(L SrcSpan
l PatBuilder GhcPs
_) = SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
l Located (PatBuilder GhcPs)
e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat :: SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc (L SrcSpan
l e :: PatBuilder GhcPs
e@(PatBuilderVar (L SrcSpan
_ RdrName
c))) [LPat GhcPs]
args
| RdrName -> Bool
isRdrDataCon RdrName
c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Pat GhcPs) -> PV (Located (Pat GhcPs)))
-> (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs
-> PV (Located (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Pat GhcPs -> PV (Located (Pat GhcPs)))
-> Pat GhcPs -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
, pat_con :: Located (ConLikeP GhcPs)
pat_con = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
c
, pat_args :: HsConPatDetails GhcPs
pat_args = [Located (Pat GhcPs)]
-> HsConDetails
(Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [Located (Pat GhcPs)]
[LPat GhcPs]
args
}
| Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec RdrName
c =
(SDoc -> SDoc)
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a. (SDoc -> SDoc) -> PV a -> PV a
localPV_msg (\SDoc
_ -> String -> SDoc
text String
"Perhaps you intended to use RecursiveDo") (PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e)
checkPat SrcSpan
loc (L SrcSpan
_ (PatBuilderApp Located (PatBuilder GhcPs)
f Located (PatBuilder GhcPs)
e)) [LPat GhcPs]
args
= do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
f (Located (Pat GhcPs)
p Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [Located (Pat GhcPs)]
[LPat GhcPs]
args)
checkPat SrcSpan
loc (L SrcSpan
_ PatBuilder GhcPs
e) []
= do Pat GhcPs
p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc PatBuilder GhcPs
e
Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Pat GhcPs
p)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
_
= SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
e)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc PatBuilder GhcPs
e0 = do
Bool
nPlusKPatterns <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
NPlusKPatternsBit
case PatBuilder GhcPs
e0 of
PatBuilderPat Pat GhcPs
p -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return Pat GhcPs
p
PatBuilderVar Located RdrName
x -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located RdrName
Located (IdP GhcPs)
x)
PatBuilderOverLit HsOverLit GhcPs
pos_lit -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs
mkNPat (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsOverLit GhcPs
pos_lit) Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing)
PatBuilderOpApp
(L SrcSpan
nloc (PatBuilderVar (L SrcSpan
_ RdrName
n)))
(L SrcSpan
_ RdrName
plus)
(L SrcSpan
lloc (PatBuilderOverLit lit :: HsOverLit GhcPs
lit@(OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral {}})))
| Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
-> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
mkNPlusKPat (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
nloc RdrName
n) (SrcSpan -> HsOverLit GhcPs -> Located (HsOverLit GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
lloc HsOverLit GhcPs
lit))
PatBuilderOpApp Located (PatBuilder GhcPs)
_ Located RdrName
op Located (PatBuilder GhcPs)
_ | RdrName -> Bool
opIsAt (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
op) -> do
SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located RdrName
op) (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Found a binding for the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
op) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"operator in a pattern position." SDoc -> SDoc -> SDoc
$$
SDoc
perhaps_as_pat
Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField)
PatBuilderOpApp Located (PatBuilder GhcPs)
l (L SrcSpan
cl RdrName
c) Located (PatBuilder GhcPs)
r
| RdrName -> Bool
isRdrDataCon RdrName
c -> do
Located (Pat GhcPs)
l <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
l
Located (Pat GhcPs)
r <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
r
Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs)) -> Pat GhcPs -> PV (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
, pat_con :: Located (ConLikeP GhcPs)
pat_con = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
cl RdrName
c
, pat_args :: HsConPatDetails GhcPs
pat_args = Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
(Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcPs)
l Located (Pat GhcPs)
r
}
PatBuilderPar Located (PatBuilder GhcPs)
e -> Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e PV (Located (Pat GhcPs))
-> (Located (Pat GhcPs) -> PV (Pat GhcPs)) -> PV (Pat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs))
-> (Located (Pat GhcPs) -> Pat GhcPs)
-> Located (Pat GhcPs)
-> PV (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat NoExtField
XParPat GhcPs
noExtField))
PatBuilder GhcPs
_ -> SrcSpan -> SDoc -> PV (Pat GhcPs)
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e0)
placeHolderPunRhs :: DisambECP b => PV (Located b)
placeHolderPunRhs :: forall b. DisambECP b => PV (Located b)
placeHolderPunRhs = Located RdrName -> PV (Located b)
forall b. DisambECP b => Located RdrName -> PV (Located b)
mkHsVarPV (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
pun_RDR)
plus_RDR, pun_RDR :: RdrName
plus_RDR :: RdrName
plus_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"+")
pun_RDR :: RdrName
pun_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pun-right-hand-side")
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (L SrcSpan
l HsRecField GhcPs (Located (PatBuilder GhcPs))
fld) = do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (HsRecField GhcPs (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField GhcPs (Located (PatBuilder GhcPs))
fld)
GenLocated
SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))
-> PV
(GenLocated
SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))
-> GenLocated
SrcSpan (HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField GhcPs (Located (PatBuilder GhcPs))
fld { hsRecFieldArg :: Located (Pat GhcPs)
hsRecFieldArg = Located (Pat GhcPs)
p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail :: forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc SDoc
e = SrcSpan -> SDoc -> PV a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> PV a) -> SDoc -> PV a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Parse error in pattern:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
e
patIsRec :: RdrName -> Bool
patIsRec :: RdrName -> Bool
patIsRec RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"rec")
opIsAt :: RdrName -> Bool
opIsAt :: RdrName -> Bool
opIsAt RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"@")
checkValDef :: Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef :: forall a.
Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkValDef Located (PatBuilder GhcPs)
lhs (Just LHsType GhcPs
sig) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
= do Located (Pat GhcPs)
lhs' <- PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Located (PatBuilder GhcPs)
-> LHsType GhcPs
-> PV (Located (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
mkHsTySigPV (Located (PatBuilder GhcPs) -> LHsType GhcPs -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig) Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
checkValDef Located (PatBuilder GhcPs)
lhs Maybe (LHsType GhcPs)
Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g@(L SrcSpan
l (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
= do { Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
mb_fun <- Located (PatBuilder GhcPs)
-> P (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
lhs
; case Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
mb_fun of
Just (Located RdrName
fun, LexicalFixity
is_infix, [Located (PatBuilder GhcPs)]
pats, [AddAnn]
ann) ->
SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
NoSrcStrict [AddAnn]
ann (Located (PatBuilder GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (PatBuilder GhcPs)
lhs)
Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (SrcSpan
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l GRHSs GhcPs (LHsExpr GhcPs)
grhss)
Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
Nothing -> do
Located (Pat GhcPs)
lhs' <- Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern Located (PatBuilder GhcPs)
lhs
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g }
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkFunBind SrcStrictness
strictness [AddAnn]
ann SrcSpan
lhs_loc Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (L SrcSpan
rhs_span GRHSs GhcPs (LHsExpr GhcPs)
grhss)
= do [Located (Pat GhcPs)]
ps <- SDoc -> PV [Located (Pat GhcPs)] -> P [Located (Pat GhcPs)]
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
param_hint ((Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [Located (PatBuilder GhcPs)]
pats)
let match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lhs_loc SrcSpan
rhs_span
([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
ann, Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
fun
[SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
match_span (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs
{ mc_fun :: Located (IdP GhcPs)
mc_fun = Located RdrName
Located (IdP GhcPs)
fun
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
, m_pats :: [LPat GhcPs]
m_pats = [Located (Pat GhcPs)]
[LPat GhcPs]
ps
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss })])
where
param_hint :: SDoc
param_hint
| LexicalFixity
Infix <- LexicalFixity
is_infix
= String -> SDoc
text String
"In a function binding for the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
fun) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"operator." SDoc -> SDoc -> SDoc
$$
if RdrName -> Bool
opIsAt (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
fun) then SDoc
perhaps_as_pat else SDoc
empty
| Bool
otherwise = SDoc
empty
perhaps_as_pat :: SDoc
perhaps_as_pat :: SDoc
perhaps_as_pat = String -> SDoc
text String
"Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind :: Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
fn [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = NoExtField
XFunBind GhcPs GhcPs
noExtField,
fun_id :: Located (IdP GhcPs)
fun_id = Located RdrName
Located (IdP GhcPs)
fn,
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms,
fun_tick :: [Tickish Id]
fun_tick = [] }
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind :: forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
checkPatBind LPat GhcPs
lhs (L SrcSpan
rhs_span (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
| BangPat XBangPat GhcPs
_ LPat GhcPs
p <- Located (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcPs)
LPat GhcPs
lhs
, VarPat XVarPat GhcPs
_ Located (IdP GhcPs)
v <- Located (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcPs)
LPat GhcPs
p
= ([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBindLR GhcPs GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
v [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
match_span (Located RdrName -> Match GhcPs (LHsExpr GhcPs)
m Located RdrName
Located (IdP GhcPs)
v)])
where
match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located (Pat GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (Pat GhcPs)
LPat GhcPs
lhs) SrcSpan
rhs_span
m :: Located RdrName -> Match GhcPs (LHsExpr GhcPs)
m Located RdrName
v = Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = FunRhs :: forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs { mc_fun :: Located (IdP GhcPs)
mc_fun = Located RdrName
Located (IdP GhcPs)
v
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
SrcStrict }
, m_pats :: [LPat GhcPs]
m_pats = []
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss }
checkPatBind LPat GhcPs
lhs (L SrcSpan
_ (a
_,GRHSs GhcPs (LHsExpr GhcPs)
grhss))
= ([AddAnn], HsBindLR GhcPs GhcPs)
-> P ([AddAnn], HsBindLR GhcPs GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind NoExtField
XPatBind GhcPs GhcPs
noExtField LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (L SrcSpan
_ (HsVar XVar GhcPs
_ lrdr :: Located (IdP GhcPs)
lrdr@(L SrcSpan
_ IdP GhcPs
v)))
| RdrName -> Bool
isUnqual RdrName
IdP GhcPs
v
, Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
v))
= Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
Located (IdP GhcPs)
lrdr
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(L SrcSpan
l HsExpr GhcPs
_)
= SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l ((String -> SDoc
text String
"Invalid type signature:" SDoc -> SDoc -> SDoc
<+>
LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":: ...")
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
hint)
where
hint :: String
hint | RdrName
IdP GhcPs
foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use ForeignFunctionInterface?"
| RdrName
IdP GhcPs
default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use DefaultSignatures?"
| RdrName
IdP GhcPs
pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall {p}. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use PatternSynonyms?"
| Bool
otherwise
= String
"Should be of form <variable> :: <type>"
looks_like :: IdP p -> LHsExpr p -> Bool
looks_like IdP p
s (L SrcSpan
_ (HsVar XVar p
_ (L SrcSpan
_ IdP p
v))) = IdP p
v IdP p -> IdP p -> Bool
forall a. Eq a => a -> a -> Bool
== IdP p
s
looks_like IdP p
s (L SrcSpan
_ (HsApp XApp p
_ LHsExpr p
lhs LHsExpr p
_)) = IdP p -> LHsExpr p -> Bool
looks_like IdP p
s LHsExpr p
lhs
looks_like IdP p
_ LHsExpr p
_ = Bool
False
foreign_RDR :: RdrName
foreign_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"foreign")
default_RDR :: RdrName
default_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"default")
pattern_RDR :: RdrName
pattern_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pattern")
checkDoAndIfThenElse
:: (Outputable a, Outputable b, Outputable c)
=> Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse :: forall a b c.
(Outputable a, Outputable b, Outputable c) =>
Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse Located a
guardExpr Bool
semiThen b
thenExpr Bool
semiElse Located c
elseExpr
| Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse
= do Bool
doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$ do
SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (Located a -> Located c -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs Located a
guardExpr Located c
elseExpr)
(String -> SDoc
text String
"Unexpected semi-colons in conditional:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
expr
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Perhaps you meant to use DoAndIfThenElse?")
| Bool
otherwise = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where pprOptSemi :: Bool -> SDoc
pprOptSemi Bool
True = SDoc
semi
pprOptSemi Bool
False = SDoc
empty
expr :: SDoc
expr = String -> SDoc
text String
"if" SDoc -> SDoc -> SDoc
<+> Located a -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located a
guardExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiThen SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"then" SDoc -> SDoc -> SDoc
<+> b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
thenExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiElse SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"else" SDoc -> SDoc -> SDoc
<+> Located c -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located c
elseExpr
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
e = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> P (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn]))
forall {m :: * -> *} {p}.
Monad m =>
Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
go Located (PatBuilder GhcPs)
e [] []
where
go :: Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
go (L SrcSpan
loc (PatBuilderVar (L SrcSpan
_ RdrName
f))) [Located (PatBuilder p)]
es [AddAnn]
ann
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
f) = Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
f, LexicalFixity
Prefix, [Located (PatBuilder p)]
es, [AddAnn]
ann))
go (L SrcSpan
_ (PatBuilderApp Located (PatBuilder p)
f Located (PatBuilder p)
e)) [Located (PatBuilder p)]
es [AddAnn]
ann = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
go Located (PatBuilder p)
f (Located (PatBuilder p)
eLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es) [AddAnn]
ann
go (L SrcSpan
l (PatBuilderPar Located (PatBuilder p)
e)) es :: [Located (PatBuilder p)]
es@(Located (PatBuilder p)
_:[Located (PatBuilder p)]
_) [AddAnn]
ann = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
go Located (PatBuilder p)
e [Located (PatBuilder p)]
es ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
go (L SrcSpan
loc (PatBuilderOpApp Located (PatBuilder p)
l (L SrcSpan
loc' RdrName
op) Located (PatBuilder p)
r)) [Located (PatBuilder p)]
es [AddAnn]
ann
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon RdrName
op)
= Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' RdrName
op, LexicalFixity
Infix, (Located (PatBuilder p)
lLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:Located (PatBuilder p)
rLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es), [AddAnn]
ann))
| Bool
otherwise
= do { Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
mb_l <- Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> [AddAnn]
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
go Located (PatBuilder p)
l [Located (PatBuilder p)]
es [AddAnn]
ann
; case Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
mb_l of
Just (Located RdrName
op', LexicalFixity
Infix, Located (PatBuilder p)
j : Located (PatBuilder p)
k : [Located (PatBuilder p)]
es', [AddAnn]
ann')
-> Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
forall a. a -> Maybe a
Just (Located RdrName
op', LexicalFixity
Infix, Located (PatBuilder p)
j Located (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
: Located (PatBuilder p)
op_app Located (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder p)]
es', [AddAnn]
ann'))
where
op_app :: Located (PatBuilder p)
op_app = SrcSpan -> PatBuilder p -> Located (PatBuilder p)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
forall p.
Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
PatBuilderOpApp Located (PatBuilder p)
k
(SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' RdrName
op) Located (PatBuilder p)
r)
Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
_ -> Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
forall a. Maybe a
Nothing }
go Located (PatBuilder p)
_ [Located (PatBuilder p)]
_ [AddAnn]
_ = Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
-> m (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder p)],
[AddAnn])
forall a. Maybe a
Nothing
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
instance Outputable TyEl where
ppr :: TyEl -> SDoc
ppr (TyElOpr RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
ppr (TyElOpd HsKind GhcPs
ty) = HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ty
ppr (TyElKindApp SrcSpan
_ LHsType GhcPs
ki) = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
ppr (TyElUnpackedness ([AddAnn]
_, SourceText
_, SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
pUnpackedness
:: [Located TyEl]
-> Maybe ( SrcSpan
, [AddAnn]
, SourceText
, SrcUnpackedness
, [Located TyEl] )
pUnpackedness :: [Located TyEl]
-> Maybe
(SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
pUnpackedness (L SrcSpan
l TyEl
x1 : [Located TyEl]
xs)
| TyElUnpackedness ([AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk) <- TyEl
x1
= (SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
-> Maybe
(SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
forall a. a -> Maybe a
Just (SrcSpan
l, [AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk, [Located TyEl]
xs)
pUnpackedness [Located TyEl]
_ = Maybe
(SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
forall a. Maybe a
Nothing
pBangTy
:: LHsType GhcPs
-> [Located TyEl]
-> ( Bool
, LHsType GhcPs
, P ()
, [Located TyEl] )
pBangTy :: LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy lt :: LHsType GhcPs
lt@(L SrcSpan
l1 HsKind GhcPs
_) [Located TyEl]
xs =
case [Located TyEl]
-> Maybe
(SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
pUnpackedness [Located TyEl]
xs of
Maybe
(SrcSpan, [AddAnn], SourceText, SrcUnpackedness, [Located TyEl])
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
Just (SrcSpan
l2, [AddAnn]
anns, SourceText
prag, SrcUnpackedness
unpk, [Located TyEl]
xs') ->
let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
([AddAnn]
anns2, HsKind GhcPs
bt) = (SourceText, SrcUnpackedness)
-> LHsType GhcPs -> ([AddAnn], HsKind GhcPs)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) LHsType GhcPs
lt
in (Bool
True, SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
bl HsKind GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
anns2), [Located TyEl]
xs')
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsKind GhcPs
mkBangTy SrcStrictness
strictness =
XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness)
addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs)
addUnpackedness :: (SourceText, SrcUnpackedness)
-> LHsType GhcPs -> ([AddAnn], HsKind GhcPs)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) (L SrcSpan
l (HsBangTy XBangTy GhcPs
x HsSrcBang
bang LHsType GhcPs
t))
| HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
strictness <- HsSrcBang
bang
= let
anns :: [AddAnn]
anns = case SrcStrictness
strictness of
SrcStrictness
SrcLazy -> [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnTilde (SrcSpan -> SrcSpan
srcSpanFirstCharacter SrcSpan
l)]
SrcStrictness
SrcStrict -> [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
AnnBang (SrcSpan -> SrcSpan
srcSpanFirstCharacter SrcSpan
l)]
SrcStrictness
NoSrcStrict -> []
in ([AddAnn]
anns, XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
x (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
strictness) LHsType GhcPs
t)
addUnpackedness (SourceText
prag, SrcUnpackedness
unpk) LHsType GhcPs
t
= ([], XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict) LHsType GhcPs
t)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((L SrcSpan
l1 (TyElOpd HsKind GhcPs
t)) : [Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l1 HsKind GhcPs
t) [Located TyEl]
xs
, [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs'
= P ()
addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
t'
mergeOps [Located TyEl]
all_xs = Int
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
forall {t}.
(Eq t, Num t) =>
t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go (Int
0 :: Int) [] LHsType GhcPs -> LHsType GhcPs
forall a. a -> a
id [Located TyEl]
all_xs
where
go :: t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElUnpackedness ([AddAnn]
anns, SourceText
unpkSrc, SrcUnpackedness
unpk))):[Located TyEl]
xs) =
if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs
then do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs))
-> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc
; let a :: LHsType GhcPs
a = LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc'
strictMark :: HsSrcBang
strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
unpkSrc SrcUnpackedness
unpk SrcStrictness
NoSrcStrict
bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l (LHsType GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
a)
bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcPs
noExtField HsSrcBang
strictMark LHsType GhcPs
a
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl [AddAnn]
anns
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
bl HsKind GhcPs
bt) }
else SrcSpan -> SDoc -> P (LHsType GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l SDoc
unpkError
where
unpkSDoc :: SDoc
unpkSDoc = case SourceText
unpkSrc of
SourceText
NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
SourceText String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" #-}"
unpkError :: SDoc
unpkError
| Bool -> Bool
not ([Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs) = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot appear inside a type."
| [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
&& t
k t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be applied to a type."
| Bool
otherwise =
String -> SDoc
forall a. String -> a
panic String
"mergeOps.UNPACK: impossible position"
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElOpr RdrName
op)):[Located TyEl]
xs) =
if [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
|| [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Located TyEl -> Bool) -> [Located TyEl] -> [Located TyEl]
forall a. (a -> Bool) -> [a] -> [a]
filter Located TyEl -> Bool
forall {l}. GenLocated l TyEl -> Bool
isTyElOpd [Located TyEl]
xs)
then Located RdrName -> P (LHsType GhcPs)
forall a. Located RdrName -> P a
failOpFewArgs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
op)
else do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [] (\LHsType GhcPs
c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
c (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
op) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc')) [Located TyEl]
xs }
where
isTyElOpd :: GenLocated l TyEl -> Bool
isTyElOpd (L l
_ (TyElOpd HsKind GhcPs
_)) = Bool
True
isTyElOpd GenLocated l TyEl
_ = Bool
False
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
l (TyElOpd HsKind GhcPs
a)):[Located TyEl]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [Located TyEl]
xs
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((L SrcSpan
_ (TyElKindApp SrcSpan
l LHsType GhcPs
a)):[Located TyEl]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
go t
k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [Located TyEl]
xs
go t
_ [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc [] = do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc') }
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = String -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg SrcSpan
_ (L SrcSpan
loc HsKind GhcPs
ki):[LHsTypeArg GhcPs]
_)
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc, String -> SDoc
text String
"Unexpected type application:" SDoc -> SDoc -> SDoc
<+> HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ki)
mergeOpsAcc (HsValArg LHsType GhcPs
ty : [LHsTypeArg GhcPs]
xs) = LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
where
go1 :: LHsType GhcPs
-> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 :: LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [] = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. b -> Either a b
Right LHsType GhcPs
lhs
go1 LHsType GhcPs
lhs (LHsTypeArg GhcPs
x:[LHsTypeArg GhcPs]
xs) = case LHsTypeArg GhcPs
x of
HsValArg LHsType GhcPs
ty -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcPs
lhs LHsType GhcPs
ty) [LHsTypeArg GhcPs]
xs
HsTypeArg SrcSpan
loc LHsType GhcPs
ki -> let ty :: LHsType GhcPs
ty = XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
XAppKindTy GhcPs
loc LHsType GhcPs
lhs LHsType GhcPs
ki
in LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
HsArgPar SrcSpan
_ -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [LHsTypeArg GhcPs]
xs
mergeOpsAcc (HsArgPar SrcSpan
_: [LHsTypeArg GhcPs]
xs) = [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
xs
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
| (Bool
True, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
= (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs')
pInfixSide (Located TyEl
el:[Located TyEl]
xs1)
| Just LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
= [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1] [Located TyEl]
xs1
where
go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go :: [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs]
acc (Located TyEl
el:[Located TyEl]
xs)
| Just LHsTypeArg GhcPs
t <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
= [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go (LHsTypeArg GhcPs
tLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [Located TyEl]
xs
go [LHsTypeArg GhcPs]
acc [Located TyEl]
xs = case [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc of
Left (SrcSpan, SDoc)
_ -> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
Right LHsType GhcPs
acc' -> (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
acc', () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
pInfixSide [Located TyEl]
_ = Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. Maybe a
Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg :: Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg (L SrcSpan
l (TyElOpd HsKind GhcPs
a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs)
forall a. a -> Maybe a
Just (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
a))
pLHsTypeArg (L SrcSpan
_ (TyElKindApp SrcSpan
l LHsType GhcPs
a)) = LHsTypeArg GhcPs -> Maybe (LHsTypeArg GhcPs)
forall a. a -> Maybe a
Just (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
a)
pLHsTypeArg Located TyEl
_ = Maybe (LHsTypeArg GhcPs)
forall a. Maybe a
Nothing
orErr :: Maybe a -> b -> Either b a
orErr :: forall a b. Maybe a -> b -> Either b a
orErr (Just a
a) b
_ = a -> Either b a
forall a b. b -> Either a b
Right a
a
orErr Maybe a
Nothing b
b = b -> Either b a
forall a b. a -> Either a b
Left b
b
mergeDataCon
:: [Located TyEl]
-> P ( Located RdrName
, HsConDeclDetails GhcPs
)
mergeDataCon :: [Located TyEl]
-> P (Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs]))
mergeDataCon [Located TyEl]
all_xs =
do { (P ()
addAnns, (Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs]))
a) <- Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> P (P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
res
; P ()
addAnns
; (Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs]))
-> P (Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs]))
a }
where
res :: Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
res = [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
goFirst [Located TyEl]
all_xs
goFirst :: [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
goFirst [ L SrcSpan
l (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ]
= do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
IdP GhcPs
tc
; (P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [])) }
goFirst ((L SrcSpan
l (TyElOpd (HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
fields))):[Located TyEl]
xs)
| [ L SrcSpan
l' (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ] <- [Located TyEl]
xs
= do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l' RdrName
IdP GhcPs
tc
; (P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), (Located RdrName
data_con, GenLocated SrcSpan [LConDeclField GhcPs]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> [LConDeclField GhcPs]
-> GenLocated SrcSpan [LConDeclField GhcPs]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LConDeclField GhcPs]
fields))) }
goFirst [L SrcSpan
l (TyElOpd (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts))]
= (P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return ( () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, ( SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts)))
, [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
ts) ) )
goFirst ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
= P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
go P ()
addAnns [LHsType GhcPs
t'] [Located TyEl]
xs'
goFirst (L SrcSpan
l (TyElKindApp SrcSpan
_ LHsType GhcPs
_):[Located TyEl]
_)
= Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall a. Semigroup a => a -> a -> a
Monoid.<> (SrcSpan, SDoc)
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall a b. a -> Either a b
Left (SrcSpan
l, SDoc
kindAppErr)
goFirst [Located TyEl]
xs
= P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
go (() -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) [] [Located TyEl]
xs
go :: P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
go P ()
addAnns [LHsType GhcPs]
ts [ L SrcSpan
l (TyElOpd (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tc))) ]
= do { Located RdrName
data_con <- SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
l RdrName
IdP GhcPs
tc
; (P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
forall (m :: * -> *) a. Monad m => a -> m a
return (P ()
addAnns, (Located RdrName
data_con, [HsScaled GhcPs (LHsType GhcPs)]
-> HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
ts))) }
go P ()
addAnns [LHsType GhcPs]
ts ((L SrcSpan
l (TyElOpd HsKind GhcPs
t)):[Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns', [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> HsKind GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsKind GhcPs
t) [Located TyEl]
xs
= P ()
-> [LHsType GhcPs]
-> [Located TyEl]
-> Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
go (P ()
addAnns P () -> P () -> P ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P ()
addAnns') (LHsType GhcPs
t'LHsType GhcPs -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. a -> [a] -> [a]
:[LHsType GhcPs]
ts) [Located TyEl]
xs'
go P ()
_ [LHsType GhcPs]
_ ((L SrcSpan
_ (TyElOpr RdrName
_)):[Located TyEl]
_) =
Either
(SrcSpan, SDoc)
(P (),
(Located RdrName,
HsConDetails
(HsScaled GhcPs (LHsType GhcPs))
(GenLocated SrcSpan [LConDeclField GhcPs])))
goInfix
go P ()
_ [LHsType GhcPs]
_ (L SrcSpan
l