X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=8d59e2b22ce3a40db205647e4329afdec991477f;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=781b085fe15881ce9c0dc88042a341dcc555bf80;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 781b085..8d59e2b 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -11,9 +11,8 @@ module RdrHsSyn ( mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, - mkTyData, mkPrefixCon, mkRecCon, + mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkBootIface, cvBindGroup, cvBindsAndSigs, @@ -21,53 +20,47 @@ module RdrHsSyn ( 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(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, - isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace, rdrNameModule ) -import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) -import Lexer ( P, failSpanMsgP ) -import Kind ( liftedTypeKind ) -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(..), CLabelString ) -import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, - occNameUserString, isValOcc ) -import BasicTypes ( initialVersion, StrictnessMark(..) ) -import Module ( ModuleName ) +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, + occNameString ) import SrcLoc -import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable @@ -97,33 +90,35 @@ extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrNa 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 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 (HsSpliceTy _) acc = acc -- Type splices mention no type variables -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 @@ -131,8 +126,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] 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 @@ -163,10 +158,10 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds 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} @@ -178,185 +173,7 @@ mkHsNegApp (L loc e) = f e 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 { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), - 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) - -hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls -hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified", - = IfAbstractTyCon -- not "no constructors" - -hsIfaceCons DataType cons -- data type - = IfDataTyCon (map (hsIfaceCon . unLoc) cons) - -hsIfaceCons NewType [con] -- newtype - = IfNewTyCon (hsIfaceCon (unLoc con)) - - -hsIfaceCon :: ConDecl RdrName -> IfaceConDecl -hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) - = IfaceConDecl (get_occ lname) is_infix - (hsIfaceTvs ex_tvs) - (hsIfaceCtxt (unLoc ex_ctxt)) - (map (hsIfaceLType . getBangType . unLoc) args) - (map (hsStrictMark . getBangStrictness . unLoc) args) - flds - where - (is_infix, args, flds) = case details of - PrefixCon args -> (False, args, []) - InfixCon a1 a2 -> (True, [a1,a2], []) - RecCon fs -> (False, map snd fs, map (get_occ . fst) fs) - get_occ lname = rdrNameOcc (unLoc lname) - -hsStrictMark :: HsBang -> StrictnessMark --- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request --- but in an hi-boot file it's interpreted as the Truth! -hsStrictMark HsNoBang = NotMarkedStrict -hsStrictMark HsStrict = MarkedStrict -hsStrictMark HsUnbox = MarkedUnboxed - -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 (HsPredTy p) = IfacePredTy (hsIfacePred p) -hsIfaceType (HsKindSig t _) = hsIfaceLType t -hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" -hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy" - ------------ -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, liftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, 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} %************************************************************************ @@ -371,7 +188,7 @@ analyser. \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 @@ -381,10 +198,10 @@ cvTopDecls decls = go (fromOL decls) 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) @@ -414,16 +231,16 @@ getMonoBind :: LHsBind RdrName -> [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) @@ -435,16 +252,11 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) \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 @@ -456,7 +268,7 @@ addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a] -- 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 @@ -495,8 +307,8 @@ add gp@(HsGroup {hs_depds = ts}) l (DeprecD 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} %************************************************************************ @@ -520,7 +332,7 @@ mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] 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" @@ -565,6 +377,10 @@ checkTyVars tvs 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 @@ -626,11 +442,12 @@ checkPred (L 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 [] @@ -646,23 +463,23 @@ checkDictTy (L spn ty) = check ty [] -- 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. @@ -682,12 +499,16 @@ 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 (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 @@ -702,12 +523,14 @@ checkAPat loc e = case e of -- 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 @@ -723,8 +546,6 @@ checkAPat loc e = case e of (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 -> @@ -740,14 +561,18 @@ checkAPat loc e = case e of 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 +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 p <- checkLPat e @@ -759,51 +584,111 @@ patFail loc = parseError loc "Parse error in pattern" --------------------------------------------------------------------------- -- 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 @@ -820,12 +705,19 @@ mkRecConstrOrUpdate -> 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 @@ -948,8 +840,8 @@ mkExport :: CallConv 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" @@ -959,10 +851,9 @@ mkExport DNCall (L loc entity, v, ty) = -- 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}