mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice,
- mkTyData, mkPrefixCon, mkRecCon,
+ mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
- mkBootIface,
cvBindGroup,
cvBindsAndSigs,
findSplice, mkGroup,
-- Stuff to do with Foreign declarations
- , CallConv(..)
- , mkImport -- CallConv -> Safety
+ CallConv(..),
+ mkImport, -- CallConv -> Safety
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExport -- CallConv
+ mkExport, -- CallConv
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExtName -- RdrName -> CLabelString
+ mkExtName, -- RdrName -> CLabelString
+ mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
-- Bunch of functions in the parser monad for
-- checking and constructing values
- , checkPrecP -- Int -> P Int
- , checkContext -- HsType -> P HsContext
- , checkPred -- HsType -> P HsPred
- , checkTyClHdr -- HsType -> (name,[tyvar])
- , checkInstType -- HsType -> P HsType
- , checkPattern -- HsExp -> P HsPat
- , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
- , checkDo -- [Stmt] -> P [Stmt]
- , checkMDo -- [Stmt] -> P [Stmt]
- , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- , parseError -- String -> Pa
+ checkPrecP, -- Int -> P Int
+ checkContext, -- HsType -> P HsContext
+ checkPred, -- HsType -> P HsPred
+ checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+ checkInstType, -- HsType -> P HsType
+ checkPattern, -- HsExp -> P HsPat
+ checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
+ checkDo, -- [Stmt] -> P [Stmt]
+ checkMDo, -- [Stmt] -> P [Stmt]
+ checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ parseError, -- String -> Pa
) where
#include "HsVersions.h"
import HsSyn -- Lots of it
-import IfaceType
-import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
-import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) )
import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
- isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
- setRdrNameSpace, rdrNameModule )
-import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
-import Lexer ( P, failSpanMsgP )
-import HscTypes ( GenAvailInfo(..) )
+ isRdrDataCon, isUnqual, getRdrName, isQual,
+ setRdrNameSpace )
+import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..), DNKind(..))
-import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
- occNameUserString, isValOcc )
-import BasicTypes ( initialVersion )
-import TyCon ( DataConDetails(..) )
-import Module ( ModuleName )
+ DNCallSpec(..), DNKind(..), CLabelString )
+import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
+ occNameString )
import SrcLoc
-import CStrings ( CLabelString )
-import CmdLineOpts ( opt_InPackage )
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
extractHsRhoRdrTyVars ctxt ty
= nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
-extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
+extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
extract_pred (HsIParam n ty) acc = extract_lty ty acc
-extract_lty (L loc (HsTyVar tv)) acc
- | isRdrTyVar tv = L loc tv : acc
- | otherwise = acc
-extract_lty ty acc = extract_ty (unLoc ty) acc
-
-extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_ty (HsListTy ty) acc = extract_lty ty acc
-extract_ty (HsPArrTy ty) acc = extract_lty ty acc
-extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
-extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc
-extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_ty (HsParTy ty) acc = extract_lty ty acc
-extract_ty (HsNumTy num) acc = acc
-extract_ty (HsKindSig ty k) acc = extract_lty ty acc
-extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
-extract_ty (HsForAllTy exp tvs cx ty)
- acc = (filter ((`notElem` locals) . unLoc) $
- extract_lctxt cx (extract_lty ty [])) ++ acc
- where
- locals = hsLTyVarNames tvs
+extract_lty (L loc ty) acc
+ = case ty of
+ HsTyVar tv -> extract_tv loc tv acc
+ HsBangTy _ ty -> extract_lty ty acc
+ HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
+ HsListTy ty -> extract_lty ty acc
+ HsPArrTy ty -> extract_lty ty acc
+ HsTupleTy _ tys -> foldr extract_lty acc tys
+ 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 num -> acc
+ HsSpliceTy _ -> acc -- Type splices mention no type variables
+ HsKindSig ty k -> extract_lty ty acc
+ HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
+ HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
+ extract_lctxt cx (extract_lty ty []))
+ where
+ locals = hsLTyVarNames tvs
+
+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]
-- Get the type variables out of the type patterns in a bunch of
extractGenericPatTyVars binds
= nubBy eqLocated (foldrBag get [] binds)
where
- get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
+ get other acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
get_m other acc = acc
tcdMeths = mbinds
}
-mkTyData new_or_data (context, tname, tyvars) data_cons maybe
+mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
tcdTyVars = tyvars, tcdCons = data_cons,
- tcdDerivs = maybe }
+ tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
\begin{code}
where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
- f expr = NegApp (L loc e) placeHolderName
-\end{code}
-
-%************************************************************************
-%* *
- Hi-boot files
-%* *
-%************************************************************************
-
-mkBootIface, and its boring helper functions, have two purposes:
-a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
- an hi-boot file, and interfaces consist of the latter
-b) Convert unqualifed names from the "current module" to qualified Orig
- names. E.g.
- module This where
- foo :: GHC.Base.Int -> GHC.Base.Int
- becomes
- This.foo :: GHC.Base.Int -> GHC.Base.Int
-
-It assumes that everything is well kinded, of course.
-
-\begin{code}
-mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
--- Make the ModIface for a hi-boot file
--- The decls are of very limited form
-mkBootIface mod decls
- = (emptyModIface opt_InPackage mod) {
- mi_boot = True,
- mi_exports = [(mod, map mk_export decls')],
- mi_decls = decls_w_vers,
- mi_ver_fn = mkIfaceVerCache decls_w_vers }
- where
- decls' = map hsIfaceDecl decls
- decls_w_vers = repeat initialVersion `zip` decls'
-
- -- hi-boot declarations don't (currently)
- -- expose constructors or class methods
- mk_export decl | isValOcc occ = Avail occ
- | otherwise = AvailTC occ [occ]
- where
- occ = ifName decl
-
-
-hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
- -- Change to Iface syntax, and replace unqualified names with
- -- qualified Orig names from this module. Reason: normal
- -- iface files have everything fully qualified, so it's convenient
- -- for hi-boot files to look the same
- --
- -- NB: no constructors or class ops to worry about
-hsIfaceDecl (SigD (Sig name ty))
- = IfaceId { ifName = rdrNameOcc (unLoc name),
- ifType = hsIfaceLType ty,
- ifIdInfo = NoInfo }
-
-hsIfaceDecl (TyClD decl@(TySynonym {}))
- = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifSynRhs = hsIfaceLType (tcdSynRhs decl),
- ifVrcs = [] }
-
-hsIfaceDecl (TyClD decl@(TyData {}))
- = IfaceData { ifND = tcdND decl,
- ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifCons = Unknown, ifRec = NonRecursive,
- ifVrcs = [], ifGeneric = False }
- -- I'm not sure that [] is right for ifVrcs, but
- -- since we don't use them I'm not going to fiddle
-
-hsIfaceDecl (TyClD decl@(ClassDecl {}))
- = IfaceClass { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
- ifSigs = [], -- Is this right??
- ifRec = NonRecursive, ifVrcs = [] }
-
-hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
-
-hsIfaceName rdr_name -- Qualify unqualifed occurrences
- -- with the module name
- | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
- | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-
-hsIfaceLType :: LHsType RdrName -> IfaceType
-hsIfaceLType = hsIfaceType . unLoc
-
-hsIfaceType :: HsType RdrName -> IfaceType
-hsIfaceType (HsForAllTy exp tvs cxt ty)
- = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
- where
- rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
- tau = hsIfaceLType ty
- tvs' = case exp of
- Explicit -> map unLoc tvs
- Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
-
-hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
-hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
-hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
-hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
-hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
-hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
-hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
-hsIfaceType (HsParTy t) = hsIfaceLType t
-hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
-hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
-hsIfaceType (HsKindSig t _) = hsIfaceLType t
-
------------
-hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
-
------------
-hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
-hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
-
------------
-hsIfaceLPred :: LHsPred RdrName -> IfacePredType
-hsIfaceLPred = hsIfacePred . unLoc
-
-hsIfacePred :: HsPred RdrName -> IfacePredType
-hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
-hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
-
------------
-hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
-hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
-hs_tc_app (HsTyVar n) args
- | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
- | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
-hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
-
------------
-hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
-
------------
-hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind)
-hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
-
------------
-hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
-hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
- | (xs,ys) <- fds ]
+ f expr = NegApp (L loc e) noSyntaxExpr
\end{code}
%************************************************************************
\begin{code}
--- | Groups together bindings for a single function
+-- | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
where
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
-cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
+cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case (cvBindsAndSigs binding) of { (mbs, sigs) ->
- HsBindGroup mbs sigs Recursive -- just one big group for now
+ ValBindsIn mbs sigs
}
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
| has_args mtchs
= go mtchs loc binds
where
- go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
- | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
+ go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
+ | f == f2 = go (mtchs2++mtchs1) loc binds
where loc = combineSrcSpans loc1 loc2
go mtchs1 loc binds
- = (L loc (FunBind lf inf (reverse mtchs1)), binds)
- -- reverse the final matches, to get it back in the right order
+ = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
+ -- Reverse the final matches, to get it back in the right order
getMonoBind bind binds = (bind, binds)
\end{code}
\begin{code}
-emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
- hs_tyclds = [], hs_instds = [],
- hs_fixds = [], hs_defds = [], hs_fords = [],
- hs_depds = [] ,hs_ruleds = [] }
-
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-findSplice ds = addl emptyGroup ds
+findSplice ds = addl emptyRdrGroup ds
mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyGroup ds
+mkGroup ds = addImpDecls emptyRdrGroup ds
addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
-- The decls are imported, and should not have a splice
-- This stuff reverses the declarations (again) but it doesn't matter
-- Base cases
-addl gp [] = (gp, Nothing)
+addl gp [] = (gp, Nothing)
addl gp (L l d : ds) = add gp l d ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
-add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
-add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
%************************************************************************
mkPrefixCon ty tys
= split ty tys
where
- split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
+ 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, PrefixCon ts)
split (L l _) _ = parseError l "parse error in data/newtype declaration"
chk (L l other)
= parseError l "Type found where type variable expected"
+checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+ ; return (tc, tvs) }
+
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
-> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
-- The header of a type or class decl should look like
-- Watch out.. in ...deriving( Show )... we use checkPred on
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
-checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
+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 (HsTyVar t) args | not (isRdrTyVar t)
- = return (L spn (HsClassP t args))
- check loc (HsAppTy l r) args = checkl l (r:args)
- check loc (HsParTy t) args = checkl t args
- check loc _ _ = parseError loc "malformed class assertion"
+ 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"
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
- check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
- = return (L spn (HsPredTy (L spn (HsClassP t args))))
+ 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 context in instance header"
-- We parse do { e1 ; e2 ; }
-- as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
--- (b) transforms it to a ResultStmt
+-- (b) returns it separately
-- same comments apply for mdo as well
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
+checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm loc ss = do
check ss
where
- check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
+ check [L 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' <- check ss
- return (s:ss')
+ (ss',e') <- check ss
+ return ((s:ss'),e')
-- -------------------------------------------------------------------------
-- Checking Patterns.
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 (L _ (HsApp f x)) args = do
- x <- checkLPat x
- checkPat loc f (x:args)
-checkPat loc (L _ e) [] = do
- p <- checkAPat loc e
- return (L loc p)
+checkPat loc e args -- OK to let this happen even if bang-patterns
+ -- are not enabled, because there is no valid
+ -- non-bang-pattern parse of (C ! e)
+ | 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 { p <- checkAPat loc e; return (L loc p) }
checkPat loc pat _some_args
= patFail loc
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by
-- RdrHsSyn.mkHsNegApp
- HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
- -> return (NPatIn pos_lit (Just placeHolderName))
+ -> return (mkNPat pos_lit (Just noSyntaxExpr))
- ELazyPat e -> checkLPat e >>= (return . LazyPat)
- EAsPat n e -> checkLPat e >>= (return . AsPat n)
+ SectionR (L _ (HsVar bang)) e
+ | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
+ ELazyPat e -> checkLPat e >>= (return . LazyPat)
+ EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExprWithTySig e t -> checkLPat e >>= \e ->
-- Pattern signatures are parsed as sigtypes,
-- but they aren't explicit forall points. Hence
(L _ (HsOverLit lit@(HsIntegral _ _)))
| plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit)
- where
- plus_RDR = mkUnqual varName FSLIT("+") -- Hack
OpApp l op fix r -> checkLPat l >>= \l ->
checkLPat r >>= \r ->
return (PArrPat ps placeHolderType)
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (TuplePat ps b)
+ return (TuplePat ps b placeHolderType)
- RecordCon c fs -> mapM checkPatField fs >>= \fs ->
+ RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon fs))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
-checkAPat loc _ = patFail loc
+plus_RDR, bang_RDR :: RdrName
+plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+bang_RDR = mkUnqual varName FSLIT("!") -- Hack
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef
- :: LHsExpr RdrName
- -> Maybe (LHsType RdrName)
- -> GRHSs RdrName
- -> P (HsBind RdrName)
+checkValDef :: LHsExpr RdrName
+ -> Maybe (LHsType RdrName)
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
checkValDef lhs opt_sig grhss
- | Just (f,inf,es) <- isFunLhs lhs []
- = if isQual (unLoc f)
- then parseError (getLoc f) ("Qualified name in function definition: " ++
- showRdrName (unLoc f))
- else do ps <- checkPatterns es
- return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
- -- TODO: span is wrong
- | otherwise = do
- lhs <- checkPattern lhs
- return (PatBind lhs 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 lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+ | isQual (unLoc fun)
+ = parseError (getLoc fun) ("Qualified name in function definition: " ++
+ showRdrName (unLoc fun))
+ | otherwise
+ = do ps <- checkPatterns pats
+ let match_span = combineSrcSpans lhs_loc rhs_span
+ matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
+ return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
+ -- The span of the match covers the entire equation.
+ -- That isn't quite right, but it'll do for now.
+
+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 = return (Sig (L l v) ty)
+checkValSig (L l (HsVar v)) ty
+ | isUnqual v && not (isDataOcc (rdrNameOcc v))
+ = return (TypeSig (L l v) ty)
checkValSig (L l other) ty
- = parseError l "Type signature given for an expression"
+ = parseError l "Invalid type signature"
+
+mkGadtDecl
+ :: Located RdrName
+ -> LHsType RdrName -- assuming HsType
+ -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
+mkGadtDecl name ty = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = []
+ , con_cxt = noLoc []
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
-- A variable binding is parsed as a FunBind.
-isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
- -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
-isFunLhs (L loc e) = isFunLhs' loc e
+
+ -- The parser left-associates, so there should
+ -- not be any OpApps inside the e's
+splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
+-- Splits (f ! g a b) into (f, [(! g), a, g])
+splitBang (L loc (OpApp l_arg bang@(L loc' (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 other = Nothing
+
+isFunLhs :: LHsExpr RdrName
+ -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- Just (fun, is_infix, arg_pats) if e is a function LHS
+isFunLhs e = go e []
where
- isFunLhs' loc (HsVar f) es
- | not (isRdrDataCon f) = Just (L loc f, False, es)
- isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
- isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
- isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
- | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
- | otherwise =
- case isFunLhs l es of
- Just (op', True, j : k : es') ->
- Just (op', True,
- j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
- _ -> Nothing
- isFunLhs' _ _ _ = Nothing
+ 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))) }
+ -- No bangs; behave just like the next case
+ | 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
---------------------------------------------------------------------------
-- Miscellaneous utilities
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
- = return (RecordCon (L l c) fs)
+ = return (RecordCon (L l c) noPostTcExpr fs)
mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs)
+ = return (RecordUpd exp fs placeHolderType placeHolderType)
mkRecConstrOrUpdate _ loc []
= parseError loc "Empty record update"
+mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+-- The Maybe is becuase the user can omit the activation spec (and usually does)
+mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
+mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
+mkInlineSpec (Just act) inl = Inline act inl
+
+
-----------------------------------------------------------------------------
-- utilities for foreign declarations
mkExport (CCall cconv) (L loc entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
where
- entity' | nullFastString entity = mkExtName (unLoc v)
- | otherwise = entity
+ entity' | nullFS entity = mkExtName (unLoc v)
+ | otherwise = entity
mkExport DNCall (L loc entity, v, ty) =
parseError (getLoc v){-TODO: not quite right-}
"Foreign export is not yet supported for .NET"
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--- (This is why we use occNameUserString.)
--
mkExtName :: RdrName -> CLabelString
-mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
+mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
\end{code}
projects / ghc-hetmet.git / blobdiff