module GHC.Parser.PostProcess (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl, mkLHsSigType,
mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
filterCTuple,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
checkImportDecl,
checkExpBlockArguments, checkCmdBlockArguments,
checkPrecP,
checkContext,
checkPattern,
checkPattern_msg,
checkMonadComp,
checkValDef,
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
mkBangTy,
mkMultTy,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
forallSym,
starSym,
warnStarIsType,
warnPrepositiveQualifiedModule,
failOpFewArgs,
failOpNotEnabledImportQualifiedPost,
failOpImportQualifiedTwice,
SumOrTuple (..),
PV,
runPV,
ECP(ECP, runECP_PV),
runECP_P,
DisambInfixOp(..),
DisambECP(..),
ecpFromExp,
ecpFromCmd,
PatBuilder
) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import GHC.Core.DataCon ( DataCon, dataConTyCon )
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Parser.Lexer
import GHC.Utils.Lexeme ( isLexCon )
import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey, eqTyCon_RDR,
tupleTyConName, cTupleTyConNameArity_maybe )
import GHC.Types.ForeignCall
import GHC.Builtin.Names ( allNameStrings )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
import GHC.Data.OrdList ( OrdList, fromOL )
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Parser.Annotation
import Data.List
import GHC.Driver.Session ( WarningFlag(..), DynFlags )
import GHC.Utils.Error ( Messages )
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
import Data.Kind ( Type )
#include "HsVersions.h"
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L loc d) = L loc (TyClD noExtField d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L loc d) = L loc (InstD noExtField d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> LayoutInfo
-> P (LTyClDecl GhcPs)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; addAnnsAt loc annst
; return (L loc (ClassDecl { tcdCExt = layoutInfo
, tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdFDs = snd (unLoc fds)
, tcdSigs = mkClassOpSigs sigs
, tcdMeths = binds
, tcdATs = ats, tcdATDefs = at_defs
, tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdDExt = noExtField,
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; return (HsDataDefn { dd_ext = noExtField
, dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = cxt
, dd_cons = data_cons
, dd_kindSig = ksig
, dd_derivs = maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType GhcPs
-> LHsType GhcPs
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; addAnnsAt loc anns
; return (L loc (SynDecl { tcdSExt = noExtField
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [Located RdrName]
-> LHsKind GhcPs
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
then return v
else addFatalError (getLoc v) $
hang (text "Expected an unqualified type constructor:") 2 (ppr v)
check_singular_lhs vs =
case vs of
[] -> panic "mkStandaloneKindSig: empty left-hand side"
[v] -> return v
_ -> addFatalError (getLoc lhs) $
vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
2 (pprWithCommas ppr vs)
, text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn bndrs lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; return (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = rhs }),
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 loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn }))))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
= return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs
-> Located (FamilyResultSig GhcPs)
-> Maybe (LInjectivityAnn GhcPs)
-> P (LTyClDecl GhcPs)
mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns
; return (L loc (FamDecl noExtField (FamilyDecl
{ fdExt = noExtField
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
, fdFixity = fixity
, fdResultSig = ksig
, fdInjectivityAnn = injAnn }))) }
where
equals_or_where = case info of
DataFamily -> empty
OpenTypeFamily -> empty
ClosedTypeFamily {} -> whereDots
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
mkSpliceDecl lexpr@(L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
= SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
= SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| otherwise
= SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName
-> [Located (Maybe FastString)]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
possible_roles = [(fsFromRole role, role) | role <- all_roles]
parse_role (L loc_role Nothing) = return $ L loc_role Nothing
parse_role (L loc_role (Just role))
= case lookup role possible_roles of
Just found_role -> return $ L loc_role $ Just found_role
Nothing ->
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
in
addFatalError loc_role
(text "Illegal role name" <+> quotes (ppr role) $$
suggestions nearby)
suggestions [] = empty
suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
suggestions list = hang (text "Perhaps you meant one of these:")
2 (pprWithCommas (quotes . ppr) list)
fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
fromSpecTyVarBndrs = mapM fromSpecTyVarBndr
fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
fromSpecTyVarBndr bndr = case bndr of
(L loc (UserTyVar xtv flag idp)) -> (check_spec flag loc)
>> return (L loc $ UserTyVar xtv () idp)
(L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)
>> return (L loc $ KindedTyVar xtv () idp k)
where
check_spec :: Specificity -> SrcSpan -> P ()
check_spec SpecifiedSpec _ = return ()
check_spec InferredSpec loc = addFatalError loc
(text "Inferred type variables are not allowed here")
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls decls = getMonoBindAll (fromOL decls)
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding
= do { (mbs, sigs, fam_ds, tfam_insts
, dfam_insts, _) <- cvBindsAndSigs binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
return $ ValBinds noExtField mbs sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs fb = do
fb' <- drop_bad_decls (fromOL fb)
return (partitionBindsAndSigs (getMonoBindAll fb'))
where
drop_bad_decls [] = return []
drop_bad_decls (L l (SpliceD _ d) : ds) = do
addError l $
hang (text "Declaration splices are allowed only" <+>
text "at the top level:")
2 (ppr d)
drop_bad_decls ds
drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
-> (LHsBind GhcPs, [LHsDecl GhcPs])
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
, fun_matches =
MG { mg_alts = (L _ mtchs1) } }))
binds
| has_args mtchs1
= go mtchs1 loc1 binds []
where
go mtchs loc
((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
, fun_matches =
MG { mg_alts = (L _ mtchs2) } })))
: binds) _
| f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
= ( L loc (makeFunBind fun_id1 (reverse mtchs))
, (reverse doc_decls) ++ binds)
getMonoBind bind binds = (bind, binds)
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [] = []
getMonoBindAll (L l (ValD _ b) : ds) =
let (L l' b', ds') = getMonoBind (L l b) ds
in L l' (ValD noExtField b') : getMonoBindAll ds'
getMonoBindAll (d : ds) = d : getMonoBindAll ds
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = panic "GHC.Parser.PostProcess.has_args"
has_args (L _ (Match { m_pats = args }) : _) = not (null args)
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= Left (loc, msg)
where
occ = rdrNameOcc tc
msg = text "Not a data constructor:" <+> quotes (ppr tc)
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
fromDecl (L loc decl@(ValD _ (PatBind _
pat@(L _ (ConPat NoExtField ln@(L _ name) details))
rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt, m_pats = pats
, m_grhss = rhs }
where
ctxt = FunRhs { mc_fun = ln
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
InfixCon p1 p2 -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt
, m_pats = [p1, p2]
, m_grhss = rhs }
where
ctxt = FunRhs { mc_fun = ln
, mc_fixity = Infix
, mc_strictness = NoSrcStrict }
RecCon{} -> recordPatSynErr loc pat
; return $ L loc match }
fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
addFatalError loc $
text "pattern synonym 'where' clause must contain a single binding:" $$
ppr decl
wrongNameBindingErr loc decl =
addFatalError loc $
text "pattern synonym 'where' clause must bind the pattern synonym's name"
<+> quotes (ppr patsyn_name) $$ ppr decl
wrongNumberErr loc =
addFatalError loc $
text "pattern synonym 'where' clause cannot be empty" $$
text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
recordPatSynErr loc pat =
addFatalError loc $
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 name mb_forall mb_cxt args
= ConDeclH98 { con_ext = noExtField
, con_name = name
, con_forall = noLoc $ isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
, con_args = args
, con_doc = Nothing }
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
-> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty = do
let (args, res_ty, anns)
| L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
= (RecCon (L loc rf), res_ty, [])
| otherwise
= let (arg_types, res_type, anns) = splitHsFunType body_ty
in (PrefixCon arg_types, res_type, anns)
pure ( ConDeclGADT { con_g_ext = noExtField
, con_names = names
, con_forall = L (getLoc ty) $ isJust mtvs
, con_qvars = fromMaybe [] mtvs
, con_mb_cxt = mcxt
, con_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns )
where
(mtvs, mcxt, body_ty) = splitLHsGadtTy ty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n) ns
| Just thing <- wiredInNameTyThing_maybe n
= setWiredInNameSpace thing ns
| isExternalName n
= Orig (nameModule n) occ
| otherwise
= Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
where
occ = setOccNameSpace ns (nameOccName n)
setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon tc) ns
| isDataConNameSpace ns
= ty_con_data_con tc
| isTcClsNameSpace ns
= Exact (getName tc)
setWiredInNameSpace (AConLike (RealDataCon dc)) ns
| isTcClsNameSpace ns
= data_con_ty_con dc
| isDataConNameSpace ns
= Exact (getName dc)
setWiredInNameSpace thing ns
= pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
ty_con_data_con :: TyCon -> RdrName
ty_con_data_con tc
| isTupleTyCon tc
, Just dc <- tyConSingleDataCon_maybe tc
= Exact (getName dc)
| tc `hasKey` listTyConKey
= Exact nilDataConName
| otherwise
= Unqual (setOccNameSpace srcDataName (getOccName tc))
data_con_ty_con :: DataCon -> RdrName
data_con_ty_con dc
| let tc = dataConTyCon dc
, isTupleTyCon tc
= Exact (getName tc)
| dc `hasKey` nilDataConKey
= Exact listTyConName
| otherwise
= Unqual (setOccNameSpace tcClsName (getOccName dc))
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact n)
| Just arity <- cTupleTyConNameArity_maybe n
= Exact $ tupleTyConName BoxedTuple arity
filterCTuple rdr = rdr
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (loc, doc)) = addFatalError loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P ( LHsQTyVars GhcPs
, [AddAnn] )
checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
; return (mkHsQTvs tvs, concat anns) }
where
check (HsTypeArg _ ki@(L loc _))
= addFatalError loc $
vcat [ text "Unexpected type application" <+>
text "@" <> ppr ki
, text "In the" <+> pp_what <+>
ptext (sLit "declaration for") <+> quotes (ppr tc)]
check (HsValArg ty) = chkParens [] ty
check (HsArgPar sp) = addFatalError sp $
vcat [text "Malformed" <+> pp_what
<+> text "declaration for" <+> quotes (ppr tc)]
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs, [AddAnn])
chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
chkParens acc ty = do
tv <- chk ty
return (tv, reverse acc)
chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
| isRdrTyVar tv = return (L l (KindedTyVar noExtField () (L lv tv) k))
chk (L l (HsTyVar _ _ (L ltv tv)))
| isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv)))
chk t@(L loc _)
= addFatalError loc $
vcat [ text "Unexpected type" <+> quotes (ppr t)
, text "In the" <+> pp_what
<+> ptext (sLit "declaration for") <+> quotes tc'
, vcat[ (text "A" <+> pp_what
<+> ptext (sLit "declaration should have form"))
, nest 2
(pp_what
<+> tc'
<+> hsep (map text (takeList tparms allNameStrings))
<+> equals_or_where) ] ]
tc' = ppr $ fmap filterCTuple tc
whereDots, equalsDots :: SDoc
whereDots = text "where ..."
equalsDots = text "= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just c)
= do allowed <- getBit DatatypeContextsBit
unless allowed $
addError (getLoc c)
(text "Illegal datatype context (use DatatypeContexts):"
<+> pprLHsContext c)
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = fmap (fmap cvt_one)
where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v
cvt_one (RuleTyTmVar v (Just sig)) =
RuleBndrSig noExtField v (mkHsPatSigType sig)
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = fmap (fmap cvt_one)
where cvt_one (RuleTyTmVar v Nothing)
= UserTyVar noExtField () (fmap tm_to_ty v)
cvt_one (RuleTyTmVar v (Just sig))
= KindedTyVar noExtField () (fmap tm_to_ty v) sig
tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
tm_to_ty _ = panic "mkRuleTyVarBndrs"
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
where check (L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
(addFatalError loc (text $ "parse error on input "
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $
text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
return lr
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(L span (_, []))
= do gadtSyntax <- getBit GadtSyntaxBit
unless gadtSyntax $ addError span $ vcat
[ text "Illegal keyword 'where' in data declaration"
, text "Perhaps you intended to use GADTs or a similar language"
, text "extension to enable syntax: data T where"
]
return gadts
checkEmptyGADTs gadts = return gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName,
[LHsTypeArg GhcPs],
LexicalFixity,
[AddAnn])
checkTyClHdr is_cls ty
= goL ty [] [] Prefix
where
goL (L l ty) acc ann fix = go l ty acc ann fix
go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (starSym isUni)
; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix
| isRdrTc tc = return (ltc, acc, fix, ann)
go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
go l _ _ _ _
= addFatalError l (text "Malformed head of type or class declaration:"
<+> ppr ty)
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = do
case unLoc expr of
HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr
HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr
HsLam {} -> check (text "lambda expression") expr
HsCase {} -> check (text "case expression") expr
HsLamCase {} -> check (text "lambda-case expression") expr
HsLet {} -> check (text "let expression") expr
HsIf {} -> check (text "if expression") expr
HsProc {} -> check (text "proc expression") expr
_ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
HsCmdLam {} -> check (text "lambda command") cmd
HsCmdCase {} -> check (text "case command") cmd
HsCmdIf {} -> check (text "if command") cmd
HsCmdLet {} -> check (text "let command") cmd
HsCmdDo {} -> check (text "do command") cmd
_ -> return ()
check :: Outputable a => SDoc -> Located a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
addError (getLoc a) $
text "Unexpected " <> element <> text " in function application:"
$$ nest 4 (ppr a)
$$ text "You could write it with parentheses"
$$ text "Or perhaps you meant to enable BlockArguments?"
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext (L l orig_t)
= check [] (L l orig_t)
where
check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
= return (anns ++ mkParensApiAnn lp,L l ts)
check anns (L lp1 (HsParTy _ ty))
= check anns' ty
where anns' = if l == lp1 then anns
else (anns ++ mkParensApiAnn lp1)
check _anns _t = return ([],L l [L l orig_t])
checkImportDecl :: Maybe (Located Token)
-> Maybe (Located Token)
-> P ()
checkImportDecl mPre mPost = do
let whenJust mg f = maybe (pure ()) f mg
importQualifiedPostEnabled <- getBit ImportQualifiedPostBit
whenJust mPost $ \post ->
when (not importQualifiedPostEnabled) $
failOpNotEnabledImportQualifiedPost (getLoc post)
whenJust mPost $ \post ->
when (isJust mPre) $
failOpImportQualifiedTwice (getLoc post)
whenJust mPre $ \pre ->
warnPrepositiveQualifiedModule (getLoc pre)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = runPV . checkLPat
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L _ c))) args
| isRdrDataCon c = return . L loc $ ConPat
{ pat_con_ext = noExtField
, pat_con = L l c
, pat_args = PrefixCon args
}
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l (ppr e)
checkPat loc (L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
checkPat loc (L _ e) []
= do p <- checkAPat loc e
return (L loc p)
checkPat loc e _
= patFail loc (ppr e)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
PatBuilderPat p -> return p
PatBuilderVar x -> return (VarPat noExtField x)
PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
PatBuilderOpApp
(L nloc (PatBuilderVar (L _ n)))
(L _ plus)
(L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit))
PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do
addError (getLoc op) $
text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$
perhaps_as_pat
return (WildPat noExtField)
PatBuilderOpApp l (L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
return $ ConPat
{ pat_con_ext = noExtField
, pat_con = L cl c
, pat_args = InfixCon l r
}
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField))
_ -> patFail loc (ppr e0)
placeHolderPunRhs :: DisambECP b => PV (Located b)
placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR)
plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+")
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
return (L l (fld { hsRecFieldArg = p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
opIsAt :: RdrName -> Bool
opIsAt e = e == mkUnqual varName (fsLit "@")
checkValDef :: Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef lhs (Just sig) grhss
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
checkValDef lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind NoSrcStrict ann (getLoc lhs)
fun is_infix pats (L l grhss)
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- runPV_msg param_hint (mapM checkLPat pats)
let match_span = combineSrcSpans lhs_loc rhs_span
return (ann, makeFunBind fun
[L match_span (Match { m_ext = noExtField
, m_ctxt = FunRhs
{ mc_fun = fun
, mc_fixity = is_infix
, mc_strictness = strictness }
, m_pats = ps
, m_grhss = grhss })])
where
param_hint
| Infix <- is_infix
= text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$
if opIsAt (unLoc fun) then perhaps_as_pat else empty
| otherwise = empty
perhaps_as_pat :: SDoc
perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind fn ms
= FunBind { fun_ext = noExtField,
fun_id = fn,
fun_matches = mkMatchGroup FromSource ms,
fun_tick = [] }
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind lhs (L rhs_span (_,grhss))
| BangPat _ p <- unLoc lhs
, VarPat _ v <- unLoc p
= return ([], makeFunBind v [L match_span (m v)])
where
match_span = combineSrcSpans (getLoc lhs) rhs_span
m v = Match { m_ext = noExtField
, m_ctxt = FunRhs { mc_fun = v
, mc_fixity = Prefix
, mc_strictness = SrcStrict }
, m_pats = []
, m_grhss = grhss }
checkPatBind lhs (L _ (_,grhss))
= return ([],PatBind noExtField lhs grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
checkValSigLhs lhs@(L l _)
= addFatalError l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")
$$ text hint)
where
hint | foreign_RDR `looks_like` lhs
= "Perhaps you meant to use ForeignFunctionInterface?"
| default_RDR `looks_like` lhs
= "Perhaps you meant to use DefaultSignatures?"
| pattern_RDR `looks_like` lhs
= "Perhaps you meant to use PatternSynonyms?"
| otherwise
= "Should be of form <variable> :: <type>"
looks_like s (L _ (HsVar _ (L _ v))) = v == s
looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse
:: (Outputable a, Outputable b, Outputable c)
=> Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do
addError (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:"
$$ nest 4 expr
$$ text "Perhaps you meant to use DoAndIfThenElse?")
| otherwise = return ()
where pprOptSemi True = semi
pprOptSemi False = empty
expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
text "else" <+> ppr elseExpr
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
isFunLhs e = go e [] []
where
go (L loc (PatBuilderVar (L _ f))) es ann
| not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann
| not (isRdrDataCon op)
= return (Just (L loc' op, Infix, (l:r:es), ann))
| otherwise
= do { mb_l <- go l es ann
; case mb_l of
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
op_app = L loc (PatBuilderOpApp k
(L loc' op) r)
_ -> return Nothing }
go _ _ _ = return Nothing
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
ppr (TyElKindApp _ ki) = text "@" <> ppr ki
ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
pUnpackedness
:: [Located TyEl]
-> Maybe ( SrcSpan
, [AddAnn]
, SourceText
, SrcUnpackedness
, [Located TyEl] )
pUnpackedness (L l x1 : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
= Just (l, anns, prag, unpk, xs)
pUnpackedness _ = Nothing
pBangTy
:: LHsType GhcPs
-> [Located TyEl]
-> ( Bool
, LHsType GhcPs
, P ()
, [Located TyEl] )
pBangTy lt@(L l1 _) xs =
case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
Just (l2, anns, prag, unpk, xs') ->
let bl = combineSrcSpans l1 l2
(anns2, bt) = addUnpackedness (prag, unpk) lt
in (True, L bl bt, addAnnsAt bl (anns ++ anns2), xs')
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy strictness =
HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs)
addUnpackedness (prag, unpk) (L l (HsBangTy x bang t))
| HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
= let
anns = case strictness of
SrcLazy -> [AddAnn AnnTilde (srcSpanFirstCharacter l)]
SrcStrict -> [AddAnn AnnBang (srcSpanFirstCharacter l)]
NoSrcStrict -> []
in (anns, HsBangTy x (HsSrcBang prag unpk strictness) t)
addUnpackedness (prag, unpk) t
= ([], HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps ((L l1 (TyElOpd t)) : xs)
| (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
, null xs'
= addAnns >> return t'
mergeOps all_xs = go (0 :: Int) [] id all_xs
where
go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExtField strictMark a
; addAnnsAt bl anns
; return (L bl bt) }
else addFatalError l unpkError
where
unpkSDoc = case unpkSrc of
NoSourceText -> ppr unpk
SourceText str -> text str <> text " #-}"
unpkError
| not (null xs) = unpkSDoc <+> text "cannot appear inside a type."
| null acc && k == 0 = unpkSDoc <+> text "must be applied to a type."
| otherwise =
panic "mergeOps.UNPACK: impossible position"
go k acc ops_acc ((L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
then failOpFewArgs (L l op)
else do { acc' <- eitherToP (mergeOpsAcc acc)
; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }
where
isTyElOpd (L _ (TyElOpd _)) = True
isTyElOpd _ = False
go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs
go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg _ (L loc ki):_)
= Left (loc, text "Unexpected type application:" <+> ppr ki)
mergeOpsAcc (HsValArg ty : xs) = go1 ty xs
where
go1 :: LHsType GhcPs
-> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 lhs [] = Right lhs
go1 lhs (x:xs) = case x of
HsValArg ty -> go1 (mkHsAppTy lhs ty) xs
HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki
in go1 ty xs
HsArgPar _ -> go1 lhs xs
mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
pInfixSide ((L l (TyElOpd t)):xs)
| (True, t', addAnns, xs') <- pBangTy (L l t) xs
= Just (t', addAnns, xs')
pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
= go [t1] xs1
where
go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go acc (el:xs)
| Just t <- pLHsTypeArg el
= go (t:acc) xs
go acc xs = case mergeOpsAcc acc of
Left _ -> Nothing
Right acc' -> Just (acc', pure (), xs)
pInfixSide _ = Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))
pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
orErr :: Maybe a -> b -> Either b a
orErr (Just a) _ = Right a
orErr Nothing b = Left b
mergeDataCon
:: [Located TyEl]
-> P ( Located RdrName
, HsConDeclDetails GhcPs
)
mergeDataCon all_xs =
do { (addAnns, a) <- eitherToP res
; addAnns
; return a }
where
res = goFirst all_xs
goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (pure (), (data_con, PrefixCon [])) }
goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)
| [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs
= do { data_con <- tyConToDataCon l' tc
; return (pure (), (data_con, RecCon (L l fields))) }
goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
= return ( pure ()
, ( L l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon (map hsLinear ts) ) )
goFirst ((L l (TyElOpd t)):xs)
| (_, t', addAnns, xs') <- pBangTy (L l t) xs
= go addAnns [t'] xs'
goFirst (L l (TyElKindApp _ _):_)
= goInfix Monoid.<> Left (l, kindAppErr)
goFirst xs
= go (pure ()) [] xs
go addAnns ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (addAnns, (data_con, PrefixCon (map hsLinear ts))) }
go addAnns ts ((L l (TyElOpd t)):xs)
| (_, t', addAnns', xs') <- pBangTy (L l t) xs
= go (addAnns >> addAnns') (t':ts) xs'
go _ _ ((L _ (TyElOpr _)):_) =
goInfix
go _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr)
go _ _ _ = Left malformedErr
where
malformedErr =
( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)
, text "Cannot parse data constructor" <+>
text "in a data/newtype declaration:" $$
nest 2 (hsep . reverse $ map ppr all_xs))
goInfix =
do { let xs0 = all_xs
; (rhs, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
; (op, xs3) <- case xs1 of
(L l (TyElOpr op)) : xs3 ->
do { data_con <- tyConToDataCon l op
; return (data_con, xs3) }
_ -> Left malformedErr
; (lhs, lhs_addAnns, xs5) <- pInfixSide xs3 `orErr` malformedErr
; unless (null xs5) (Left malformedErr)
; let addAnns = lhs_addAnns >> rhs_addAnns
; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs))) }
where
malformedErr =
( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)
, text "Cannot parse an infix data constructor" <+>
text "in a data/newtype declaration:" $$
nest 2 (hsep . reverse $ map ppr all_xs))
kindAppErr =
text "Unexpected kind application" <+>
text "in a data/newtype declaration:" $$
nest 2 (hsep . reverse $ map ppr all_xs)
checkMonadComp :: PV (HsStmtContext GhcRn)
checkMonadComp = do
monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions
then MonadComp
else ListComp
newtype ECP =
ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
runECP_P :: DisambECP b => ECP -> P (Located b)
runECP_P p = runPV (runECP_PV p)
ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp a = ECP (ecpFromExp' a)
ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd a = ECP (ecpFromCmd' a)
class DisambInfixOp b where
mkHsVarOpPV :: Located RdrName -> PV (Located b)
mkHsConOpPV :: Located RdrName -> PV (Located b)
mkHsInfixHolePV :: SrcSpan -> PV (Located b)
instance DisambInfixOp (HsExpr GhcPs) where
mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
mkHsInfixHolePV l = return $ L l hsHoleExpr
instance DisambInfixOp RdrName where
mkHsConOpPV (L l v) = return $ L l v
mkHsVarOpPV (L l v) = return $ L l v
mkHsInfixHolePV l =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
class b ~ (Body b) GhcPs => DisambECP b where
type Body b :: Type -> Type
ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b)
ecpFromExp' :: LHsExpr GhcPs -> PV (Located b)
mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)
type InfixOp b
superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b)
mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b)
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b)
mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
type FunArg b
superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)
mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)
mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool
-> Located b
-> Bool
-> Located b
-> PV (Located b)
mkHsDoPV ::
SrcSpan ->
Maybe ModuleName ->
Located [LStmt GhcPs (Located b)] ->
PV (Located b)
mkHsParPV :: SrcSpan -> Located b -> PV (Located b)
mkHsVarPV :: Located RdrName -> PV (Located b)
mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)
mkHsWildCardPV :: SrcSpan -> PV (Located b)
mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b)
mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
mkHsRecordPV ::
SrcSpan ->
SrcSpan ->
Located b ->
([LHsRecField GhcPs (Located b)], Maybe SrcSpan) ->
PV (Located b)
mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b)
mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)
mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b)
mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)
mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b)
mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)
mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)
rejectPragmaPV :: Located b -> PV ()
instance DisambECP (HsCmd GhcPs) where
type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' = return
ecpFromExp' (L l e) = cmdFail l (ppr e)
mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)
mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c
return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg)
mkHsLamCasePV l mg = return $ L l (HsCmdLamCase noExtField mg)
type FunArg (HsCmd GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l c e = do
checkCmdBlockArguments c
checkExpBlockArguments e
return $ L l (HsCmdApp noExtField c e)
mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsCmdIf c a b)
mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)
mkHsDoPV l (Just m) _ =
cmdFail l $
text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
$$ text "qualified 'do' is not supported in commands."
mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
mkHsVarPV (L l v) = cmdFail l (ppr v)
mkHsLitPV (L l a) = cmdFail l (ppr a)
mkHsOverLitPV (L l a) = cmdFail l (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig)
mkHsExplicitListPV l xs = cmdFail l $
brackets (fsep (punctuate comma (map ppr xs)))
mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
mkHsSectionR_PV l op c = cmdFail l $
let pp_op = fromMaybe (panic "cannot print infix operator")
(ppr_infix_expr (unLoc op))
in pp_op <> ppr c
mkHsViewPatPV l a b = cmdFail l $
ppr a <+> text "->" <+> ppr b
mkHsAsPatPV l v c = cmdFail l $
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV l c = cmdFail l $
text "~" <> ppr c
mkHsBangPatPV l c = cmdFail l $
text "!" <> ppr c
mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a)
rejectPragmaPV _ = return ()
cmdFail :: SrcSpan -> SDoc -> PV a
cmdFail loc e = addFatalError loc $
hang (text "Parse error in command:") 2 (ppr e)
instance DisambECP (HsExpr GhcPs) where
type Body (HsExpr GhcPs) = HsExpr
ecpFromCmd' (L l c) = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
return (L l hsHoleExpr)
ecpFromExp' = return
mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
return $ L l $ OpApp noExtField e1 op e2
mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)
mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l e1 e2 = do
checkExpBlockArguments e1
checkExpBlockArguments e2
return $ L l (HsApp noExtField e1 e2)
mkHsAppTypePV l e t = do
checkExpBlockArguments e
return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsIf c a b)
mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)
mkHsParPV l e = return $ L l (HsPar noExtField e)
mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)
mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
mkHsWildCardPV l = return $ L l hsHoleExpr
mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
checkRecordSyntax (L l r)
mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
mkHsAsPatPV l v e =
patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
text "Type application syntax requires a space before '@'"
mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $
text "Did you mean to add a space after the '~'?"
mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
text "Did you mean to add a space after the '!'?"
mkSumOrTuplePV = mkSumOrTupleExpr
rejectPragmaPV (L _ (OpApp _ _ _ e)) =
rejectPragmaPV e
rejectPragmaPV (L l (HsPragE _ prag _)) =
addError l $
hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
rejectPragmaPV _ = return ()
patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr item l e explanation =
do { addError l $
sep [text item <+> text "in expression context:",
nest 4 (ppr e)] $$
explanation
; return (L l hsHoleExpr) }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
data PatBuilder p
= PatBuilderPat (Pat p)
| PatBuilderPar (Located (PatBuilder p))
| PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
| PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
| PatBuilderVar (Located RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
instance Outputable (PatBuilder GhcPs) where
ppr (PatBuilderPat p) = ppr p
ppr (PatBuilderPar (L _ p)) = parens (ppr p)
ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
ppr (PatBuilderVar v) = ppr v
ppr (PatBuilderOverLit l) = ppr l
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
ecpFromCmd' (L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
ecpFromExp' (L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
mkHsLamPV l _ = addFatalError l $
text "Lambda-syntax in pattern." $$
text "Pattern matching on functions is not possible."
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern"
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsAppTypePV l _ _ = addFatalError l $
text "Type applications in patterns are not yet supported"
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"
mkHsParPV l p = return $ L l (PatBuilderPar p)
mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedStringLitPat lit
return $ L l (PatBuilderPat (LitPat noExtField a))
mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
mkHsTySigPV l b sig = do
p <- checkLPat b
return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
return (L l (PatBuilderPat (ListPat noExtField ps)))
mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
checkRecordSyntax (L l r)
mkHsNegAppPV l (L lp p) = do
lit <- case p of
PatBuilderOverLit pos_lit -> return (L lp pos_lit)
_ -> patFail l (text "-" <> ppr p)
return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
mkHsViewPatPV l a b = do
p <- checkLPat b
return $ L l (PatBuilderPat (ViewPat noExtField a p))
mkHsAsPatPV l v e = do
p <- checkLPat e
return $ L l (PatBuilderPat (AsPat noExtField v p))
mkHsLazyPatPV l e = do
p <- checkLPat e
return $ L l (PatBuilderPat (LazyPat noExtField p))
mkHsBangPatPV l e = do
p <- checkLPat e
let pb = BangPat noExtField p
hintBangPat l pb
return $ L l (PatBuilderPat pb)
mkSumOrTuplePV = mkSumOrTuplePat
rejectPragmaPV _ = return ()
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat (L loc lit) =
case lit of
HsStringPrim _ _
-> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
_ -> return ()
mkPatRec ::
Located (PatBuilder GhcPs) ->
HsRecFields GhcPs (Located (PatBuilder GhcPs)) ->
PV (PatBuilder GhcPs)
mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
| isRdrDataCon (unLoc c)
= do fs <- mapM checkPatField fs
return $ PatBuilderPat $ ConPat
{ pat_con_ext = noExtField
, pat_con = c
, pat_args = RecCon (HsRecFields fs dd)
}
mkPatRec p _ =
addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
checkPrecP
:: Located (SourceText,Int)
-> Located (OrdList (Located RdrName))
-> P ()
checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
| otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
where
specialOp op = unLoc op `elem` [ eqTyCon_RDR
, getRdrName unrestrictedFunTyCon ]
mkRecConstrOrUpdate
:: LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
= RecordUpd { rupd_ext = noExtField
, rupd_expr = exp
, rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
= RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds }
mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
, rec_dotdot = Just (L s (length fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExtField rdr)) arg pun
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
mkInlinePragma src (inl, match_info) mb_act
= InlinePragma { inl_src = src
, inl_inline = inl
, inl_sat = Nothing
, inl_act = act
, inl_rule = match_info }
where
act = case mb_act of
Just act -> act
Nothing ->
case inl of
NoInline -> NeverActive
_other -> AlwaysActive
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
case unLoc cconv of
CCallConv -> mkCImport
CApiConv -> mkCImport
StdCallConv -> mkCImport
PrimCallConv -> mkOtherImport
JavaScriptCallConv -> mkOtherImport
where
mkCImport = do
let e = unpackFS entity
case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError loc (text "Malformed entity string")
Just importSpec -> returnSpec importSpec
mkOtherImport = returnSpec importSpec
where
entity' = if nullFS entity
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
returnSpec spec = return $ ForD noExtField $ ForeignImport
{ fd_i_ext = noExtField
, fd_name = v
, fd_sig_ty = ty
, fd_fi = spec
}
parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport cconv safety nm str sourceText =
listToMaybe $ map fst $ filter (null.snd) $
readP_to_S parse str
where
parse = do
skipSpaces
r <- choice [
string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
string "wrapper" >> return (mk Nothing CWrapper),
do optional (token "static" >> skipSpaces)
((mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char
skipSpaces
mk (Just (Header (SourceText h) (mkFastString h)))
<$> cimp nm))
]
skipSpaces
return r
token str = do _ <- string str
toks <- look
case toks of
c : _
| id_char c -> pfail
_ -> return ()
mk h n = CImport cconv safety h n sourceText
hdr_char c = not (isSpace c)
id_first_char c = isAlpha c || c == '_'
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
+++ (do isFun <- case unLoc cconv of
CApiConv ->
option True
(do token "value"
skipSpaces
return False)
_ -> return True
cid' <- cid
return (CFunction (StaticTarget NoSourceText cid'
Nothing isFun)))
where
cid = return nm +++
(do c <- satisfy id_first_char
cs <- many (satisfy id_char)
return (mkFastString (c:cs)))
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
= return $ ForD noExtField $
ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty
, fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
(L le esrc) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
mkExtName :: RdrName -> CLabelString
mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
data ImpExpSubSpec = ImpExpAbs
| ImpExpAll
| ImpExpList [Located ImpExpQcSpec]
| ImpExpAllWith [Located ImpExpQcSpec]
data ImpExpQcSpec = ImpExpQcName (Located RdrName)
| ImpExpQcType (Located RdrName)
| ImpExpQcWildcard
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp (L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
-> return $ IEVar noExtField (L l (ieNameFromSpec specname))
| otherwise -> IEThingAbs noExtField . L l <$> nameT
ImpExpAll -> IEThingAll noExtField . L l <$> nameT
ImpExpList xs ->
(\newName -> IEThingWith noExtField (L l newName)
NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- getBit PatternSynonymsBit
if allowed
then
let withs = map unLoc xs
pos = maybe NoIEWildcard IEWildcard
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
-> IEThingWith noExtField (L l newName) pos ies [])
<$> nameT
else addFatalError l
(text "Illegal export form (use PatternSynonyms to enable)")
where
name = ieNameVal specname
nameT =
if isVarNameSpace (rdrNameSpace name)
then addFatalError l
(text "Expecting a type constructor but found a variable,"
<+> quotes (ppr name) <> text "."
$$ if isSymOcc $ rdrNameOcc name
then text "If" <+> quotes (ppr name)
<+> text "is a type constructor"
<+> text "then enable ExplicitNamespaces and use the 'type' keyword."
else empty)
else return $ ieNameFromSpec specname
ieNameVal (ImpExpQcName ln) = unLoc ln
ieNameVal (ImpExpQcType ln) = unLoc ln
ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
ieNameFromSpec (ImpExpQcName ln) = IEName ln
ieNameFromSpec (ImpExpQcType ln) = IEType ln
ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
wrapped = map (mapLoc ieNameFromSpec)
mkTypeImpExp :: Located RdrName
-> P (Located RdrName)
mkTypeImpExp name =
do allowed <- getBit ExplicitNamespacesBit
unless allowed $ addError (getLoc name) $
text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
return (fmap (`setRdrNameSpace` tcClsName) name)
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
checkImportSpec ie@(L _ specs) =
case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
importSpecError l =
addFatalError l
(text "Illegal import form, this syntax can only be used to bundle"
$+$ text "pattern synonyms with types in module exports.")
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L _ ImpExpQcWildcard] =
return ([], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
else return $ ([], ImpExpList xs)
isImpExpQcWildcard :: ImpExpQcSpec -> Bool
isImpExpQcWildcard ImpExpQcWildcard = True
isImpExpQcWildcard _ = False
warnPrepositiveQualifiedModule :: SrcSpan -> P ()
warnPrepositiveQualifiedModule span =
addWarning Opt_WarnPrepositiveQualifiedModule span msg
where
msg = text "Found" <+> quotes (text "qualified")
<+> text "in prepositive position"
$$ text "Suggested fix: place " <+> quotes (text "qualified")
<+> text "after the module name instead."
failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
failOpNotEnabledImportQualifiedPost loc = addError loc msg
where
msg = text "Found" <+> quotes (text "qualified")
<+> text "in postpositive position. "
$$ text "To allow this, enable language extension 'ImportQualifiedPost'"
failOpImportQualifiedTwice :: SrcSpan -> P ()
failOpImportQualifiedTwice loc = addError loc msg
where
msg = text "Multiple occurrences of 'qualified'"
warnStarIsType :: SrcSpan -> P ()
warnStarIsType span = addWarning Opt_WarnStarIsType span msg
where
msg = text "Using" <+> quotes (text "*")
<+> text "(or its Unicode variant) to mean"
<+> quotes (text "Data.Kind.Type")
$$ text "relies on the StarIsType extension, which will become"
$$ text "deprecated in the future."
$$ text "Suggested fix: use" <+> quotes (text "Type")
<+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
warnStarBndr :: SrcSpan -> P ()
warnStarBndr span = addWarning Opt_WarnStarBinder span msg
where
msg = text "Found binding occurrence of" <+> quotes (text "*")
<+> text "yet StarIsType is enabled."
$$ text "NB. To use (or export) this operator in"
<+> text "modules with StarIsType,"
$$ text " including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let msg = too_few $$ starInfo star_is_type op
; addFatalError loc msg }
where
too_few = text "Operator applied to too few arguments:" <+> ppr op
data PV_Context =
PV_Context
{ pv_options :: ParserFlags
, pv_hint :: SDoc
}
data PV_Accum =
PV_Accum
{ pv_messages :: DynFlags -> Messages
, pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
, pv_comment_q :: [RealLocated AnnotationComment]
, pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
}
data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }
instance Functor PV where
fmap = liftM
instance Applicative PV where
pure a = a `seq` PV (\_ acc -> PV_Ok acc a)
(<*>) = ap
instance Monad PV where
m >>= f = PV $ \ctx acc ->
case unPV m ctx acc of
PV_Ok acc' a -> unPV (f a) ctx acc'
PV_Failed acc' -> PV_Failed acc'
runPV :: PV a -> P a
runPV = runPV_msg empty
runPV_msg :: SDoc -> PV a -> P a
runPV_msg msg m =
P $ \s ->
let
pv_ctx = PV_Context
{ pv_options = options s
, pv_hint = msg }
pv_acc = PV_Accum
{ pv_messages = messages s
, pv_annotations = annotations s
, pv_comment_q = comment_q s
, pv_annotations_comments = annotations_comments s }
mkPState acc' =
s { messages = pv_messages acc'
, annotations = pv_annotations acc'
, comment_q = pv_comment_q acc'
, annotations_comments = pv_annotations_comments acc' }
in
case unPV m pv_ctx pv_acc of
PV_Ok acc' a -> POk (mkPState acc') a
PV_Failed acc' -> PFailed (mkPState acc')
localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
localPV_msg f m =
let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in
PV (\ctx acc -> unPV m (modifyHint ctx) acc)
instance MonadP PV where
addError srcspan msg =
PV $ \ctx acc@PV_Accum{pv_messages=m} ->
let msg' = msg $$ pv_hint ctx in
PV_Ok acc{pv_messages=appendError srcspan msg' m} ()
addWarning option srcspan warning =
PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->
PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()
addFatalError srcspan msg =
addError srcspan msg >> PV (const PV_Failed)
getBit ext =
PV $ \ctx acc ->
let b = ext `xtest` pExtsBitmap (pv_options ctx) in
PV_Ok acc $! b
addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) =
PV $ \_ acc ->
let
(comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)
annotations_comments' = new_ann_comments ++ pv_annotations_comments acc
annotations' = ((l,a), [v]) : pv_annotations acc
acc' = acc
{ pv_annotations = annotations'
, pv_comment_q = comment_q'
, pv_annotations_comments = annotations_comments' }
in
PV_Ok acc' ()
addAnnotation _ _ _ = return ()
hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
addError span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple b
= Sum ConTag Arity (Located b)
| Tuple [Located (Maybe (Located b))]
pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple boxity = \case
Sum alt arity e ->
parOpen <+> ppr_bars (alt 1) <+> ppr e <+> ppr_bars (arity alt)
<+> parClose
Tuple xs ->
parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
<> parClose
where
ppr_bars n = hsep (replicate n (Outputable.char '|'))
(parOpen, parClose) =
case boxity of
Boxed -> (text "(", text ")")
Unboxed -> (text "(#", text "#)")
mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
mkSumOrTupleExpr l boxity (Tuple es) =
return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity)
where
toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = mapLoc (maybe missingTupArg (Present noExtField))
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
return $ L l (ExplicitSum noExtField alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
mkSumOrTuplePat l boxity (Tuple ps) = do
ps' <- traverse toTupPat ps
return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity))
where
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
toTupPat (L l p) = case p of
Nothing -> addFatalError l (text "Tuple section in pattern context")
Just p' -> checkLPat p'
mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
in L loc (mkHsOpTy x op y)
mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)
mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1)))
= (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t))
mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok))
starSym :: Bool -> String
starSym True = "★"
starSym False = "*"
forallSym :: Bool -> String
forallSym True = "∀"
forallSym False = "forall"