module RdrHsSyn (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkTyFamInst,
mkFamDecl, mkLHsSigType,
splitCon, mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
filterCTuple,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkConDeclH98,
mkATDefault,
checkBlockArguments,
checkPrecP,
checkContext,
checkInfixConstr,
checkPattern,
bang_RDR,
checkPatterns,
checkMonadComp,
checkCommand,
checkValDef,
checkValSigLhs,
checkDoAndIfThenElse,
checkRecordSyntax,
checkEmptyGADTs,
parseErrorSDoc, hintBangPat,
splitTilde,
TyEl(..), mergeOps,
ImpExpSubSpec(..),
ImpExpQcSpec(..),
mkModuleImpExp,
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec,
warnStarIsType,
failOpFewArgs,
SumOrTuple (..), mkSumOrTuple
) where
import GhcPrelude
import HsSyn
import Class ( FunDep )
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(..) )
import TysWiredIn ( cTupleTyConName, tupleTyConName, tupleTyCon,
tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey,
cTupleTyConNameArity_maybe )
import ForeignCall
import PrelNames ( forall_tv_RDR, eqTyCon_RDR, 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 HsExtension ( noExt )
import Data.List
import qualified GHC.LanguageExtensions as LangExt
import DynFlags ( WarningFlag(..) )
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
#include "HsVersions.h"
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L loc d) = L loc (TyClD noExt d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L loc d) = L loc (InstD noExt d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[Located (FunDep (Located RdrName))])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; mapM_ (\a -> a loc) ann
; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
; at_defs <- mapM (eitherToP . mkATDefault) at_insts
; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdFDs = snd (unLoc fds)
, tcdSigs = mkClassOpSigs sigs
, tcdMeths = binds
, tcdATs = ats, tcdATDefs = at_defs
, tcdDocs = docs })) }
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
| FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = rhs } <- e
= do { tvs <- checkTyVars (text "default") equalsDots tc pats
; return (L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })) }
mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
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
; mapM_ (\a -> a loc) ann
; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdDExt = noExt,
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 = noExt
, 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
; mapM_ (\a -> a loc) ann
; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
; return (L loc (SynDecl { tcdSExt = noExt
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdRhs = rhs })) }
mkTyFamInstEqn :: LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; return (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = rhs }),
ann) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn }))))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
= return (L loc (TyFamInstD noExt (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
; mapM_ (\a -> a loc) ann
; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
; return (L loc (FamDecl noExt (FamilyDecl
{ fdExt = noExt
, 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 noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
= SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
| otherwise
= SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens 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 noExt 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
parseErrorSDoc 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)
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds'
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
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 noExt mbs sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
, [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
go (L l (ValD _ b) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
where
(b', ds') = getMonoBind (L l b) ds
go (L l decl : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
SigD _ s
-> return (bs, L l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
-> return (bs, ss, L l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
-> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
-> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
DocD _ d
-> return (bs, ss, ts, tfis, dfis, L l d : docs)
SpliceD _ d
-> parseErrorSDoc l $
hang (text "Declaration splices are allowed only" <+>
text "at the top level:")
2 (ppr d)
_ -> pprPanic "cvBindsAndSigs" (ppr decl) }
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)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
has_args ((L _ (XMatch _)) : _) = panic "has_args"
splitCon :: [LHsType GhcPs]
-> P ( Located RdrName
, HsConDeclDetails GhcPs
, Maybe LHsDocString
)
splitCon apps
= split apps' []
where
oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
ty = foldl1 mkHsAppTy (reverse apps)
(apps', trailing_doc)
= case apps of
L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
ts -> (ts, Nothing)
split [ L _ (HsDocTy _ con con_doc) ] ts = do
(data_con, con_details, con_doc') <- split [con] ts
return (data_con, con_details, con_doc' `mplus` Just con_doc)
split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
data_con <- tyConToDataCon l tc
return (data_con, mk_rest ts, trailing_doc)
split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
= return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon ts
, trailing_doc
)
split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
where msg = "Cannot parse data constructor in a data/newtype declaration:"
split (u : us) ts = split us (u : ts)
split _ _ = panic "RdrHsSyn:splitCon"
mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
mk_rest ts = PrefixCon ts
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ
, isLexCon (occNameFS occ)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= parseErrorSDoc loc (msg $$ extra)
where
occ = rdrNameOcc tc
msg = text "Not a data constructor:" <+> quotes (ppr tc)
extra | tc == forall_tv_RDR
= text "Perhaps you intended to use ExistentialQuantification"
| otherwise = empty
splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
where ~(t2', ds) = splitDocTy t2
splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
splitDocTy ty = (ty, Nothing)
checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
where (ty', doc_string) = splitDocTy ty
msg = text "infix constructor field"
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 _ (ConPatIn ln@(L _ name) details))
rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats -> return $ Match { m_ext = noExt
, 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 = noExt
, 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 =
parseErrorSDoc loc $
text "pattern synonym 'where' clause must contain a single binding:" $$
ppr decl
wrongNameBindingErr loc decl =
parseErrorSDoc loc $
text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
quotes (ppr patsyn_name) $$ ppr decl
wrongNumberErr loc =
parseErrorSDoc 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 =
parseErrorSDoc loc $
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 name mb_forall mb_cxt args
= ConDeclH98 { con_ext = noExt
, 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 }
where
args' = nudgeHsSrcBangs args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
-> (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty
= (ConDeclGADT { con_g_ext = noExt
, con_names = names
, con_forall = L l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args'
, con_res_ty = res_ty
, con_doc = Nothing }
, anns1 ++ anns2)
where
(ty'@(L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTy ty'
(mcxt, tau, anns2) = split_rho rho []
split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
= (Just cxt, tau, ann)
split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
split_rho tau ann = (Nothing, tau, ann)
(args, res_ty) = split_tau tau
args' = nudgeHsSrcBangs args
split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
= (RecCon (L loc rf), res_ty)
split_tau tau = (PrefixCon [], tau)
peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
nudgeHsSrcBangs details
= case details of
PrefixCon as -> PrefixCon (map go as)
RecCon r -> RecCon r
InfixCon a1 a2 -> InfixCon (go a1) (go a2)
where
go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
go lty = lty
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
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
-> P (LHsQTyVars GhcPs)
checkTyVarsP pp_what equals_or_where tc tparms
= eitherToP $ checkTyVars pp_what equals_or_where tc tparms
eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
-> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
checkTyVars pp_what equals_or_where tc tparms
= do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
chk (L _ (HsParTy _ ty)) = chk ty
chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
| isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
chk (L l (HsTyVar _ _ (L ltv tv)))
| isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
chk t@(L loc _)
= Left (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 (L loc c))
= do allowed <- extension datatypeContextsEnabled
unless allowed $
parseErrorSDoc loc
(text "Illegal datatype context (use DatatypeContexts):" <+>
pprHsContext c)
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
= do allowed <- extension traditionalRecordSyntaxEnabled
if allowed
then return lr
else parseErrorSDoc loc
(text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
ppr r)
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(L span (_, []))
= do opts <- fmap options getPState
if LangExt.GADTSyntax `extopt` opts
then return gadts
else parseErrorSDoc 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"
]
checkEmptyGADTs gadts = return gadts
checkTyClHdr :: Bool
-> LHsType GhcPs
-> P (Located RdrName,
[LHsType 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 _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (if isUni then "★" else "*")
; return (L l (Unqual name), acc, fix, ann) }
go l (HsTyVar _ _ (L _ tc)) acc ann fix
| isRdrTc tc = return (L l tc, acc, fix, ann)
go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, t1: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 (t2:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (L l (nameRdrName tup_name), ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
go l _ _ _ _
= parseErrorSDoc l (text "Malformed head of type or class declaration:"
<+> ppr ty)
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments expr = case unLoc expr of
HsDo _ DoExpr _ -> check "do block"
HsDo _ MDoExpr _ -> check "mdo block"
HsLam {} -> check "lambda expression"
HsCase {} -> check "case expression"
HsLamCase {} -> check "lambda-case expression"
HsLet {} -> check "let expression"
HsIf {} -> check "if expression"
HsProc {} -> check "proc expression"
_ -> return ()
where
check element = do
pState <- getPState
unless (extopt LangExt.BlockArguments (options pState)) $
parseErrorSDoc (getLoc expr) $
text "Unexpected " <> text element <> text " in function application:"
$$ nest 4 (ppr expr)
$$ 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 = checkNoDocs msg t *> return ([],L l [L l orig_t])
msg = text "data constructor context"
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg ty = go ty
where
go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
[ text "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ]
go _ = pure ()
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern msg e = checkLPat msg e
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns msg es = mapM (checkPattern msg) es
checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat msg e@(L l _) = checkPat msg l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
checkPat _ loc (L l e@(HsVar _ (L _ c))) args
| isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
| not (null args) && patIsRec c =
patFail (text "Perhaps you intended to use RecursiveDo") l e
checkPat msg loc e args
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
checkPat msg loc (L _ (HsApp _ f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
checkPat msg loc (L _ e) []
= do p <- checkAPat msg loc e
return (L loc p)
checkPat msg loc e _
= patFail msg loc (unLoc e)
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
checkAPat msg loc e0 = do
pState <- getPState
let opts = options pState
case e0 of
EWildPat _ -> return (WildPat noExt)
HsVar _ x -> return (VarPat noExt x)
HsLit _ (HsStringPrim _ _)
-> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
HsLit _ l -> return (LitPat noExt l)
HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
NegApp _ (L l (HsOverLit _ pos_lit)) _
-> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
SectionR _ (L lb (HsVar _ (L _ bang))) e
| bang == bang_RDR
-> do { hintBangPat loc e0
; e' <- checkLPat msg e
; addAnnotation loc AnnBang lb
; return (BangPat noExt e') }
ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
EViewPat _ expr patE -> checkLPat msg patE >>=
(return . (\p -> ViewPat noExt expr p))
ExprWithTySig t e -> do e <- checkLPat msg e
return (SigPat t e)
OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
(L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit))
OpApp _ l (L cl (HsVar _ (L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
l <- checkLPat msg l
r <- checkLPat msg r
return (ConPatIn (L cl c) (InfixCon l r))
OpApp {} -> patFail msg loc e0
ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
return (ListPat noExt ps)
HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
[e | L _ (Present _ e) <- es]
return (TuplePat noExt ps b)
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
ExplicitSum _ alt arity expr -> do
p <- checkLPat msg expr
return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE _ s | not (isTypedSplice s)
-> return (SplicePat noExt s)
_ -> patFail msg loc e0
placeHolderPunRhs :: LHsExpr GhcPs
placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+")
bang_RDR = mkUnqual varName (fsLit "!")
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
return (L l (fld { hsRecFieldArg = p }))
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg loc e = parseErrorSDoc loc err
where err = text "Parse error in pattern:" <+> ppr e
$$ msg
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef msg _strictness lhs (Just sig) grhss
= checkPatBind msg (L (combineLocs lhs sig)
(ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind msg strictness ann (getLoc lhs)
fun is_infix pats (L l grhss)
Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- checkPatterns msg pats
let match_span = combineSrcSpans lhs_loc rhs_span
return (ann, makeFunBind fun
[L match_span (Match { m_ext = noExt
, m_ctxt = FunRhs { mc_fun = fun
, mc_fixity = is_infix
, mc_strictness = strictness }
, m_pats = ps
, m_grhss = grhss })])
makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
makeFunBind fn ms
= FunBind { fun_ext = noExt,
fun_id = fn,
fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper,
fun_tick = [] }
checkPatBind :: SDoc
-> LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind msg lhs (L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
; return ([],PatBind noExt 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 _)
= parseErrorSDoc 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 :: LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> Bool
-> LHsExpr GhcPs
-> P ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do pState <- getPState
unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
parseErrorSDoc (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
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
| op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
where
l' = combineLocs bang arg1
(arg1,argns) = split_bang r_arg []
split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
split_bang e es = (e,es)
splitBang _ = Nothing
isFunLhs :: LHsExpr GhcPs
-> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
isFunLhs e = go e [] []
where
go (L loc (HsVar _ (L _ f))) es ann
| not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
go (L _ (HsApp _ f e)) es ann = go f (e:es) ann
go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
[] ann
| bang == bang_RDR
, not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es) ann
else return (Just (L loc' op, Infix, (l: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 (OpApp noExt k
(L loc' (HsVar noExt (L loc' op))) r)
_ -> return Nothing }
go _ _ _ = return Nothing
splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
splitTilde [] = panic "splitTilde"
splitTilde (x:xs) = go x xs
where
go lhs [] = return lhs
go lhs (x:xs)
| L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
= do { rhs <- splitTilde (t:xs)
; let r = mkLHsOpTy lhs (tildeOp loc) rhs
; moveAnnotations loc (getLoc r)
; return r }
| otherwise
= go (mkHsAppTy lhs x) xs
tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
mergeOps = go [] id
where
go acc ops_acc (L l (TyElOpr op):xs) =
if null acc || null xs
then failOpFewArgs (L l op)
else do { a <- splitTilde acc
; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
go acc ops_acc [] =
do { a <- splitTilde acc
; return (ops_acc a) }
checkMonadComp :: P (HsStmtContext Name)
checkMonadComp = do
pState <- getPState
return $ if extopt LangExt.MonadComprehensions (options pState)
then MonadComp
else ListComp
checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand lc = locMap checkCmd lc
locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap f (L l a) = f l a >>= (\b -> return $ L l b)
checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
checkCmd _ (HsArrApp _ e1 e2 haat b) =
return $ HsCmdArrApp noExt e1 e2 haat b
checkCmd _ (HsArrForm _ e mf args) =
return $ HsCmdArrForm noExt e Prefix mf args
checkCmd _ (HsApp _ e1 e2) =
checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
checkCmd _ (HsLam _ mg) =
checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
checkCmd _ (HsPar _ e) =
checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
checkCmd _ (HsCase _ e mg) =
checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
checkCmd _ (HsIf _ cf ep et ee) = do
pt <- checkCommand et
pe <- checkCommand ee
return $ HsCmdIf noExt cf ep pt pe
checkCmd _ (HsLet _ lb e) =
checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
checkCmd _ (HsDo _ DoExpr (L l stmts)) =
mapM checkCmdLStmt stmts >>=
(\ss -> return $ HsCmdDo noExt (L l ss) )
checkCmd _ (OpApp _ eLeft op eRight) = do
c1 <- checkCommand eLeft
c2 <- checkCommand eRight
let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
arg2 = L (getLoc c2) $ HsCmdTop noExt c2
return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
checkCmd l e = cmdFail l e
checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt = locMap checkCmdStmt
checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
checkCmdStmt _ (LastStmt x e s r) =
checkCommand e >>= (\c -> return $ LastStmt x c s r)
checkCmdStmt _ (BindStmt x pat e b f) =
checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
checkCmdStmt _ (BodyStmt x e t g) =
checkCommand e >>= (\c -> return $ BodyStmt x c t g)
checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
ss <- mapM checkCmdLStmt stmts
return $ stmt { recS_ext = noExt, recS_stmts = ss }
checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
checkCmdStmt l stmt = cmdStmtFail l stmt
checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
ms' <- mapM (locMap $ const convert) ms
return $ mg { mg_ext = noExt, mg_alts = L l ms' }
where convert match@(Match { m_grhss = grhss }) = do
grhss' <- checkCmdGRHSs grhss
return $ match { m_ext = noExt, m_grhss = grhss'}
convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs (GRHSs x grhss binds) = do
grhss' <- mapM checkCmdGRHS grhss
return $ GRHSs x grhss' binds
checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
checkCmdGRHS = locMap $ const convert
where
convert (GRHS x stmts e) = do
c <- checkCommand e
return $ GRHS x stmts c
convert (XGRHS _) = panic "checkCmdGRHS"
cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
cmdStmtFail loc e = parseErrorSDoc loc
(text "Parse error in command statement:" <+> ppr e)
checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
checkPrecP (L l (src,i))
| 0 <= i && i <= maxPrecedence = return (L l (src,i))
| otherwise
= parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
mkRecConstrOrUpdate
:: LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
-> P (HsExpr GhcPs)
mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
| dd = parseErrorSDoc l (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 = noExt
, rupd_expr = exp
, rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
= RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (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 noExt rdr)) arg pun
mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
= panic "mk_rec_upd_field"
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 cconv of
L _ CCallConv -> mkCImport
L _ CApiConv -> mkCImport
L _ StdCallConv -> mkCImport
L _ PrimCallConv -> mkOtherImport
L _ JavaScriptCallConv -> mkOtherImport
where
mkCImport = do
let e = unpackFS entity
case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> parseErrorSDoc 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 noExt $ ForeignImport
{ fd_i_ext = noExt
, 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 cconv of
L _ 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 noExt $
ForeignExport { fd_e_ext = noExt, 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 noExt (L l (ieNameFromSpec specname))
| otherwise -> IEThingAbs noExt . L l <$> nameT
ImpExpAll -> IEThingAll noExt . L l <$> nameT
ImpExpList xs ->
(\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
<$> nameT
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
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 noExt (L l newName) pos ies []) <$> nameT
else parseErrorSDoc l
(text "Illegal export form (use PatternSynonyms to enable)")
where
name = ieNameVal specname
nameT =
if isVarNameSpace (rdrNameSpace name)
then parseErrorSDoc 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 (\(L l x) -> L l (ieNameFromSpec x))
mkTypeImpExp :: Located RdrName
-> P (Located RdrName)
mkTypeImpExp name =
do allowed <- extension explicitNamespacesEnabled
if allowed
then return (fmap (`setRdrNameSpace` tcClsName) name)
else parseErrorSDoc (getLoc name)
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
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 =
parseErrorSDoc 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
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."
$$ 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 <- extension starIsTypeEnabled
; let msg = too_few $$ starInfo star_is_type op
; parseErrorSDoc loc msg }
where
too_few = text "Operator applied to too few arguments:" <+> ppr op
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc span s = failSpanMsgP span s
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat span e = do
bang_on <- extension bangPatEnabled
unless bang_on $
parseErrorSDoc span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple
= Sum ConTag Arity (LHsExpr GhcPs)
| Tuple [LHsTupArg GhcPs]
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
mkSumOrTuple Unboxed _ (Sum alt arity e) =
return (ExplicitSum noExt alt arity e)
mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
where
ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
ppr_boxed_sum alt arity e =
text "(" <+> ppr_bars (alt 1) <+> ppr e <+> ppr_bars (arity alt) <+> text ")"
ppr_bars n = hsep (replicate n (Outputable.char '|'))
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)