X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=c99a8d565f0b7f8dab1300e12a93ac0d710a2766;hb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;hp=656fc34b45feb3ac5e2d3b9810d099243181cc53;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 656fc34..c99a8d5 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -13,7 +13,6 @@ module RdrHsSyn ( mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkBootIface, cvBindGroup, cvBindsAndSigs, @@ -50,8 +49,10 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType -import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) +import Packages ( PackageIdH(..) ) +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache, + Dependencies(..), IsBootInterface, noDependencies ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace, rdrNameModule ) @@ -61,15 +62,12 @@ import Kind ( liftedTypeKind ) import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..), DNKind(..)) + DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, isValOcc ) -import BasicTypes ( initialVersion ) -import TyCon ( DataConDetails(..) ) -import Module ( ModuleName ) +import BasicTypes ( initialVersion, StrictnessMark(..) ) +import Module ( Module ) import SrcLoc -import CStrings ( CLabelString ) -import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable @@ -109,12 +107,13 @@ extract_lty (L loc (HsTyVar tv)) acc | otherwise = acc extract_lty ty acc = extract_ty (unLoc ty) acc +extract_ty (HsBangTy _ ty) acc = extract_lty 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 (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 @@ -133,8 +132,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 _ _ (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 @@ -165,10 +164,10 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds tcdMeths = mbinds } -mkTyData new_or_data (context, tname, tyvars) data_cons maybe +mkTyData new_or_data (L _ (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} @@ -185,151 +184,6 @@ mkHsNegApp (L loc e) = f e %************************************************************************ %* * - 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 (HsPredTy p) = IfacePredTy (hsIfaceLPred 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 ] -\end{code} - -%************************************************************************ -%* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} %* * %************************************************************************ @@ -383,15 +237,16 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds +-- gaw 2004 +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds) + go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds) | f == unLoc f2 = go (mtchs2++mtchs1) loc binds where loc = combineSrcSpans loc1 loc2 go mtchs1 loc binds - = (L loc (FunBind lf inf (reverse mtchs1)), binds) + = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds) -- reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -425,7 +280,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 @@ -489,7 +344,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" @@ -588,7 +443,7 @@ checkPred :: LHsType RdrName -> P (LHsPred RdrName) -- 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 [] @@ -604,8 +459,8 @@ checkPred (L spn 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 (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" @@ -731,20 +586,22 @@ patFail loc = parseError loc "Parse error in pattern" checkValDef :: LHsExpr RdrName -> Maybe (LHsType RdrName) - -> GRHSs RdrName + -> Located (GRHSs RdrName) -> P (HsBind RdrName) -checkValDef lhs opt_sig grhss +checkValDef lhs opt_sig (L rhs_span 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 + let match_span = combineSrcSpans (getLoc lhs) rhs_span + return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)])) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. | otherwise = do lhs <- checkPattern lhs - return (PatBind lhs grhss) + return (PatBind lhs grhss placeHolderType) checkValSig :: LHsExpr RdrName