%
% (c) The University of Glasgow, 19962003
Functions over HsSyn specialised to RdrName.
\begin{code}
module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
splitCon, mkInlineSpec,
mkRecConstrOrUpdate,
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
findSplice, checkDecBrGroup,
placeHolderPunRhs,
mkImport,
parseCImport,
mkExport,
mkExtName,
mkGadtDecl,
mkSimpleConDecl,
mkDeprecatedGadtRecordDecl,
checkPrecP,
checkContext,
checkPred,
checkTyVars,
checkKindSigs,
checkInstType,
checkPattern,
bang_RDR,
checkPatterns,
checkDo,
checkMDo,
checkValDef,
checkValSig,
parseError,
parseErrorSDoc,
) where
import HsSyn
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
InlinePragma(..), InlineSpec(..),
alwaysInlineSpec, neverInlineSpec )
import Lexer
import TysWiredIn ( unitTyCon )
import ForeignCall
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
import PrelNames ( forall_tv_RDR )
import DynFlags
import SrcLoc
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
import FastString
import Maybes
import Control.Applicative ((<$>))
import Text.ParserCombinators.ReadP as ReadP
import Data.List ( nubBy )
import Data.Char
#include "HsVersions.h"
\end{code}
%************************************************************************
%* *
\subsection{A few functions over HsSyn at RdrName}
%* *
%************************************************************************
extractHsTyRdrNames finds the free variables of a HsType
It's used when making the foralls explicit.
\begin{code}
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
extractHsRhoRdrTyVars ctxt ty
= nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
extract_ltys tys acc = foldr extract_lty acc tys
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv acc
HsBangTy _ ty -> extract_lty ty acc
HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsListTy ty -> extract_lty ty acc
HsPArrTy ty -> extract_lty ty acc
HsTupleTy _ tys -> extract_ltys tys acc
HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
HsNumTy _ -> acc
HsSpliceTy {} -> acc
HsSpliceTyOut {} -> acc
HsKindSig ty _ -> extract_lty ty acc
HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
HsDocTy ty _ -> extract_lty ty acc
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
| otherwise = acc
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
extractGenericPatTyVars binds
= nubBy eqLocated (foldrBag get [] binds)
where
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
get _ acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
get_m _ acc = acc
\end{code}
%************************************************************************
%* *
\subsection{Construction functions for Rdr stuff}
%* *
%************************************************************************
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
by deriving them from the name of the class. We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself. This saves recording the names in the interface
file (which would be equally good).
Similarly for mkConDecl, mkClassOpSig and defaultmethod names.
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
mkClassDecl :: SrcSpan
-> Located (LHsContext RdrName, LHsType RdrName)
-> Located [Located (FunDep RdrName)]
-> Located (OrdList (LHsDecl RdrName))
-> P (LTyClDecl RdrName)
mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tparams
; checkKindSigs ats
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Bool
-> Located (LHsContext RdrName, LHsType RdrName)
-> Maybe Kind
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; (tyvars, typats) <- checkTParams is_family tparams
; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
tcdTyVars = tyvars, tcdTyPats = typats,
tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
mkTySynonym :: SrcSpan
-> Bool
-> LHsType RdrName
-> LHsType RdrName
-> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; (tyvars, typats) <- checkTParams is_family tparams
; return (L loc (TySynonym tc tyvars typats rhs)) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
-> LHsType RdrName
-> Maybe Kind
-> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars tparams
; return (L loc (TyFamily flavour tc tyvars ksig)) }
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
mkTopSpliceDecl expr
= SpliceD (SpliceDecl expr')
where
expr' = case expr of
(L _ (HsSpliceE (HsSplice _ expr))) -> expr
_other -> expr
\end{code}
%************************************************************************
%* *
\subsection[cvBindsetc]{Converting to @HsBinds@, etc.}
%* *
%************************************************************************
Function definitions are restructured here. Each is assumed to be recursive
initially, and non recursive definitions are discovered by the dependency
analyser.
\begin{code}
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
go [] = []
go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
(mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [], [])
go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
where (bs, ss, ts, docs) = go ds
go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, docs) = go ds'
go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
where (bs, ss, ts, docs) = go ds
go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
where (bs, ss, ts, docs) = go ds
go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
-> (LHsBind RdrName, [LHsDecl RdrName])
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
fun_matches = MatchGroup mtchs1 _ })) binds
| has_args mtchs1
= go is_infix1 mtchs1 loc1 binds []
where
go is_infix mtchs loc
(L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
fun_matches = MatchGroup mtchs2 _ })) : binds) _
| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls
in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
go is_infix mtchs loc binds doc_decls
= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch RdrName] -> Bool
has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match args _ _)) : _) = not (null args)
\end{code}
\begin{code}
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
findSplice ds = addl emptyRdrGroup ds
checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
checkDecBrGroup decls
= case addl emptyRdrGroup decls of
(group, Nothing) -> return group
(_, Just (SpliceDecl (L loc _), _)) ->
parseError loc "Declaration splices are not permitted inside declaration brackets"
addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
addl gp [] = (gp, Nothing)
addl gp (L l d : ds) = add gp l d ds
add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
-> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
add gp _ (SpliceD e) ds = (gp, Just (e, ds))
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
l (TyClD d) ds
| isClassDecl d =
let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
| otherwise =
addl (gp { hs_tyclds = L l d : ts }) ds
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
= addl (gp { hs_valds = add_bind (L l d) ts }) ds
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_instds = L l d : ts }) ds
add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
= addl (gp { hs_defds = L l d : ts }) ds
add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
= addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
= addl (gp { hs_warnds = L l d : ts }) ds
add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
= addl (gp { hs_annds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}
%************************************************************************
%* *
\subsection[PrefixToHSutils]{Utilities for conversion}
%* *
%************************************************************************
\begin{code}
splitCon :: LHsType RdrName
-> P (Located RdrName, HsConDeclDetails RdrName)
splitCon ty
= split ty []
where
split (L _ (HsAppTy t u)) ts = split t (u : ts)
split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
return (data_con, mk_rest ts)
split (L l _) _ = parseError l "parse error in data/newtype declaration"
mk_rest [L _ (HsRecTy flds)] = RecCon flds
mk_rest ts = PrefixCon ts
mkDeprecatedGadtRecordDecl :: SrcSpan
-> Located RdrName
-> [ConDeclField RdrName]
-> LHsType RdrName
-> P (LConDecl RdrName)
mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
= do { data_con <- tyConToDataCon con_loc con
; return (L loc (ConDecl { con_old_rec = True
, con_name = data_con
, con_explicit = Implicit
, con_qvars = []
, con_cxt = noLoc []
, con_details = RecCon flds
, con_res = ResTyGADT res_ty
, con_doc = Nothing })) }
mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> HsConDeclDetails RdrName
-> ConDecl RdrName
mkSimpleConDecl name qvars cxt details
= ConDecl { con_old_rec = False
, con_name = name
, con_explicit = Explicit
, con_qvars = qvars
, con_cxt = cxt
, con_details = details
, con_res = ResTyH98
, con_doc = Nothing }
mkGadtDecl :: [Located RdrName]
-> LHsType RdrName
-> [ConDecl RdrName]
mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
= [mk_gadt_con name | name <- names]
where
(details, res_ty)
= case tau of
L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
_other -> (PrefixCon [], tau)
mk_gadt_con name
= ConDecl { con_old_rec = False
, con_name = name
, con_explicit = imp
, con_qvars = qvars
, con_cxt = cxt
, con_details = details
, con_res = ResTyGADT res_ty
, con_doc = Nothing }
mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
| isTcOcc (rdrNameOcc tc)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= parseErrorSDoc loc (msg $$ extra)
where
msg = text "Not a data constructor:" <+> quotes (ppr tc)
extra | tc == forall_tv_RDR
= text "Perhaps you intended to use -XExistentialQuantification"
| otherwise = empty
\end{code}
Note [Sorting out the result type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a GADT declaration which is not a record, we put the whole constr
type into the ResTyGADT for now; the renamer will unravel it once it
has sorted out operator fixities. Consider for example
C :: a :*: b -> a :*: b -> a :+: b
Initially this type will parse as
a :*: (b -> (a :*: (b -> (a :+: b))))
so it's hard to split up the arguments until we've done the precedence
resolution (in the renamer) On the other hand, for a record
{ x,y :: Int } -> a :*: b
there is no doubt. AND we need to sort records out so that
we can bring x,y into scope. So:
* For PrefixCon we keep all the args in the ResTyGADT
* For RecCon we do not
\begin{code}
checkInstType :: LHsType RdrName -> P (LHsType RdrName)
checkInstType (L l t)
= case t of
HsForAllTy exp tvs ctxt ty -> do
dict_ty <- checkDictTy ty
return (L l (HsForAllTy exp tvs ctxt dict_ty))
HsParTy ty -> checkInstType ty
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
check (HsTyVar t) args | not (isRdrTyVar t)
= return (L spn (HsPredTy (HsClassP t args)))
check (HsAppTy l r) args = check (unLoc l) (r:args)
check (HsParTy t) args = check (unLoc t) args
check _ _ = parseError spn "Malformed instance header"
checkTParams :: Bool
-> [LHsType RdrName]
-> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
checkTParams is_family tparams
| not is_family
= do { tyvars <- checkTyVars tparams
; return (tyvars, Nothing) }
| otherwise
= do { let tyvars = [L l (UserTyVar tv)
| L l tv <- extractHsTysRdrTyVars tparams]
; return (tyvars, Just tparams) }
checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
checkTyVars tparms = mapM chk tparms
where
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk (L l _) =
parseError l "Type found where type variable expected"
checkTyClHdr :: LHsType RdrName
-> P (Located RdrName,
[LHsType RdrName])
checkTyClHdr ty
= goL ty []
where
goL (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
| isRdrTc tc = return (L l tc, acc)
go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
| isRdrTc tc = return (ltc, t1:t2:acc)
go _ (HsParTy ty) acc = goL ty acc
go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
go l _ _ = parseError l "Malformed head of type or class declaration"
checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
where
check (L l tydecl)
| isFamilyDecl tydecl
|| isSynDecl tydecl = return ()
| otherwise =
parseError l "Type declaration in a class must be a kind signature or synonym default"
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
= check t
where
check (HsTupleTy _ ts)
= do ctx <- mapM checkPred ts
return (L l ctx)
check (HsParTy ty)
= check (unLoc ty)
check (HsTyVar t)
| t == getRdrName unitTyCon = return (L l [])
check t
= do p <- checkPred (L l t)
return (L l [p])
checkPred :: LHsType RdrName -> P (LHsPred RdrName)
checkPred (L spn (HsPredTy (HsIParam n ty)))
= return (L spn (HsIParam n ty))
checkPred (L spn ty)
= check spn ty []
where
checkl (L l ty) args = check l ty args
check _loc (HsPredTy pred@(HsEqualP _ _))
args | null args
= return $ L spn pred
check _loc (HsTyVar t) args | not (isRdrTyVar t)
= return (L spn (HsClassP t args))
check _loc (HsAppTy l r) args = checkl l (r:args)
check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
check _loc (HsParTy t) args = checkl t args
check loc _ _ = parseError loc
"malformed class assertion"
checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm _ ss = do
check ss
where
check [] = panic "RdrHsSyn:checkDoMDo"
check [L _ (ExprStmt e _ _)] = return ([], e)
check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
" construct must be an expression")
check (s:ss) = do
(ss',e') <- check ss
return ((s:ss'),e')
checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
checkPattern e = checkLPat e
checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns es = mapM checkPattern es
checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
checkPat loc (L l (HsVar c)) args
| isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
checkPat loc e args
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns args'
; checkPat loc e' (args'' ++ args) }
checkPat loc (L _ (HsApp f x)) args
= do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
= do { pState <- getPState
; p <- checkAPat (dflags pState) loc e
; return (L loc p) }
checkPat loc _ _
= patFail loc
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of
EWildPat -> return (WildPat placeHolderType)
HsVar x -> return (VarPat x)
HsLit l -> return (LitPat l)
HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
-> return (mkNPat pos_lit (Just noSyntaxExpr))
SectionR (L _ (HsVar bang)) e
| bang == bang_RDR
-> do { bang_on <- extension bangPatEnabled
; if bang_on then checkLPat e >>= (return . BangPat)
else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
ExprWithTySig e t -> do e <- checkLPat e
let t' = case t of
L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
other -> other
return (SigPatIn e t')
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) lit)
OpApp l op _fix r -> do l <- checkLPat l
r <- checkLPat r
case op of
L cl (HsVar c) | isDataOcc (rdrNameOcc c)
-> return (ConPatIn (L cl c) (InfixCon l r))
_ -> patFail loc
HsPar e -> checkLPat e >>= (return . ParPat)
ExplicitList _ es -> do ps <- mapM checkLPat es
return (ListPat ps placeHolderType)
ExplicitPArr _ es -> do ps <- mapM checkLPat es
return (PArrPat ps placeHolderType)
ExplicitTuple es b
| all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
return (TuplePat ps b placeHolderType)
| otherwise -> parseError loc "Illegal tuple section in pattern"
RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsQuasiQuoteE q -> return (QuasiQuotePat q)
HsType ty -> return (TypePat ty)
_ -> patFail loc
placeHolderPunRhs :: HsExpr RdrName
placeHolderPunRhs = HsVar 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 :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
; return (fld { hsRecFieldArg = p }) }
patFail :: SrcSpan -> P a
patFail loc = parseError loc "Parse error in pattern"
checkValDef :: LHsExpr RdrName
-> Maybe (LHsType RdrName)
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
checkValDef lhs (Just sig) grhss
= checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
checkValDef lhs opt_sig grhss
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
fun is_infix pats opt_sig grhss
Nothing -> checkPatBind lhs grhss }
checkFunBind :: SrcSpan
-> Located RdrName
-> Bool
-> [LHsExpr RdrName]
-> Maybe (LHsType RdrName)
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
makeFunBind fn is_infix ms
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind :: LHsExpr RdrName
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames) }
checkValSig
:: LHsExpr RdrName
-> LHsType RdrName
-> P (Sig RdrName)
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
checkValSig (L l _) _
= parseError l "Invalid type signature"
\end{code}
\begin{code}
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
| op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
where
(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 RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
isFunLhs e = go e []
where
go (L loc (HsVar f)) es
| not (isRdrDataCon f) = return (Just (L loc f, False, es))
go (L _ (HsApp f e)) es = go f (e:es)
go (L _ (HsPar e)) es@(_:_) = go e es
go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es)
else return (Just (L loc' op, True, (l:r:es))) }
| not (isRdrDataCon op)
= return (Just (L loc' op, True, (l:r:es)))
| otherwise
= do { mb_l <- go l es
; case mb_l of
Just (op', True, j : k : es')
-> return (Just (op', True, j : op_app : es'))
where
op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
_ -> return Nothing }
go _ _ = return Nothing
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
| 0 <= i && i <= maxPrecedence = return i
| otherwise = parseError l "Precedence out of range"
mkRecConstrOrUpdate
:: LHsExpr RdrName
-> SrcSpan
-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp loc (fs,dd)
| null fs = parseError loc "Empty record update"
| otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
mk_rec_fields :: [HsRecField 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) }
mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
mkInlineSpec Nothing match_info False = neverInlineSpec match_info
mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
mkImport :: CCallConv
-> Safety
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity)
importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
| otherwise = do
case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
Nothing -> parseError loc "Malformed entity string"
Just importSpec -> return (ForD (ForeignImport v ty importSpec))
parseCImport :: CCallConv -> Safety -> FastString -> String
-> Maybe ForeignImport
parseCImport cconv safety nm str =
listToMaybe $ map fst $ filter (null.snd) $
readP_to_S parse str
where
parse = do
skipSpaces
r <- choice [
string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
string "wrapper" >> return (mk nilFS CWrapper),
optional (string "static" >> skipSpaces) >>
(mk nilFS <$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
]
skipSpaces
return r
mk = CImport cconv safety
hdr_char c = not (isSpace c)
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
+++ ((CFunction . StaticTarget) <$> cid)
where
cid = return nm +++
(do c <- satisfy (\c -> isAlpha c || c == '_')
cs <- many (satisfy id_char)
return (mkFastString (c:cs)))
mkExport :: CCallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkExport cconv (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
mkExtName :: RdrName -> CLabelString
mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
\end{code}
\begin{code}
parseError :: SrcSpan -> String -> P a
parseError span s = parseErrorSDoc span (text s)
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc span s = failSpanMsgP span s
\end{code}