{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl, mkLHsSigType,
mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
filterCTuple,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
checkImportDecl,
checkExpBlockArguments,
checkPrecP,
checkContext,
checkPattern,
checkPattern_msg,
isBangRdr,
isTildeRdr,
checkMonadComp,
checkValDef,
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
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,
patBuilderBang,
) where
import GhcPrelude
import GHC.Hs
import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon ( DataCon, dataConTyCon )
import ConLike ( ConLike(..) )
import CoAxiom ( Role, fsFromRole )
import RdrName
import Name
import BasicTypes
import TcEvidence ( idHsWrapper )
import Lexer
import Lexeme ( isLexCon )
import Type ( TyThing(..), funTyCon )
import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey, eqTyCon_RDR,
tupleTyConName, cTupleTyConNameArity_maybe )
import ForeignCall
import PrelNames ( allNameStrings )
import SrcLoc
import Unique ( hasKey )
import OrdList ( OrdList, fromOL )
import Bag ( emptyBag, consBag )
import Outputable
import FastString
import Maybes
import Util
import ApiAnnotation
import Data.List
import DynFlags ( WarningFlag(..), DynFlags )
import ErrUtils ( Messages )
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
#include "HsVersions.h"
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (LTyClDecl (GhcPass p)
-> Located (SrcSpanLess (LTyClDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LTyClDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyClD (GhcPass p) -> TyClDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD (GhcPass p)
NoExtField
noExtField SrcSpanLess (LTyClDecl (GhcPass p))
TyClDecl (GhcPass p)
d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (LInstDecl (GhcPass p)
-> Located (SrcSpanLess (LInstDecl (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LInstDecl (GhcPass p))
d) = SrcSpan -> SrcSpanLess (LHsDecl (GhcPass p)) -> LHsDecl (GhcPass p)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XInstD (GhcPass p) -> InstDecl (GhcPass p) -> HsDecl (GhcPass p)
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD (GhcPass p)
NoExtField
noExtField SrcSpanLess (LInstDecl (GhcPass p))
InstDecl (GhcPass p)
d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a, [LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
mkClassDecl SrcSpan
loc (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (mcxt, tycl_hdr)) Located (a, [LHsFunDep GhcPs])
fds OrdList (LHsDecl GhcPs)
where_cls
= do { (LHsBinds GhcPs
binds, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
ats, [LTyFamInstDecl GhcPs]
at_defs, [LDataFamInstDecl GhcPs]
_, [LDocDecl]
docs) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
where_cls
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; (Located RdrName
cls, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
True LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = XClassDecl GhcPs
NoExtField
noExtField, tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
cls, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = (a, [Located (FunDep (Located RdrName))])
-> [Located (FunDep (Located RdrName))]
forall a b. (a, b) -> b
snd (Located (a, [Located (FunDep (Located RdrName))])
-> SrcSpanLess (Located (a, [Located (FunDep (Located RdrName))]))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (a, [Located (FunDep (Located RdrName))])
Located (a, [LHsFunDep GhcPs])
fds)
, tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs [LSig GhcPs]
sigs
, tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
binds
, tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs
, tcdDocs :: [LDocDecl]
tcdDocs = [LDocDecl]
docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located
(SrcSpanLess (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (mcxt, tycl_hdr))
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; (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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
NoExtField
noExtField,
tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Maybe (LHsContext GhcPs)
mcxt
; let cxt :: LHsContext GhcPs
cxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs) -> LHsContext GhcPs
forall a. a -> Maybe a -> a
fromMaybe (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []) Maybe (LHsContext GhcPs)
mcxt
; HsDataDefn GhcPs -> P (HsDataDefn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
, dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
cxt
, dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
data_cons
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = XSynDecl GhcPs
NoExtField
noExtField
, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc, tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tyvars
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [Located RdrName]
-> 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 a (m :: * -> *).
(HasSrcSpan a, MonadP m, Outputable a, SrcSpanLess a ~ RdrName) =>
a -> m a
check_lhs_name (Located [Located RdrName]
-> SrcSpanLess (Located [Located RdrName])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [Located RdrName]
lhs)
; Located RdrName
v <- [Located RdrName] -> P (Located RdrName)
check_singular_lhs ([Located RdrName] -> [Located RdrName]
forall a. [a] -> [a]
reverse [Located RdrName]
vs)
; LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs))
-> LStandaloneKindSig GhcPs -> P (LStandaloneKindSig GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LStandaloneKindSig GhcPs)
-> LStandaloneKindSig GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LStandaloneKindSig GhcPs)
-> LStandaloneKindSig GhcPs)
-> SrcSpanLess (LStandaloneKindSig GhcPs)
-> LStandaloneKindSig GhcPs
forall a b. (a -> b) -> a -> b
$ XStandaloneKindSig GhcPs
-> Located (IdP GhcPs)
-> LHsSigType GhcPs
-> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig XStandaloneKindSig GhcPs
NoExtField
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
rhs) }
where
check_lhs_name :: a -> m a
check_lhs_name v :: a
v@(a -> SrcSpanLess a
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc->SrcSpanLess a
name) =
if RdrName -> Bool
isUnqual SrcSpanLess a
RdrName
name Bool -> Bool -> Bool
&& OccName -> Bool
isTcOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess a
RdrName
name)
then a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
else SrcSpan -> SDoc -> m a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
v) (SDoc -> m a) -> SDoc -> m a
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Expected an unqualified type constructor:") Int
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
v)
check_singular_lhs :: [Located RdrName] -> P (Located RdrName)
check_singular_lhs [Located RdrName]
vs =
case [Located RdrName]
vs of
[] -> String -> P (Located RdrName)
forall a. String -> a
panic String
"mkStandaloneKindSig: empty left-hand side"
[Located RdrName
v] -> Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
v
[Located RdrName]
_ -> SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError (Located [Located RdrName] -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located [Located RdrName]
lhs) (SDoc -> P (Located RdrName)) -> SDoc -> P (Located RdrName)
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Standalone kind signatures do not support multiple names at the moment:")
Int
2 ((Located RdrName -> SDoc) -> [Located RdrName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located RdrName]
vs)
, String -> SDoc
text String
"See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs, [AddAnn])
mkTyFamInstEqn Maybe [LHsTyVarBndr GhcPs]
bndrs LHsType GhcPs
lhs LHsType GhcPs
rhs
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
lhs
; (TyFamInstEqn GhcPs, [AddAnn]) -> P (TyFamInstEqn GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs)
feqn_ext = XCFamEqn GhcPs (LHsType GhcPs)
NoExtField
noExtField
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: LHsType GhcPs
feqn_rhs = LHsType GhcPs
rhs }),
[AddAnn]
ann) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs],
LHsType GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst SrcSpan
loc NewOrData
new_or_data Maybe (Located CType)
cType (Maybe (LHsContext GhcPs)
mcxt, Maybe [LHsTyVarBndr GhcPs]
bndrs, LHsType GhcPs
tycl_hdr)
Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
= do { (Located RdrName
tc, [LHsTypeArg GhcPs]
tparams, LexicalFixity
fixity, [AddAnn]
ann) <- Bool
-> LHsType GhcPs
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
checkTyClHdr Bool
False LHsType GhcPs
tycl_hdr
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
loc [AddAnn]
ann
; HsDataDefn GhcPs
defn <- NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsType GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn NewOrData
new_or_data Maybe (Located CType)
cType Maybe (LHsContext GhcPs)
mcxt Maybe (LHsType GhcPs)
ksig [LConDecl GhcPs]
data_cons HsDeriving GhcPs
maybe_deriv
; LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcPs
NoExtField
noExtField (FamInstEqn GhcPs (HsDataDefn GhcPs) -> DataFamInstDecl GhcPs
forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl (FamEqn GhcPs (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
(FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsDataDefn GhcPs)
NoExtField
noExtField
, feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc
, feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs
, feqn_pats :: [LHsTypeArg GhcPs]
feqn_pats = [LHsTypeArg GhcPs]
tparams
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn }))))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs)
mkTyFamInst SrcSpan
loc TyFamInstEqn GhcPs
eqn
= LInstDecl GhcPs -> P (LInstDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcPs
NoExtField
noExtField (TyFamInstEqn GhcPs -> TyFamInstDecl GhcPs
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl TyFamInstEqn GhcPs
eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> 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 -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExtField
noExtField (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl
{ fdExt :: XCFamilyDecl GhcPs
fdExt = XCFamilyDecl GhcPs
NoExtField
noExtField
, fdInfo :: FamilyInfo GhcPs
fdInfo = FamilyInfo GhcPs
info, fdLName :: Located (IdP GhcPs)
fdLName = Located RdrName
Located (IdP GhcPs)
tc
, fdTyVars :: LHsQTyVars GhcPs
fdTyVars = LHsQTyVars GhcPs
tyvars
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdResultSig :: Located (FamilyResultSig GhcPs)
fdResultSig = Located (FamilyResultSig GhcPs)
ksig
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcPs)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injAnn }))) }
where
equals_or_where :: SDoc
equals_or_where = case FamilyInfo GhcPs
info of
FamilyInfo GhcPs
DataFamily -> SDoc
empty
FamilyInfo GhcPs
OpenTypeFamily -> SDoc
empty
ClosedTypeFamily {} -> SDoc
whereDots
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr :: LHsExpr GhcPs
lexpr@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcPs)
expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- SrcSpanLess (LHsExpr GhcPs)
expr
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice) SpliceExplicitFlag
ExplicitSplice)
| Bool
otherwise
= XSpliceD GhcPs -> SpliceDecl GhcPs -> HsDecl GhcPs
forall p. XSpliceD p -> SpliceDecl p -> HsDecl p
SpliceD XSpliceD GhcPs
NoExtField
noExtField (XSpliceDecl GhcPs
-> Located (HsSplice GhcPs)
-> SpliceExplicitFlag
-> SpliceDecl GhcPs
forall p.
XSpliceDecl p
-> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p
SpliceDecl XSpliceDecl GhcPs
NoExtField
noExtField (SrcSpan
-> SrcSpanLess (Located (HsSplice GhcPs))
-> Located (HsSplice GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice SpliceDecoration
NoParens LHsExpr GhcPs
lexpr))
SpliceExplicitFlag
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl SrcSpan
loc Located RdrName
tycon [Located (Maybe FastString)]
roles
= do { [Located (Maybe Role)]
roles' <- (Located (Maybe FastString) -> P (Located (Maybe Role)))
-> [Located (Maybe FastString)] -> P [Located (Maybe Role)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role [Located (Maybe FastString)]
roles
; LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs))
-> LRoleAnnotDecl GhcPs -> P (LRoleAnnotDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs)
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [Located (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcPs
NoExtField
noExtField Located RdrName
Located (IdP GhcPs)
tycon [Located (Maybe Role)]
roles' }
where
role_data_type :: DataType
role_data_type = Role -> DataType
forall a. Data a => a -> DataType
dataTypeOf (Role
forall a. HasCallStack => a
undefined :: Role)
all_roles :: [Role]
all_roles = (Constr -> Role) -> [Constr] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> Role
forall a. Data a => Constr -> a
fromConstr ([Constr] -> [Role]) -> [Constr] -> [Role]
forall a b. (a -> b) -> a -> b
$ DataType -> [Constr]
dataTypeConstrs DataType
role_data_type
possible_roles :: [(FastString, Role)]
possible_roles = [(Role -> FastString
fsFromRole Role
role, Role
role) | Role
role <- [Role]
all_roles]
parse_role :: Located (Maybe FastString) -> P (Located (Maybe Role))
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc_role SrcSpanLess (Located (Maybe FastString))
Nothing) = Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role SrcSpanLess (Located (Maybe Role))
forall a. Maybe a
Nothing
parse_role (Located (Maybe FastString)
-> Located (SrcSpanLess (Located (Maybe FastString)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc_role (Just role))
= case FastString -> [(FastString, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FastString
role [(FastString, Role)]
possible_roles of
Just Role
found_role -> Located (Maybe Role) -> P (Located (Maybe Role))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Maybe Role) -> P (Located (Maybe Role)))
-> Located (Maybe Role) -> P (Located (Maybe Role))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc_role (SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role))
-> SrcSpanLess (Located (Maybe Role)) -> Located (Maybe Role)
forall a b. (a -> b) -> a -> b
$ Role -> Maybe Role
forall a. a -> Maybe a
Just Role
found_role
Maybe Role
Nothing ->
let nearby :: [Role]
nearby = String -> [(String, Role)] -> [Role]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (FastString -> String
unpackFS FastString
role)
((FastString -> String) -> [(FastString, Role)] -> [(String, Role)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst FastString -> String
unpackFS [(FastString, Role)]
possible_roles)
in
SrcSpan -> SDoc -> P (Located (Maybe Role))
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc_role
(String -> SDoc
text String
"Illegal role name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
role) SDoc -> SDoc -> SDoc
$$
[Role] -> SDoc
forall a. Outputable a => [a] -> SDoc
suggestions [Role]
nearby)
parse_role Located (Maybe FastString)
_ = String -> P (Located (Maybe Role))
forall a. String -> a
panic String
"parse_role: Impossible Match"
suggestions :: [a] -> SDoc
suggestions [] = SDoc
empty
suggestions [a
r] = String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
r)
suggestions [a]
list = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Perhaps you meant one of these:")
Int
2 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (a -> SDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [a]
list)
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls OrdList (LHsDecl GhcPs)
decls = [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ValD x b)) : [LHsDecl GhcPs]
ds)
= SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
x SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b') LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds'
where (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l' SrcSpanLess (LHsBind GhcPs)
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [LHsDecl GhcPs]
ds
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup OrdList (LHsDecl GhcPs)
binding
= do { (LHsBinds GhcPs
mbs, [LSig GhcPs]
sigs, [LFamilyDecl GhcPs]
fam_ds, [LTyFamInstDecl GhcPs]
tfam_insts
, [LDataFamInstDecl GhcPs]
dfam_insts, [LDocDecl]
_) <- OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs OrdList (LHsDecl GhcPs)
binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsValBinds GhcPs -> P (HsValBinds GhcPs))
-> HsValBinds GhcPs -> P (HsValBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBinds GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExtField
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 = [LHsDecl GhcPs]
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
forall (m :: * -> *) a a a a a.
(HasSrcSpan a, HasSrcSpan a, HasSrcSpan a, HasSrcSpan a,
HasSrcSpan a, MonadP m, SrcSpanLess a ~ DataFamInstDecl GhcPs,
SrcSpanLess a ~ FamilyDecl GhcPs, SrcSpanLess a ~ Sig GhcPs,
SrcSpanLess a ~ TyFamInstDecl GhcPs, SrcSpanLess a ~ DocDecl) =>
[LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
fb)
where
go :: [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [] = (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
forall a. Bag a
emptyBag, [], [], [], [], [])
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ValD _ b)) : [LHsDecl GhcPs]
ds)
= do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds'
; (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBind GhcPs
b' LHsBind GhcPs -> LHsBinds GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a -> Bag a
`consBag` LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) }
where
(LHsBind GhcPs
b', [LHsDecl GhcPs]
ds') = LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
b) [LHsDecl GhcPs]
ds
go ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsDecl GhcPs)
decl) : [LHsDecl GhcPs]
ds)
= do { (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs) <- [LHsDecl GhcPs] -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
go [LHsDecl GhcPs]
ds
; case SrcSpanLess (LHsDecl GhcPs)
decl of
SigD _ s
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
Sig GhcPs
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
TyClD _ (FamDecl _ t)
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
FamilyDecl GhcPs
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ts, [a]
tfis, [a]
dfis, [a]
docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
TyFamInstDecl GhcPs
tfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tfis, [a]
dfis, [a]
docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DataFamInstDecl GhcPs
dfi a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
dfis, [a]
docs)
DocD _ d
-> (LHsBinds GhcPs, [a], [a], [a], [a], [a])
-> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcPs
bs, [a]
ss, [a]
ts, [a]
tfis, [a]
dfis, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
DocDecl
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
docs)
SpliceD _ d
-> SrcSpan -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l (SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a]))
-> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Declaration splices are allowed only" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"at the top level:")
Int
2 (SpliceDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SpliceDecl GhcPs
d)
SrcSpanLess (LHsDecl GhcPs)
_ -> String -> SDoc -> m (LHsBinds GhcPs, [a], [a], [a], [a], [a])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cvBindsAndSigs" (HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl) }
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind :: LHsBind GhcPs
-> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (LHsBind GhcPs -> Located (SrcSpanLess (LHsBind GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs1) } }))
[LHsDecl GhcPs]
binds
| [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1
= [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs1 SrcSpan
loc1 [LHsDecl GhcPs]
binds []
where
go :: [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc
((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
, fun_matches =
MG { mg_alts = (dL->L _ mtchs2) } })))
: [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
_
| SrcSpanLess (Located RdrName)
RdrName
f1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
f2 = [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go ([LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
mtchs2 [LMatch GhcPs (LHsExpr GhcPs)]
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcPs (LHsExpr GhcPs)]
mtchs)
(SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds []
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc (doc_decl :: LHsDecl GhcPs
doc_decl@(LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (DocD {})) : [LHsDecl GhcPs]
binds) [LHsDecl GhcPs]
doc_decls
= let doc_decls' :: [LHsDecl GhcPs]
doc_decls' = LHsDecl GhcPs
doc_decl LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
: [LHsDecl GhcPs]
doc_decls
in [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpan
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc SrcSpan
loc2) [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls'
go [LMatch GhcPs (LHsExpr GhcPs)]
mtchs SrcSpan
loc [LHsDecl GhcPs]
binds [LHsDecl GhcPs]
doc_decls
= ( SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
Located (IdP GhcPs)
fun_id1 ([LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a]
reverse [LMatch GhcPs (LHsExpr GhcPs)]
mtchs))
, ([LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a]
reverse [LHsDecl GhcPs]
doc_decls) [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
binds)
getMonoBind LHsBind GhcPs
bind [LHsDecl GhcPs]
binds = (LHsBind GhcPs
bind, [LHsDecl GhcPs]
binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = String -> Bool
forall a. String -> a
panic String
"RdrHsSyn:has_args"
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_pats = args })) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args)
has_args ((LMatch GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XMatch nec)) : [LMatch GhcPs (LHsExpr GhcPs)]
_) = NoExtCon -> Bool
forall a. NoExtCon -> a
noExtCon XXMatch GhcPs (LHsExpr GhcPs)
NoExtCon
nec
has_args (LMatch GhcPs (LHsExpr GhcPs)
_ : [LMatch GhcPs (LHsExpr GhcPs)]
_) = String -> Bool
forall a. String -> a
panic String
"has_args:Impossible Match"
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon SrcSpan
loc RdrName
tc
| OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
|| OccName -> Bool
isDataOcc OccName
occ
, FastString -> Bool
isLexCon (OccName -> FastString
occNameFS OccName
occ)
= Located RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (RdrName -> NameSpace -> RdrName
setRdrNameSpace RdrName
tc NameSpace
srcDataName))
| Bool
otherwise
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (Located RdrName)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
msg)
where
occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
tc
msg :: SDoc
msg = String -> SDoc
text String
"Not a data constructor:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
patsyn_name) (Located (OrdList (LHsDecl GhcPs))
-> Located (SrcSpanLess (Located (OrdList (LHsDecl GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls) =
do { [LMatch GhcPs (LHsExpr GhcPs)]
matches <- (LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> [LHsDecl GhcPs] -> P [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
forall a. OrdList a -> [a]
fromOL OrdList (LHsDecl GhcPs)
SrcSpanLess (Located (OrdList (LHsDecl GhcPs)))
decls)
; Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LMatch GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
matches) (SrcSpan -> P ()
wrongNumberErr SrcSpan
loc)
; MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs)))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
matches }
where
fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
fromDecl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc decl :: SrcSpanLess (LHsDecl GhcPs)
decl@(ValD _ (PatBind _
pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
rhs _))) =
do { Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SrcSpanLess (Located RdrName)
RdrName
name RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpanLess (Located RdrName)
RdrName
patsyn_name) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl
; Match GhcPs (LHsExpr GhcPs)
match <- case HsConPatDetails GhcPs
details of
PrefixCon [LPat GhcPs]
pats -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExtField
noExtField
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs]
pats
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext RdrName
ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs { mc_fun :: Located RdrName
mc_fun = Located RdrName
Located (IdP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Prefix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
InfixCon LPat GhcPs
p1 LPat GhcPs
p2 -> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs) -> P (Match GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExtField
noExtField
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt
, m_pats :: [LPat GhcPs]
m_pats = [LPat GhcPs
p1, LPat GhcPs
p2]
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
rhs }
where
ctxt :: HsMatchContext RdrName
ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs { mc_fun :: Located RdrName
mc_fun = Located RdrName
Located (IdP GhcPs)
ln
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
Infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
NoSrcStrict }
RecCon{} -> SrcSpan -> LPat GhcPs -> P (Match GhcPs (LHsExpr GhcPs))
forall a. SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat
; LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs)))
-> LMatch GhcPs (LHsExpr GhcPs) -> P (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
Match GhcPs (LHsExpr GhcPs)
match }
fromDecl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
decl) = SrcSpan -> HsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a a.
(MonadP m, Outputable a) =>
SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
decl
extraDeclErr :: SrcSpan -> a -> m a
extraDeclErr SrcSpan
loc a
decl =
SrcSpan -> SDoc -> m a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> m a) -> SDoc -> m a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause must contain a single binding:" SDoc -> SDoc -> SDoc
$$
a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl
wrongNameBindingErr :: SrcSpan -> HsDecl GhcPs -> P ()
wrongNameBindingErr SrcSpan
loc HsDecl GhcPs
decl =
SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause must bind the pattern synonym's name"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located RdrName)
RdrName
patsyn_name) SDoc -> SDoc -> SDoc
$$ HsDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDecl GhcPs
decl
wrongNumberErr :: SrcSpan -> P ()
wrongNumberErr SrcSpan
loc =
SrcSpan -> SDoc -> P ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"pattern synonym 'where' clause cannot be empty" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"In the pattern synonym declaration for: " SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanLess (Located RdrName)
RdrName
patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr SrcSpan
loc LPat GhcPs
pat =
SrcSpan -> SDoc -> P a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P a) -> SDoc -> P a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"record syntax not supported for pattern synonym declarations:" SDoc -> SDoc -> SDoc
$$
Located (Pat GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (Pat GhcPs)
LPat GhcPs
pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 :: Located RdrName
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
name Maybe [LHsTyVarBndr GhcPs]
mb_forall Maybe (LHsContext GhcPs)
mb_cxt HsConDeclDetails GhcPs
args
= ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcPs
con_ext = XConDeclH98 GhcPs
NoExtField
noExtField
, con_name :: Located (IdP GhcPs)
con_name = Located RdrName
Located (IdP GhcPs)
name
, con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ Maybe [LHsTyVarBndr GhcPs] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [LHsTyVarBndr GhcPs]
mb_forall
, con_ex_tvs :: [LHsTyVarBndr GhcPs]
con_ex_tvs = Maybe [LHsTyVarBndr GhcPs]
mb_forall Maybe [LHsTyVarBndr GhcPs]
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. Maybe a -> a -> a
`orElse` []
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mb_cxt
, con_args :: HsConDeclDetails GhcPs
con_args = HsConDeclDetails GhcPs
args
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
-> (ConDecl GhcPs, [AddAnn])
mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
names LHsType GhcPs
ty
= (ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> LHsQTyVars pass
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext = XConDeclGADT GhcPs
NoExtField
noExtField
, con_names :: [Located (IdP GhcPs)]
con_names = [Located RdrName]
[Located (IdP GhcPs)]
names
, con_forall :: Located Bool
con_forall = SrcSpan -> SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
ty'
, con_qvars :: LHsQTyVars GhcPs
con_qvars = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tvs
, con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt
, con_args :: HsConDeclDetails GhcPs
con_args = HsConDeclDetails GhcPs
args
, con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
forall a. Maybe a
Nothing }
, [AddAnn]
anns1 [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
anns2)
where
(ty' :: LHsType GhcPs
ty'@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
_),[AddAnn]
anns1) = LHsType GhcPs -> [AddAnn] -> (LHsType GhcPs, [AddAnn])
forall pass. LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType GhcPs
ty []
([LHsTyVarBndr GhcPs]
tvs, LHsType GhcPs
rho) = LHsType GhcPs -> ([LHsTyVarBndr GhcPs], LHsType GhcPs)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTyInvis LHsType GhcPs
ty'
(Maybe (LHsContext GhcPs)
mcxt, LHsType GhcPs
tau, [AddAnn]
anns2) = LHsType GhcPs
-> [AddAnn] -> (Maybe (LHsContext GhcPs), LHsType GhcPs, [AddAnn])
forall pass.
LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType GhcPs
rho []
split_rho :: LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) [AddAnn]
ann
= (LHsContext pass -> Maybe (LHsContext pass)
forall a. a -> Maybe a
Just LHsContext pass
cxt, LHsType pass
tau, [AddAnn]
ann)
split_rho (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann
= LHsType pass
-> [AddAnn] -> (Maybe (LHsContext pass), LHsType pass, [AddAnn])
split_rho LHsType pass
ty ([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
split_rho LHsType pass
tau [AddAnn]
ann
= (Maybe (LHsContext pass)
forall a. Maybe a
Nothing, LHsType pass
tau, [AddAnn]
ann)
(HsConDeclDetails GhcPs
args, LHsType GhcPs
res_ty) = LHsType GhcPs -> (HsConDeclDetails GhcPs, LHsType GhcPs)
forall rec pass arg.
(HasSrcSpan rec, SrcSpanLess rec ~ [LConDeclField pass]) =>
LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau LHsType GhcPs
tau
split_tau :: LHsType pass -> (HsConDetails arg rec, LHsType pass)
split_tau (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
= (rec -> HsConDetails arg rec
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan -> SrcSpanLess rec -> rec
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LConDeclField pass]
SrcSpanLess rec
rf), LHsType pass
res_ty)
split_tau LHsType pass
tau
= ([arg] -> HsConDetails arg rec
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [], LHsType pass
tau)
peel_parens :: LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) [AddAnn]
ann = LHsType pass -> [AddAnn] -> (LHsType pass, [AddAnn])
peel_parens LHsType pass
ty
([AddAnn]
ann[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
peel_parens LHsType pass
ty [AddAnn]
ann = (LHsType pass
ty, [AddAnn]
ann)
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
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 :: 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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsParTy _ ty)) = [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr GhcPs, [AddAnn])
chkParens (SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l
[AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AddAnn]
acc) LHsType GhcPs
ty
chkParens [AddAnn]
acc LHsType GhcPs
ty = do
LHsTyVarBndr GhcPs
tv <- LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
chk LHsType GhcPs
ty
(LHsTyVarBndr GhcPs, [AddAnn]) -> P (LHsTyVarBndr GhcPs, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsTyVarBndr GhcPs
tv, [AddAnn] -> [AddAnn]
forall a. [a] -> [a]
reverse [AddAnn]
acc)
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
| RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv = LHsTyVarBndr GhcPs -> P (LHsTyVarBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv SrcSpanLess (Located RdrName)
tv) LHsType GhcPs
k))
chk (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsTyVar _ _ (dL->L ltv tv)))
| RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
RdrName
tv = LHsTyVarBndr GhcPs -> P (LHsTyVarBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcPs) -> LHsTyVarBndr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
ltv SrcSpanLess (Located RdrName)
tv)))
chk t :: LHsType GhcPs
t@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsType GhcPs)
_)
= SrcSpan -> SDoc -> P (LHsTyVarBndr GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> P (LHsTyVarBndr GhcPs)) -> SDoc -> P (LHsTyVarBndr GhcPs)
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t)
, String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration for") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
tc'
, [SDoc] -> SDoc
vcat[ (String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"declaration should have form"))
, Int -> SDoc -> SDoc
nest Int
2
(SDoc
pp_what
SDoc -> SDoc -> SDoc
<+> SDoc
tc'
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text ([LHsTypeArg GhcPs] -> [String] -> [String]
forall b a. [b] -> [a] -> [a]
takeList [LHsTypeArg GhcPs]
tparms [String]
allNameStrings))
SDoc -> SDoc -> SDoc
<+> SDoc
equals_or_where) ] ]
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 a. HasSrcSpan a => a -> SrcSpan
getLoc LHsContext GhcPs
c)
(String -> SDoc
text String
"Illegal datatype context (use DatatypeContexts):"
SDoc -> SDoc -> SDoc
<+> LHsContext GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LHsContext (GhcPass p) -> SDoc
pprLHsContext LHsContext GhcPs
c)
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = (LRuleTyTmVar -> LRuleBndr GhcPs)
-> [LRuleTyTmVar] -> [LRuleBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> RuleBndr GhcPs) -> LRuleTyTmVar -> LRuleBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> RuleBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> RuleBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing) = XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr XCRuleBndr GhcPs
NoExtField
noExtField Located RdrName
Located (IdP GhcPs)
v
cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig)) =
XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> LHsSigWcType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcPs
NoExtField
noExtField Located RdrName
Located (IdP GhcPs)
v (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs = (LRuleTyTmVar -> LHsTyVarBndr GhcPs)
-> [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleTyTmVar -> HsTyVarBndr GhcPs)
-> LRuleTyTmVar -> LHsTyVarBndr GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one)
where cvt_one :: RuleTyTmVar -> HsTyVarBndr GhcPs
cvt_one (RuleTyTmVar Located RdrName
v Maybe (LHsType GhcPs)
Nothing) = XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
NoExtField
noExtField ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v)
cvt_one (RuleTyTmVar Located RdrName
v (Just LHsType GhcPs
sig))
= XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
NoExtField
noExtField ((RdrName -> RdrName) -> Located RdrName -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> RdrName
tm_to_ty Located RdrName
v) LHsType GhcPs
sig
tm_to_ty :: RdrName -> RdrName
tm_to_ty (Unqual OccName
occ) = OccName -> RdrName
Unqual (NameSpace -> OccName -> OccName
setOccNameSpace NameSpace
tvName OccName
occ)
tm_to_ty RdrName
_ = String -> RdrName
forall a. String -> a
panic String
"mkRuleTyVarBndrs"
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = (LHsTyVarBndr GhcPs -> P ()) -> [LHsTyVarBndr GhcPs] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Located RdrName -> P ()
forall a (f :: * -> *).
(HasSrcSpan a, MonadP f, SrcSpanLess a ~ RdrName) =>
a -> f ()
check (Located RdrName -> P ())
-> (LHsTyVarBndr GhcPs -> Located RdrName)
-> LHsTyVarBndr GhcPs
-> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsTyVarBndr GhcPs -> RdrName)
-> LHsTyVarBndr GhcPs -> Located RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr GhcPs -> RdrName
forall (p :: Pass). HsTyVarBndr (GhcPass p) -> IdP (GhcPass p)
hsTyVarName)
where check :: a -> f ()
check (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (Unqual occ)) = do
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OccName -> String
occNameString OccName
occ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String
"forall",String
"family",String
"role"])
(SrcSpan -> SDoc -> f ()
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"parse error on input "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ))
check a
_ = String -> f ()
forall a. String -> a
panic String
"checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax :: Located a -> m (Located a)
checkRecordSyntax lr :: Located a
lr@(Located a -> Located (SrcSpanLess (Located a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located a)
r)
= do Bool
allowed <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
TraditionalRecordSyntaxBit
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> m ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
loc (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Illegal record syntax (use TraditionalRecordSyntax):" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
SrcSpanLess (Located a)
r
Located a -> m (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
lr
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts :: Located ([AddAnn], [LConDecl GhcPs])
gadts@(Located ([AddAnn], [LConDecl GhcPs])
-> Located (SrcSpanLess (Located ([AddAnn], [LConDecl GhcPs])))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
span (_, []))
= do Bool
gadtSyntax <- ExtBits -> P Bool
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 (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
ty [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
go :: SrcSpan
-> HsKind GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
go SrcSpan
lp (HsParTy XParTy GhcPs
_ (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsStarTy _ isUni))) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
= do { SrcSpan -> P ()
warnStarBndr SrcSpan
l
; let name :: OccName
name = NameSpace -> String -> OccName
mkOccName NameSpace
tcClsName (Bool -> String
starSym Bool
isUni)
; (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (OccName -> RdrName
Unqual OccName
name), [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp)) }
go SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ ltc :: Located (IdP GhcPs)
ltc@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
tc)) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, [LHsTypeArg GhcPs]
acc, LexicalFixity
fix, [AddAnn]
ann)
go SrcSpan
_ (HsOpTy XOpTy GhcPs
_ LHsType GhcPs
t1 ltc :: Located (IdP GhcPs)
ltc@(Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
tc) LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
_fix
| RdrName -> Bool
isRdrTc SrcSpanLess (Located RdrName)
RdrName
tc = (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName
Located (IdP GhcPs)
ltc, LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc, LexicalFixity
Infix, [AddAnn]
ann)
go SrcSpan
l (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty [LHsTypeArg GhcPs]
acc ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l) LexicalFixity
fix
go SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
t1 (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
_ (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
ki) [LHsTypeArg GhcPs]
acc [AddAnn]
ann LexicalFixity
fix = LHsType GhcPs
-> [LHsTypeArg GhcPs]
-> [AddAnn]
-> LexicalFixity
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
goL LHsType GhcPs
ty (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
kiLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) [AddAnn]
ann LexicalFixity
fix
go SrcSpan
l (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
ts) [] [AddAnn]
ann LexicalFixity
fix
= (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
-> P (Located RdrName, [LHsTypeArg GhcPs], LexicalFixity, [AddAnn])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (Name -> RdrName
nameRdrName Name
tup_name), (LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> [LHsTypeArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
ts, LexicalFixity
fix, [AddAnn]
ann)
where
arity :: Int
arity = [LHsType GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
ts
tup_name :: Name
tup_name | Bool
is_cls = Int -> Name
cTupleTyConName Int
arity
| Bool
otherwise = TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity)
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 = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
expr of
HsDo _ DoExpr _ -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"do block" LHsExpr GhcPs
expr
HsDo _ MDoExpr _ -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"mdo block" LHsExpr GhcPs
expr
HsLam {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"lambda expression" LHsExpr GhcPs
expr
HsCase {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"case expression" LHsExpr GhcPs
expr
HsLamCase {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"lambda-case expression" LHsExpr GhcPs
expr
HsLet {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"let expression" LHsExpr GhcPs
expr
HsIf {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"if expression" LHsExpr GhcPs
expr
HsProc {} -> String -> LHsExpr GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"proc expression" LHsExpr GhcPs
expr
SrcSpanLess (LHsExpr GhcPs)
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd LHsCmd GhcPs
cmd = case LHsCmd GhcPs -> SrcSpanLess (LHsCmd GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsCmd GhcPs
cmd of
HsCmdLam {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"lambda command" LHsCmd GhcPs
cmd
HsCmdCase {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"case command" LHsCmd GhcPs
cmd
HsCmdIf {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"if command" LHsCmd GhcPs
cmd
HsCmdLet {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"let command" LHsCmd GhcPs
cmd
HsCmdDo {} -> String -> LHsCmd GhcPs -> PV ()
forall a. (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check String
"do command" LHsCmd GhcPs
cmd
SrcSpanLess (LHsCmd GhcPs)
_ -> () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check :: String -> a -> PV ()
check String
element a
a = do
Bool
blockArguments <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BlockArgumentsBit
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
blockArguments (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
a) (SDoc -> PV ()) -> SDoc -> PV ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unexpected " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
element SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" in function application:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"You could write it with parentheses"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Or perhaps you meant to enable BlockArguments?"
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
checkContext (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t)
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [] (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t)
where
check :: [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
= ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp,SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
ts)
check [AddAnn]
anns (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lp1 (HsParTy _ ty))
= [AddAnn] -> LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)
check [AddAnn]
anns' LHsType GhcPs
ty
where anns' :: [AddAnn]
anns' = if SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
lp1 then [AddAnn]
anns
else ([AddAnn]
anns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
lp1)
check [AddAnn]
_anns LHsType GhcPs
t = SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
t P ()
-> P ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([AddAnn], LHsContext GhcPs) -> P ([AddAnn], LHsContext GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
orig_t])
msg :: SDoc
msg = String -> SDoc
text String
"data constructor context"
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs SDoc
msg LHsType GhcPs
ty = LHsType GhcPs -> P ()
go LHsType GhcPs
ty
where
go :: LHsType GhcPs -> P ()
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppKindTy _ ty ki)) = LHsType GhcPs -> P ()
go LHsType GhcPs
ty P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
ki
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsAppTy _ t1 t2)) = LHsType GhcPs -> P ()
go LHsType GhcPs
t1 P () -> P () -> P ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LHsType GhcPs -> P ()
go LHsType GhcPs
t2
go (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (HsDocTy _ t ds)) = SrcSpan -> SDoc -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError SrcSpan
l (SDoc -> P ()) -> SDoc -> P ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Unexpected haddock", SDoc -> SDoc
quotes (LHsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsDocString
ds)
, String -> SDoc
text String
"on", SDoc
msg, SDoc -> SDoc
quotes (LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
t) ]
go LHsType GhcPs
_ = () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkImportDecl :: Maybe (Located Token)
-> Maybe (Located Token)
-> P ()
checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P ()
checkImportDecl Maybe (Located Token)
mPre Maybe (Located Token)
mPost = do
let whenJust :: Maybe a -> (a -> f ()) -> f ()
whenJust Maybe a
mg a -> f ()
f = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> f ()
f Maybe a
mg
Bool
importQualifiedPostEnabled <- ExtBits -> P Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
ImportQualifiedPostBit
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
importQualifiedPostEnabled) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost (Located Token -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located Token
post)
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPost ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
post ->
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Located Token) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Located Token)
mPre) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> P ()
failOpImportQualifiedTwice (Located Token -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located Token
post)
Maybe (Located Token) -> (Located Token -> P ()) -> P ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (Located Token)
mPre ((Located Token -> P ()) -> P ())
-> (Located Token -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \Located Token
pre ->
SrcSpan -> P ()
warnPrepositiveQualifiedModule (Located Token -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located Token
pre)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> Located (PatBuilder GhcPs)
-> P (Located (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg SDoc
msg PV (Located (PatBuilder GhcPs))
pp = SDoc -> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. SDoc -> PV a -> P a
runPV_msg SDoc
msg (PV (Located (PatBuilder GhcPs))
pp PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e :: Located (PatBuilder GhcPs)
e@(Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located (PatBuilder GhcPs))
_) = SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
l Located (PatBuilder GhcPs)
e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat :: SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l e :: SrcSpanLess (Located (PatBuilder GhcPs))
e@(PatBuilderVar (dL->L _ c))) [LPat GhcPs]
args
| RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c = Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
c) ([Located (Pat GhcPs)]
-> HsConDetails
(Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [Located (Pat GhcPs)]
[LPat GhcPs]
args)))
| Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Pat GhcPs)]
[LPat GhcPs]
args) Bool -> Bool -> Bool
&& RdrName -> Bool
patIsRec SrcSpanLess (Located RdrName)
RdrName
c =
(SDoc -> SDoc)
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a. (SDoc -> SDoc) -> PV a -> PV a
localPV_msg (\SDoc
_ -> String -> SDoc
text String
"Perhaps you intended to use RecursiveDo") (PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> PV (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
l (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located (PatBuilder GhcPs))
PatBuilder GhcPs
e)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
args
| Just (Located (PatBuilder GhcPs)
e', [Located (PatBuilder GhcPs)]
args') <- Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang Located (PatBuilder GhcPs)
e
= do { [Located (Pat GhcPs)]
args'' <- (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> PV [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat [Located (PatBuilder GhcPs)]
args'
; SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e' ([Located (Pat GhcPs)]
args'' [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)]
[LPat GhcPs]
args) }
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [LPat GhcPs]
args
= do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
SrcSpan
-> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
f (Located (Pat GhcPs)
p Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. a -> [a] -> [a]
: [Located (Pat GhcPs)]
[LPat GhcPs]
args)
checkPat SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (PatBuilder GhcPs))
e) []
= do Pat GhcPs
p <- SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc SrcSpanLess (Located (PatBuilder GhcPs))
PatBuilder GhcPs
e
Located (Pat GhcPs) -> PV (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (Pat GhcPs))
Pat GhcPs
p)
checkPat SrcSpan
loc Located (PatBuilder GhcPs)
e [LPat GhcPs]
_
= SrcSpan -> SDoc -> PV (Located (Pat GhcPs))
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (Located (PatBuilder GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (PatBuilder GhcPs)
e)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat SrcSpan
loc PatBuilder GhcPs
e0 = do
Bool
nPlusKPatterns <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
NPlusKPatternsBit
case PatBuilder GhcPs
e0 of
PatBuilderPat Pat GhcPs
p -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return Pat GhcPs
p
PatBuilderVar Located RdrName
x -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField Located RdrName
Located (IdP GhcPs)
x)
PatBuilderOverLit HsOverLit GhcPs
pos_lit -> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs
mkNPat (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
pos_lit) Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing)
PatBuilderBang SrcSpan
lb Located (PatBuilder GhcPs)
e
-> do { SrcSpan -> PatBuilder GhcPs -> PV ()
hintBangPat SrcSpan
loc PatBuilder GhcPs
e0
; Located (Pat GhcPs)
e' <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e
; SrcSpan -> AnnKeywordId -> SrcSpan -> PV ()
forall (m :: * -> *).
MonadP m =>
SrcSpan -> AnnKeywordId -> SrcSpan -> m ()
addAnnotation SrcSpan
loc AnnKeywordId
AnnBang SrcSpan
lb
; Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBangPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcPs
NoExtField
noExtField Located (Pat GhcPs)
LPat GhcPs
e') }
PatBuilderOpApp
(Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
nloc (PatBuilderVar (dL->L _ n)))
(Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
plus)
(Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| Bool
nPlusKPatterns Bool -> Bool -> Bool
&& (SrcSpanLess (Located RdrName)
RdrName
plus RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
plus_RDR)
-> Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
mkNPlusKPat (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
nloc SrcSpanLess (Located RdrName)
n) (SrcSpan
-> SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lloc SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
lit))
PatBuilderOpApp Located (PatBuilder GhcPs)
l (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
cl SrcSpanLess (Located RdrName)
c) Located (PatBuilder GhcPs)
r
| RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
c -> do
Located (Pat GhcPs)
l <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
l
Located (Pat GhcPs)
r <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
r
Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
cl SrcSpanLess (Located RdrName)
c) (Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
(Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon Located (Pat GhcPs)
l Located (Pat GhcPs)
r))
PatBuilderPar Located (PatBuilder GhcPs)
e -> Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat Located (PatBuilder GhcPs)
e PV (Located (Pat GhcPs))
-> (Located (Pat GhcPs) -> PV (Pat GhcPs)) -> PV (Pat GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pat GhcPs -> PV (Pat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcPs -> PV (Pat GhcPs))
-> (Located (Pat GhcPs) -> Pat GhcPs)
-> Located (Pat GhcPs)
-> PV (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat GhcPs
NoExtField
noExtField))
PatBuilder GhcPs
_ -> SrcSpan -> SDoc -> PV (Pat GhcPs)
forall a. SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
e0)
placeHolderPunRhs :: DisambECP b => PV (Located b)
placeHolderPunRhs :: PV (Located b)
placeHolderPunRhs = Located RdrName -> PV (Located b)
forall b. DisambECP b => Located RdrName -> PV (Located b)
mkHsVarPV (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
pun_RDR)
plus_RDR, pun_RDR :: RdrName
plus_RDR :: RdrName
plus_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"+")
pun_RDR :: RdrName
pun_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pun-right-hand-side")
isBangRdr, isTildeRdr :: RdrName -> Bool
isBangRdr :: RdrName -> Bool
isBangRdr (Unqual OccName
occ) = OccName -> FastString
occNameFS OccName
occ FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit String
"!"
isBangRdr RdrName
_ = Bool
False
isTildeRdr :: RdrName -> Bool
isTildeRdr = (RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
==RdrName
eqTyCon_RDR)
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> Located
(SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs)))
fld) = do Located (Pat GhcPs)
p <- Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs)))
HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs))
fld)
LHsRecField GhcPs (Located (Pat GhcPs))
-> PV (LHsRecField GhcPs (Located (Pat GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LHsRecField GhcPs (Located (Pat GhcPs)))
-> LHsRecField GhcPs (Located (Pat GhcPs))
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (LHsRecField GhcPs (Located (PatBuilder GhcPs)))
HsRecField' (FieldOcc GhcPs) (Located (PatBuilder GhcPs))
fld { hsRecFieldArg :: Located (Pat GhcPs)
hsRecFieldArg = Located (Pat GhcPs)
p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail :: SrcSpan -> SDoc -> PV a
patFail SrcSpan
loc SDoc
e = SrcSpan -> SDoc -> PV a
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
loc (SDoc -> PV a) -> SDoc -> PV a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Parse error in pattern:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
e
patIsRec :: RdrName -> Bool
patIsRec :: RdrName -> Bool
patIsRec RdrName
e = RdrName
e RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"rec")
checkValDef :: SrcStrictness
-> Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef :: SrcStrictness
-> Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkValDef SrcStrictness
_strictness Located (PatBuilder GhcPs)
lhs (Just LHsType GhcPs
sig) Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
= do Located (Pat GhcPs)
lhs' <- PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a. PV a -> P a
runPV (PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs)) -> P (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Located (PatBuilder GhcPs)
-> LHsType GhcPs
-> PV (Located (PatBuilder GhcPs))
forall b.
DisambECP b =>
SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
mkHsTySigPV (Located (PatBuilder GhcPs) -> LHsType GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig) Located (PatBuilder GhcPs)
lhs LHsType GhcPs
sig PV (Located (PatBuilder GhcPs))
-> (Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs)))
-> PV (Located (Pat GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Located (PatBuilder GhcPs) -> PV (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
grhss
checkValDef SrcStrictness
strictness Located (PatBuilder GhcPs)
lhs Maybe (LHsType GhcPs)
Nothing g :: Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g@(Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (_,grhss))
= do { Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
mb_fun <- Located (PatBuilder GhcPs)
-> P (Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn]))
isFunLhs Located (PatBuilder GhcPs)
lhs
; case Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
mb_fun of
Just (Located RdrName
fun, LexicalFixity
is_infix, [Located (PatBuilder GhcPs)]
pats, [AddAnn]
ann) ->
SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind SrcStrictness
strictness [AddAnn]
ann (Located (PatBuilder GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (PatBuilder GhcPs)
lhs)
Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (SrcSpan
-> SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
GRHSs GhcPs (LHsExpr GhcPs)
grhss)
Maybe
(Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],
[AddAnn])
Nothing -> do
Located (Pat GhcPs)
lhs' <- Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern Located (PatBuilder GhcPs)
lhs
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
forall a.
LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind Located (Pat GhcPs)
LPat GhcPs
lhs' Located (a, GRHSs GhcPs (LHsExpr GhcPs))
g }
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkFunBind SrcStrictness
strictness [AddAnn]
ann SrcSpan
lhs_loc Located RdrName
fun LexicalFixity
is_infix [Located (PatBuilder GhcPs)]
pats (Located (GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
rhs_span SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
grhss)
= do [Located (Pat GhcPs)]
ps <- (Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs)))
-> [Located (PatBuilder GhcPs)] -> P [Located (Pat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (PatBuilder GhcPs) -> P (Located (Pat GhcPs))
Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern [Located (PatBuilder GhcPs)]
pats
let match_span :: SrcSpan
match_span = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
lhs_loc SrcSpan
rhs_span
([AddAnn], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddAnn]
ann, Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
fun
[SrcSpan
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
match_span (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext = XCMatch GhcPs (LHsExpr GhcPs)
NoExtField
noExtField
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = FunRhs :: forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs
{ mc_fun :: Located RdrName
mc_fun = Located RdrName
fun
, mc_fixity :: LexicalFixity
mc_fixity = LexicalFixity
is_infix
, mc_strictness :: SrcStrictness
mc_strictness = SrcStrictness
strictness }
, m_pats :: [LPat GhcPs]
m_pats = [Located (Pat GhcPs)]
[LPat GhcPs]
ps
, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = SrcSpanLess (Located (GRHSs GhcPs (LHsExpr GhcPs)))
GRHSs GhcPs (LHsExpr GhcPs)
grhss })])
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
makeFunBind Located RdrName
fn [LMatch GhcPs (LHsExpr GhcPs)]
ms
= FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcPs GhcPs
fun_ext = XFunBind GhcPs GhcPs
NoExtField
noExtField,
fun_id :: Located (IdP GhcPs)
fun_id = Located RdrName
Located (IdP GhcPs)
fn,
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms,
fun_co_fn :: HsWrapper
fun_co_fn = HsWrapper
idHsWrapper,
fun_tick :: [Tickish Id]
fun_tick = [] }
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind :: LPat GhcPs
-> Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn], HsBind GhcPs)
checkPatBind LPat GhcPs
lhs (Located (a, GRHSs GhcPs (LHsExpr GhcPs))
-> Located (SrcSpanLess (Located (a, GRHSs GhcPs (LHsExpr GhcPs))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (_,grhss))
= ([AddAnn], HsBind GhcPs) -> P ([AddAnn], HsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([Tickish Id], [[Tickish Id]])
-> HsBind GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExtField
noExtField LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ lrdr@(dL->L _ v)))
| RdrName -> Bool
isUnqual SrcSpanLess (Located RdrName)
RdrName
v
, Bool -> Bool
not (OccName -> Bool
isDataOcc (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
v))
= Located RdrName -> P (Located RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return Located RdrName
Located (IdP GhcPs)
lrdr
checkValSigLhs lhs :: LHsExpr GhcPs
lhs@(LHsExpr GhcPs -> Located (SrcSpanLess (LHsExpr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (LHsExpr GhcPs)
_)
= SrcSpan -> SDoc -> P (Located RdrName)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l ((String -> SDoc
text String
"Invalid type signature:" SDoc -> SDoc -> SDoc
<+>
LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":: ...")
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
hint)
where
hint :: String
hint | RdrName
IdP GhcPs
foreign_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use ForeignFunctionInterface?"
| RdrName
IdP GhcPs
default_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use DefaultSignatures?"
| RdrName
IdP GhcPs
pattern_RDR IdP GhcPs -> LHsExpr GhcPs -> Bool
forall p. Eq (IdP p) => IdP p -> LHsExpr p -> Bool
`looks_like` LHsExpr GhcPs
lhs
= String
"Perhaps you meant to use PatternSynonyms?"
| Bool
otherwise
= String
"Should be of form <variable> :: <type>"
looks_like :: IdP p -> LHsExpr p -> Bool
looks_like IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ (dL->L _ v))) = SrcSpanLess (Located (IdP p))
IdP p
v IdP p -> IdP p -> Bool
forall a. Eq a => a -> a -> Bool
== IdP p
s
looks_like IdP p
s (LHsExpr p -> Located (SrcSpanLess (LHsExpr p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsApp _ lhs _)) = IdP p -> LHsExpr p -> Bool
looks_like IdP p
s LHsExpr p
lhs
looks_like IdP p
_ LHsExpr p
_ = Bool
False
foreign_RDR :: RdrName
foreign_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"foreign")
default_RDR :: RdrName
default_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"default")
pattern_RDR :: RdrName
pattern_RDR = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
varName (String -> FastString
fsLit String
"pattern")
checkDoAndIfThenElse
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse :: a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse a
guardExpr Bool
semiThen b
thenExpr Bool
semiElse c
elseExpr
| Bool
semiThen Bool -> Bool -> Bool
|| Bool
semiElse
= do Bool
doAndIfThenElse <- ExtBits -> PV Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
DoAndIfThenElseBit
Bool -> PV () -> PV ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doAndIfThenElse (PV () -> PV ()) -> PV () -> PV ()
forall a b. (a -> b) -> a -> b
$ do
SrcSpan -> SDoc -> PV ()
forall (m :: * -> *). MonadP m => SrcSpan -> SDoc -> m ()
addError (a -> c -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs a
guardExpr c
elseExpr)
(String -> SDoc
text String
"Unexpected semi-colons in conditional:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
expr
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Perhaps you meant to use DoAndIfThenElse?")
| Bool
otherwise = () -> PV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where pprOptSemi :: Bool -> SDoc
pprOptSemi Bool
True = SDoc
semi
pprOptSemi Bool
False = SDoc
empty
expr :: SDoc
expr = String -> SDoc
text String
"if" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
guardExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiThen SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"then" SDoc -> SDoc -> SDoc
<+> b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
thenExpr SDoc -> SDoc -> SDoc
<> Bool -> SDoc
pprOptSemi Bool
semiElse SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"else" SDoc -> SDoc -> SDoc
<+> c -> SDoc
forall a. Outputable a => a -> SDoc
ppr c
elseExpr
splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang :: Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderOpApp l_arg op r_arg))
| RdrName -> Bool
isBangRdr (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
op)
= (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall a. a -> Maybe a
Just (Located (PatBuilder GhcPs)
l_arg, SrcSpan
-> SrcSpanLess (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l' (SrcSpan -> Located (PatBuilder GhcPs) -> PatBuilder GhcPs
forall p. SrcSpan -> Located (PatBuilder p) -> PatBuilder p
PatBuilderBang (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located RdrName
op) Located (PatBuilder GhcPs)
arg1) Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder GhcPs)]
argns)
where
l' :: SrcSpan
l' = Located RdrName -> Located (PatBuilder GhcPs) -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs Located RdrName
op Located (PatBuilder GhcPs)
arg1
(Located (PatBuilder GhcPs)
arg1,[Located (PatBuilder GhcPs)]
argns) = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall p.
Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang Located (PatBuilder GhcPs)
r_arg []
split_bang :: Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang (Located (PatBuilder p)
-> Located (SrcSpanLess (Located (PatBuilder p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [Located (PatBuilder p)]
es = Located (PatBuilder p)
-> [Located (PatBuilder p)]
-> (Located (PatBuilder p), [Located (PatBuilder p)])
split_bang Located (PatBuilder p)
f (Located (PatBuilder p)
eLocated (PatBuilder p)
-> [Located (PatBuilder p)] -> [Located (PatBuilder p)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder p)]
es)
split_bang Located (PatBuilder p)
e [Located (PatBuilder p)]
es = (Located (PatBuilder p)
e,[Located (PatBuilder p)]
es)
splitBang Located (PatBuilder GhcPs)
_ = Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
forall a. Maybe a
Nothing
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 :: * -> *) a.
(HasSrcSpan a, MonadP m, SrcSpanLess a ~ RdrName) =>
Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e [] []
where
go :: Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (PatBuilderVar (dL->L _ f))) [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
f) = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
SrcSpanLess (Located RdrName)
f, LexicalFixity
Prefix, [Located (PatBuilder GhcPs)]
es, [AddAnn]
ann))
go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderApp f e)) [Located (PatBuilder GhcPs)]
es [AddAnn]
ann = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
f (Located (PatBuilder GhcPs)
eLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es) [AddAnn]
ann
go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (PatBuilderPar e)) es :: [Located (PatBuilder GhcPs)]
es@(Located (PatBuilder GhcPs)
_:[Located (PatBuilder GhcPs)]
_) [AddAnn]
ann = Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e [Located (PatBuilder GhcPs)]
es ([AddAnn]
ann [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [AddAnn]
mkParensApiAnn SrcSpan
l)
go (Located (PatBuilder GhcPs)
-> Located (SrcSpanLess (Located (PatBuilder GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] [AddAnn]
ann
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
var) = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess a
SrcSpanLess (Located RdrName)
var, LexicalFixity
Prefix, [], [AddAnn]
ann))
go e :: Located (PatBuilder GhcPs)
e@(L SrcSpan
loc (PatBuilderOpApp Located (PatBuilder GhcPs)
l (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc' SrcSpanLess (Located RdrName)
op) Located (PatBuilder GhcPs)
r)) [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
| Just (Located (PatBuilder GhcPs)
e',[Located (PatBuilder GhcPs)]
es') <- Located (PatBuilder GhcPs)
-> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
splitBang Located (PatBuilder GhcPs)
e
= do { Bool
bang_on <- ExtBits -> m Bool
forall (m :: * -> *). MonadP m => ExtBits -> m Bool
getBit ExtBits
BangPatBit
; if Bool
bang_on then Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
e' ([Located (PatBuilder GhcPs)]
es' [Located (PatBuilder GhcPs)]
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (PatBuilder GhcPs)]
es) [AddAnn]
ann
else Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess a
SrcSpanLess (Located RdrName)
op, LexicalFixity
Infix, (Located (PatBuilder GhcPs)
lLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:Located (PatBuilder GhcPs)
rLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es), [AddAnn]
ann)) }
| Bool -> Bool
not (RdrName -> Bool
isRdrDataCon SrcSpanLess (Located RdrName)
RdrName
op)
= Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess a
SrcSpanLess (Located RdrName)
op, LexicalFixity
Infix, (Located (PatBuilder GhcPs)
lLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:Located (PatBuilder GhcPs)
rLocated (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
:[Located (PatBuilder GhcPs)]
es), [AddAnn]
ann))
| Bool
otherwise
= do { Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
mb_l <- Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)]
-> [AddAnn]
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
go Located (PatBuilder GhcPs)
l [Located (PatBuilder GhcPs)]
es [AddAnn]
ann
; case Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
mb_l of
Just (a
op', LexicalFixity
Infix, Located (PatBuilder GhcPs)
j : Located (PatBuilder GhcPs)
k : [Located (PatBuilder GhcPs)]
es', [AddAnn]
ann')
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. a -> Maybe a
Just (a
op', LexicalFixity
Infix, Located (PatBuilder GhcPs)
j Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: Located (PatBuilder GhcPs)
op_app Located (PatBuilder GhcPs)
-> [Located (PatBuilder GhcPs)] -> [Located (PatBuilder GhcPs)]
forall a. a -> [a] -> [a]
: [Located (PatBuilder GhcPs)]
es', [AddAnn]
ann'))
where
op_app :: Located (PatBuilder GhcPs)
op_app = SrcSpan
-> SrcSpanLess (Located (PatBuilder GhcPs))
-> Located (PatBuilder GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Located (PatBuilder GhcPs)
-> Located RdrName
-> Located (PatBuilder GhcPs)
-> PatBuilder GhcPs
forall p.
Located (PatBuilder p)
-> Located RdrName -> Located (PatBuilder p) -> PatBuilder p
PatBuilderOpApp Located (PatBuilder GhcPs)
k
(SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess (Located RdrName)
op) Located (PatBuilder GhcPs)
r)
Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
_ -> Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. Maybe a
Nothing }
go Located (PatBuilder GhcPs)
_ [Located (PatBuilder GhcPs)]
_ [AddAnn]
_ = Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
-> m (Maybe
(a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, LexicalFixity, [Located (PatBuilder GhcPs)], [AddAnn])
forall a. Maybe a
Nothing
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
| TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
instance Outputable TyEl where
ppr :: TyEl -> SDoc
ppr (TyElOpr RdrName
name) = RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name
ppr (TyElOpd HsKind GhcPs
ty) = HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ty
ppr (TyElKindApp SrcSpan
_ LHsType GhcPs
ki) = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ki
ppr TyEl
TyElTilde = String -> SDoc
text String
"~"
ppr TyEl
TyElBang = String -> SDoc
text String
"!"
ppr (TyElUnpackedness ([AddAnn]
_, SourceText
_, SrcUnpackedness
unpk)) = SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
ppr (TyElDocPrev HsDocString
doc) = HsDocString -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDocString
doc
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness TyEl
TyElTilde = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnTilde, SrcStrictness
SrcLazy)
tyElStrictness TyEl
TyElBang = (AnnKeywordId, SrcStrictness)
-> Maybe (AnnKeywordId, SrcStrictness)
forall a. a -> Maybe a
Just (AnnKeywordId
AnnBang, SrcStrictness
SrcStrict)
tyElStrictness TyEl
_ = Maybe (AnnKeywordId, SrcStrictness)
forall a. Maybe a
Nothing
pStrictMark
:: [Located TyEl]
-> Maybe ( Located HsSrcBang
, [AddAnn]
, [Located TyEl] )
pStrictMark :: [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (Located TyEl)
x1) : (Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located TyEl)
x2) : [Located TyEl]
xs)
| Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
, TyElUnpackedness (unpkAnns, prag, unpk) <- SrcSpanLess (Located TyEl)
x2
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2) (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
str)
, [AddAnn]
unpkAnns [AddAnn] -> [AddAnn] -> [AddAnn]
forall a. [a] -> [a] -> [a]
++ [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
strAnnId SrcSpan
l1]
, [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
| Just (AnnKeywordId
strAnnId, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess (Located TyEl)
TyEl
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
str)
, [AnnKeywordId -> SrcSpan -> AddAnn
AddAnn AnnKeywordId
strAnnId SrcSpan
l]
, [Located TyEl]
xs )
pStrictMark ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located TyEl)
x1) : [Located TyEl]
xs)
| TyElUnpackedness (anns, prag, unpk) <- SrcSpanLess (Located TyEl)
x1
= (Located HsSrcBang, [AddAnn], [Located TyEl])
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. a -> Maybe a
Just ( SrcSpan -> SrcSpanLess (Located HsSrcBang) -> Located HsSrcBang
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
prag SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
, [AddAnn]
anns
, [Located TyEl]
xs )
pStrictMark [Located TyEl]
_ = Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
forall a. Maybe a
Nothing
pBangTy
:: LHsType GhcPs
-> [Located TyEl]
-> ( Bool
, LHsType GhcPs
, P ()
, [Located TyEl] )
pBangTy :: LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy lt :: LHsType GhcPs
lt@(LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
_) [Located TyEl]
xs =
case [Located TyEl]
-> Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
pStrictMark [Located TyEl]
xs of
Maybe (Located HsSrcBang, [AddAnn], [Located TyEl])
Nothing -> (Bool
False, LHsType GhcPs
lt, () -> P ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [Located TyEl]
xs)
Just (Located HsSrcBang -> Located (SrcSpanLess (Located HsSrcBang))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l2 SrcSpanLess (Located HsSrcBang)
strictMark, [AddAnn]
anns, [Located TyEl]
xs') ->
let bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2
bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExtField
noExtField SrcSpanLess (Located HsSrcBang)
HsSrcBang
strictMark LHsType GhcPs
lt
in (Bool
True, SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bl SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
bt, SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl [AddAnn]
anns, [Located TyEl]
xs')
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l1 (TyElOpd t)) : [Located TyEl]
xs)
| (Bool
_, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l1 SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
t) [Located TyEl]
xs
, [Located TyEl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located TyEl]
xs'
= P ()
addAnns P () -> P (LHsType GhcPs) -> P (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
t'
mergeOps [Located TyEl]
all_xs = Int
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [Located TyEl]
-> P (LHsType GhcPs)
forall a t.
(HasSrcSpan a, Num t, Ord t, SrcSpanLess a ~ TyEl) =>
t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (Int
0 :: Int) [] LHsType GhcPs -> LHsType GhcPs
forall a. a -> a
id [Located TyEl]
all_xs
where
go :: t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElUnpackedness (anns, unpkSrc, unpk))):[a]
xs) =
if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
then do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP (Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs))
-> Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc
; let a :: LHsType GhcPs
a = LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc'
strictMark :: HsSrcBang
strictMark = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
unpkSrc SrcUnpackedness
unpk SrcStrictness
NoSrcStrict
bl :: SrcSpan
bl = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l (LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
a)
bt :: HsKind GhcPs
bt = XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsKind GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExtField
noExtField HsSrcBang
strictMark LHsType GhcPs
a
; SrcSpan -> [AddAnn] -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt SrcSpan
bl [AddAnn]
anns
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bl SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
bt) }
else SrcSpan -> SDoc -> P (LHsType GhcPs)
forall (m :: * -> *) a. MonadP m => SrcSpan -> SDoc -> m a
addFatalError SrcSpan
l SDoc
unpkError
where
unpkSDoc :: SDoc
unpkSDoc = case SourceText
unpkSrc of
SourceText
NoSourceText -> SrcUnpackedness -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcUnpackedness
unpk
SourceText String
str -> String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" #-}"
unpkError :: SDoc
unpkError
| Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot appear inside a type."
| [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
&& t
k t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = SDoc
unpkSDoc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be applied to a type."
| Bool
otherwise =
String -> SDoc
forall a. String -> a
panic String
"mergeOps.UNPACK: impossible position"
go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElDocPrev _)):[a]
_) =
SrcSpan -> P (LHsType GhcPs)
forall a. SrcSpan -> P a
failOpDocPrev SrcSpan
l
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
x) : [a]
xs)
| Just (AnnKeywordId
_, SrcStrictness
str) <- TyEl -> Maybe (AnnKeywordId, SrcStrictness)
tyElStrictness SrcSpanLess a
TyEl
x
, let guess :: [a] -> Bool
guess [] = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpd _)):[a]
_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpr _)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElKindApp _ _)):[a]
_) = Bool
False
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElTilde)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (SrcSpanLess a
TyElBang)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElUnpackedness _)):[a]
_) = Bool
True
guess ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElDocPrev _)):[a]
xs') = [a] -> Bool
guess [a]
xs'
guess [a]
_ = String -> Bool
forall a. String -> a
panic String
"mergeOps.go.guess: Impossible Match"
in [a] -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => [a] -> Bool
guess [a]
xs
= if Bool -> Bool
not ([LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc) Bool -> Bool -> Bool
&& (t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1 Bool -> Bool -> Bool
|| [LHsTypeArg GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTypeArg GhcPs]
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
then do { LHsType GhcPs
a <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; Located SrcStrictness -> LHsType GhcPs -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> LHsType GhcPs -> P a
failOpStrictnessCompound (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
a) }
else Located SrcStrictness -> P (LHsType GhcPs)
forall a. Located SrcStrictness -> P a
failOpStrictnessPosition (SrcSpan
-> SrcSpanLess (Located SrcStrictness) -> Located SrcStrictness
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located SrcStrictness)
SrcStrictness
str)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpr op)):[a]
xs) =
if [LHsTypeArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTypeArg GhcPs]
acc Bool -> Bool -> Bool
|| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
forall a. (HasSrcSpan a, SrcSpanLess a ~ TyEl) => a -> Bool
isTyElOpd [a]
xs)
then Located RdrName -> P (LHsType GhcPs)
forall a. Located RdrName -> P a
failOpFewArgs (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op)
else do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [] (\LHsType GhcPs
c -> LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy LHsType GhcPs
c (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located RdrName)
RdrName
op) (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc')) [a]
xs }
where
isTyElOpd :: a -> Bool
isTyElOpd (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElOpd _)) = Bool
True
isTyElOpd a
_ = Bool
False
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElTilde):[a]
xs) =
let op :: RdrName
op = RdrName
eqTyCon_RDR
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess a
TyElBang):[a]
xs) =
let op :: RdrName
op = NameSpace -> FastString -> RdrName
mkUnqual NameSpace
tcClsName (String -> FastString
fsLit String
"!")
in t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (RdrName -> TyEl
TyElOpr RdrName
op)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd a)):[a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
a)LHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go t
k [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (TyElKindApp l a)):[a]
xs) = t
-> [LHsTypeArg GhcPs]
-> (LHsType GhcPs -> LHsType GhcPs)
-> [a]
-> P (LHsType GhcPs)
go t
k (SrcSpan -> LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcPs
aLHsTypeArg GhcPs -> [LHsTypeArg GhcPs] -> [LHsTypeArg GhcPs]
forall a. a -> [a] -> [a]
:[LHsTypeArg GhcPs]
acc) LHsType GhcPs -> LHsType GhcPs
ops_acc [a]
xs
go t
_ [LHsTypeArg GhcPs]
acc LHsType GhcPs -> LHsType GhcPs
ops_acc [] = do { LHsType GhcPs
acc' <- Either (SrcSpan, SDoc) (LHsType GhcPs) -> P (LHsType GhcPs)
forall a. Either (SrcSpan, SDoc) a -> P a
eitherToP ([LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
acc)
; LHsType GhcPs -> P (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> LHsType GhcPs
ops_acc LHsType GhcPs
acc') }
go t
_ [LHsTypeArg GhcPs]
_ LHsType GhcPs -> LHsType GhcPs
_ [a]
_ = String -> P (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOps.go: Impossible Match"
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc :: [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = String -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a. String -> a
panic String
"mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg SrcSpan
_ (L SrcSpan
loc HsKind GhcPs
ki):[LHsTypeArg GhcPs]
_)
= (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
loc, String -> SDoc
text String
"Unexpected type application:" SDoc -> SDoc -> SDoc
<+> HsKind GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsKind GhcPs
ki)
mergeOpsAcc (HsValArg LHsType GhcPs
ty : [LHsTypeArg GhcPs]
xs) = LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
where
go1 :: LHsType GhcPs
-> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 :: LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [] = LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsType GhcPs)
forall a b. b -> Either a b
Right LHsType GhcPs
lhs
go1 LHsType GhcPs
lhs (LHsTypeArg GhcPs
x:[LHsTypeArg GhcPs]
xs) = case LHsTypeArg GhcPs
x of
HsValArg LHsType GhcPs
ty -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcPs
lhs LHsType GhcPs
ty) [LHsTypeArg GhcPs]
xs
HsTypeArg SrcSpan
loc LHsType GhcPs
ki -> let ty :: LHsType GhcPs
ty = XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
XAppKindTy GhcPs
loc LHsType GhcPs
lhs LHsType GhcPs
ki
in LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
ty [LHsTypeArg GhcPs]
xs
HsArgPar SrcSpan
_ -> LHsType GhcPs
-> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 LHsType GhcPs
lhs [LHsTypeArg GhcPs]
xs
mergeOpsAcc (HsArgPar SrcSpan
_: [LHsTypeArg GhcPs]
xs) = [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [LHsTypeArg GhcPs]
xs
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((Located TyEl -> Located (SrcSpanLess (Located TyEl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (TyElOpd t)):[Located TyEl]
xs)
| (Bool
True, LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs') <- LHsType GhcPs
-> [Located TyEl] -> (Bool, LHsType GhcPs, P (), [Located TyEl])
pBangTy (SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsKind GhcPs
t) [Located TyEl]
xs
= (LHsType GhcPs, P (), [Located TyEl])
-> Maybe (LHsType GhcPs, P (), [Located TyEl])
forall a. a -> Maybe a
Just (LHsType GhcPs
t', P ()
addAnns, [Located TyEl]
xs')
pInfixSide (Located TyEl
el:[Located TyEl]
xs1)
| Just LHsTypeArg GhcPs
t1 <- Located TyEl -> Maybe (LHsTypeArg GhcPs)
pLHsTypeArg Located TyEl
el
= [LHsTypeArg GhcPs]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go [LHsTypeArg GhcPs
t1]