X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=7d51a54c07682647dd70fdd33e37cec578cd6e13;hb=3a49601be4ed68d59ca9a81589e3cb627ae268d7;hp=101ada1595f5837606d5ef585e1a74e397be0ef9;hpb=16e4ce4c0c02650082f2e11982017c903c549ad5;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 101ada1..7d51a54 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,7 +16,6 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, - RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, @@ -47,15 +46,15 @@ module RdrHsSyn ( main_RDR_Unqual, - extractHsTyRdrNames, extractHsTyRdrTyVars, - extractHsCtxtRdrTyVars, extractGenericPatTyVars, + extractHsTyRdrTyVars, + extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkSigDecls, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] + mkBootIface, cvBinds, cvMonoBindsAndSigs, @@ -94,20 +93,26 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it +import IfaceType +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) -import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence ) -import Class ( DefMeth (..) ) -import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP ) -import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) -import TysWiredIn ( unitTyCon ) + setRdrNameSpace, rdrNameModule ) +import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) +import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP ) +import HscTypes ( GenAvailInfo(..) ) +import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..)) -import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, - mkDefaultMethodOcc, mkVarOcc ) +import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, + occNameUserString, mkVarOcc, isValOcc ) +import BasicTypes ( initialVersion ) +import TyCon ( DataConDetails(..) ) +import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) +import CmdLineOpts ( opt_InPackage ) import List ( isSuffixOf, nub ) import Outputable import FastString @@ -131,7 +136,6 @@ type RdrNameContext = HsContext RdrName type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameCoreDecl = CoreDecl RdrName type RdrNameGRHS = GRHS RdrName type RdrNameGRHSs = GRHSs RdrName type RdrNameHsBinds = HsBinds RdrName @@ -176,41 +180,36 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrNames :: RdrNameHsType -> [RdrName] -extractHsTyRdrNames ty = nub (extract_ty ty []) - extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) -extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) -extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) +extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName] +-- This one takes the context and tau-part of a +-- sigma type and returns their free type variables +extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $ + extract_ctxt ctxt (extract_ty ty []) extract_ctxt ctxt acc = foldr extract_pred acc ctxt extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys extract_pred (HsIParam n ty) acc = extract_ty ty acc -extract_tys tys = foldr extract_ty [] tys - -extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsListTy ty) acc = extract_ty ty acc -extract_ty (HsPArrTy ty) acc = extract_ty ty acc -extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys -extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred p acc -extract_ty (HsTyVar tv) acc = tv : acc -extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) -extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsParTy ty) acc = extract_ty ty acc --- Generics -extract_ty (HsNumTy num) acc = acc -extract_ty (HsKindSig ty k) acc = extract_ty ty acc -extract_ty (HsForAllTy (Just tvs) ctxt ty) +extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsPArrTy ty) acc = extract_ty ty acc +extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys +extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsPredTy p) acc = extract_pred p acc +extract_ty (HsTyVar tv) acc = tv : acc +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsParTy ty) acc = extract_ty ty acc +extract_ty (HsNumTy num) acc = acc +extract_ty (HsKindSig ty k) acc = extract_ty ty acc +extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc) +extract_ty (HsForAllTy exp tvs cx ty) acc = acc ++ (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) + extract_ctxt cx (extract_ty ty [])) where locals = hsTyVarNames tvs @@ -249,22 +248,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, - tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs + tcdSigs = sigs, tcdMeths = mbinds, tcdLoc = loc } mkTyData new_or_data (context, tname, tyvars) data_cons maybe src = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } - -cvClassOpSig :: RdrNameSig -> RdrNameSig -cvClassOpSig (Sig var poly_ty src_loc) - = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var)) -cvClassOpSig sig - = sig + tcdDerivs = maybe, tcdLoc = src } \end{code} \begin{code} @@ -276,7 +267,7 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp expr = NegApp expr placeHolderName +mkHsNegApp expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -306,6 +297,145 @@ unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) %************************************************************************ %* * + 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 name, + ifType = hsIfaceType ty, + ifIdInfo = NoInfo } + +hsIfaceDecl (TyClD decl@(TySynonym {})) + = IfaceSyn { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifSynRhs = hsIfaceType (tcdSynRhs decl), + ifVrcs = [] } + +hsIfaceDecl (TyClD decl@(TyData {})) + = IfaceData { ifND = tcdND decl, + ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (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 (tcdCtxt decl), + ifFDs = hsIfaceFDs (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) + +hsIfaceType :: HsType RdrName -> IfaceType +hsIfaceType (HsForAllTy exp tvs cxt ty) + = foldr (IfaceForAllTy . hsIfaceTv) rho tvs' + where + rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt + tau = hsIfaceType ty + tvs' = case exp of + Explicit -> tvs + Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) + +hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] +hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] +hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2) +hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t] +hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t] +hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts) +hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2]) +hsIfaceType (HsParTy t) = hsIfaceType t +hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) +hsIfaceType (HsKindSig t _) = hsIfaceType t + +----------- +hsIfaceTypes tys = map hsIfaceType tys + +----------- +hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType] +hsIfaceCtxt ctxt = map hsIfacePred ctxt + +----------- +hsIfacePred :: HsPred RdrName -> IfacePredType +hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts) +hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t) + +----------- +hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType +hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType 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 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 ] +\end{code} + + +%************************************************************************ +%* * \subsection[rdrBinding]{Bindings straight out of the parser} %* * %************************************************************************ @@ -416,7 +546,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, -- they start life as a single giant MonoBinds hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_fords = [], - hs_depds = [] ,hs_ruleds = [], hs_coreds = [] } + hs_depds = [] ,hs_ruleds = [] } findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) findSplice ds = add emptyGroup ds @@ -456,7 +586,6 @@ add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds -add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r @@ -484,19 +613,19 @@ mkPrefixCon ty tys = split ty tys where split (HsAppTy t u) ts = split t (unbangedType u : ts) - split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> - returnP (data_con, PrefixCon ts) + split (HsTyVar tc) ts = tyConToDataCon tc >>= \ data_con -> + return (data_con, PrefixCon ts) split _ _ = parseError "Illegal data/newtype declaration" mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) mkRecCon con fields - = tyConToDataCon con `thenP` \ data_con -> - returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + = tyConToDataCon con >>= \ data_con -> + return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) tyConToDataCon :: RdrName -> P RdrName tyConToDataCon tc | isTcOcc (rdrNameOcc tc) - = returnP (setRdrNameSpace tc srcDataName) + = return (setRdrNameSpace tc srcDataName) | otherwise = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) @@ -506,74 +635,82 @@ tyConToDataCon tc checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of - HsForAllTy tvs ctxt ty -> - checkDictTy ty [] `thenP` \ dict_ty -> - returnP (HsForAllTy tvs ctxt dict_ty) + HsForAllTy exp tvs ctxt ty -> + checkDictTy ty [] >>= \ dict_ty -> + return (HsForAllTy exp tvs ctxt dict_ty) HsParTy ty -> checkInstType ty - ty -> checkDictTy ty [] `thenP` \ dict_ty-> - returnP (HsForAllTy Nothing [] dict_ty) + ty -> checkDictTy ty [] >>= \ dict_ty-> + return (HsForAllTy Implicit [] [] dict_ty) checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] checkTyVars tvs - = mapP chk tvs + = mapM chk tvs where -- Check that the name space is correct! - chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k) - chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv) + chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k) + chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv) chk other = parseError "Type found where type variable expected" -checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc -checkTyClHdr ty - = go ty [] +checkTyClHdr cxt ty + = go ty [] >>= \ (tc, tvs) -> + mapM chk_pred cxt >>= \ _ -> + return (cxt, tc, tvs) where go (HsTyVar tc) acc - | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs -> - returnP (tc, tvs) - go (HsOpTy t1 (HsTyOp tc) t2) acc - = checkTyVars (t1:t2:acc) `thenP` \ tvs -> - returnP (tc, tvs) + | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> + return (tc, tvs) + go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> + return (tc, tvs) go (HsParTy ty) acc = go ty acc go (HsAppTy t1 t2) acc = go t1 (t2:acc) go other acc = parseError "Malformed LHS to type of class declaration" + -- The predicates in a type or class decl must all + -- be HsClassPs. They need not all be type variables, + -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (HsClassP _ args) = return () + chk_pred pred = parseError "Malformed context in type or class declaration" + + checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = mapP checkPred ts + = mapM checkPred ts checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way = checkContext ty checkContext (HsTyVar t) -- Empty context shows up as a unit type () - | t == getRdrName unitTyCon = returnP [] + | t == getRdrName unitTyCon = return [] checkContext t - = checkPred t `thenP` \p -> - returnP [p] + = checkPred t >>= \p -> + return [p] checkPred :: RdrNameHsType -> P (HsPred 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 (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) +checkPred (HsPredTy (HsIParam n ty)) = return (HsIParam n ty) checkPred ty = go ty [] where go (HsTyVar t) args | not (isRdrTyVar t) - = returnP (HsClassP t args) + = return (HsClassP t args) go (HsAppTy l r) args = go l (r:args) go (HsParTy t) args = go t args go _ _ = parseError "Illegal class assertion" checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (mkHsDictTy t args) + = return (mkHsDictTy t args) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) checkDictTy (HsParTy t) args = checkDictTy t args checkDictTy _ _ = parseError "Malformed context in instance header" @@ -591,86 +728,87 @@ checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct" -checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l] +checkDoMDo _ _ [ExprStmt e _ l] = return [ResultStmt e l] checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression" -checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' -> - returnP (s:ss') +checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' -> + return (s:ss') ---------------------------------------------------------------------------- +-- ------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat -checkPattern loc e = setSrcLocP loc (checkPat e []) +checkPattern loc e = setSrcLocFor loc (checkPat e []) checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] -checkPatterns loc es = mapP (checkPattern loc) es +checkPatterns loc es = mapM (checkPattern loc) es checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat -checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args)) +checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args)) checkPat (HsApp f x) args = - checkPat x [] `thenP` \x -> + checkPat x [] >>= \x -> checkPat f (x:args) checkPat e [] = case e of - EWildPat -> returnP (WildPat placeHolderType) + EWildPat -> return (WildPat placeHolderType) HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x) - | otherwise -> returnP (VarPat x) - HsLit l -> returnP (LitPat l) - HsOverLit l -> returnP (NPatIn l Nothing) - ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat) - EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n) - ExprWithTySig e t -> checkPat e [] `thenP` \e -> + | otherwise -> return (VarPat x) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- 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) + NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName)) + + ELazyPat e -> checkPat e [] >>= (return . LazyPat) + EAsPat n e -> checkPat e [] >>= (return . AsPat n) + ExprWithTySig e t -> checkPat e [] >>= \e -> -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence -- we have to remove the implicit forall here. let t' = case t of - HsForAllTy Nothing [] ty -> ty + HsForAllTy Implicit _ [] ty -> ty other -> other in - returnP (SigPatIn e t') - - -- Translate out NegApps of literals in patterns. We negate - -- the Integer here, and add back the call to 'negate' when - -- we typecheck the pattern. - -- NB. Negative *primitive* literals are already handled by - -- RdrHsSyn.mkHsNegApp - NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg)) + return (SigPatIn e t') + -- n+k patterns OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) | plus == plus_RDR - -> returnP (mkNPlusKPat n lit) + -> return (mkNPlusKPat n lit) where plus_RDR = mkUnqual varName FSLIT("+") -- Hack - OpApp l op fix r -> checkPat l [] `thenP` \l -> - checkPat r [] `thenP` \r -> + OpApp l op fix r -> checkPat l [] >>= \l -> + checkPat r [] >>= \r -> case op of HsVar c | isDataOcc (rdrNameOcc c) - -> returnP (ConPatIn c (InfixCon l r)) + -> return (ConPatIn c (InfixCon l r)) _ -> patFail - HsPar e -> checkPat e [] `thenP` (returnP . ParPat) - ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (ListPat ps placeHolderType) - ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (PArrPat ps placeHolderType) + HsPar e -> checkPat e [] >>= (return . ParPat) + ExplicitList _ es -> mapM (\e -> checkPat e []) es >>= \ps -> + return (ListPat ps placeHolderType) + ExplicitPArr _ es -> mapM (\e -> checkPat e []) es >>= \ps -> + return (PArrPat ps placeHolderType) - ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (TuplePat ps b) + ExplicitTuple es b -> mapM (\e -> checkPat e []) es >>= \ps -> + return (TuplePat ps b) - RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> - returnP (ConPatIn c (RecCon fs)) + RecordCon c fs -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon fs)) -- Generics - HsType ty -> returnP (TypePat ty) + HsType ty -> return (TypePat ty) _ -> patFail checkPat _ _ = patFail checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) -checkPatField (n,e) = checkPat e [] `thenP` \p -> - returnP (n,p) +checkPatField (n,e) = checkPat e [] >>= \p -> + return (n,p) patFail = parseError "Parse error in pattern" @@ -691,19 +829,19 @@ checkValDef lhs opt_sig grhss loc | isQual f -> parseError ("Qualified name in function definition: " ++ showRdrName f) | otherwise - -> checkPatterns loc es `thenP` \ps -> - returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) + -> checkPatterns loc es >>= \ps -> + return (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) Nothing -> - checkPattern loc lhs `thenP` \lhs -> - returnP (RdrValBinding (PatMonoBind lhs grhss loc)) + checkPattern loc lhs >>= \lhs -> + return (RdrValBinding (PatMonoBind lhs grhss loc)) checkValSig :: RdrNameHsExpr -> RdrNameHsType -> SrcLoc -> P RdrBinding -checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc))) +checkValSig (HsVar v) ty loc | isUnqual v = return (RdrHsDecl (SigD (Sig v ty loc))) checkValSig other ty loc = parseError "Type signature given for an expression" mkSigDecls :: [Sig RdrName] -> RdrBinding @@ -731,7 +869,7 @@ isFunLhs _ _ = Nothing -- Miscellaneous utilities checkPrecP :: Int -> P Int -checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i +checkPrecP i | 0 <= i && i <= maxPrecedence = return i | otherwise = parseError "Precedence out of range" mkRecConstrOrUpdate @@ -740,9 +878,9 @@ mkRecConstrOrUpdate -> P RdrNameHsExpr mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c - = returnP (RecordCon c fs) + = return (RecordCon c fs) mkRecConstrOrUpdate exp fs@(_:_) - = returnP (RecordUpd exp fs) + = return (RecordUpd exp fs) mkRecConstrOrUpdate _ _ = parseError "Empty record update" @@ -762,11 +900,11 @@ mkImport :: CallConv -> SrcLoc -> P RdrNameHsDecl mkImport (CCall cconv) safety (entity, v, ty) loc = - parseCImport entity cconv safety v `thenP` \importSpec -> - returnP $ ForD (ForeignImport v ty importSpec False loc) + parseCImport entity cconv safety v >>= \importSpec -> + return $ ForD (ForeignImport v ty importSpec False loc) mkImport (DNCall ) _ (entity, v, ty) loc = - parseDImport entity `thenP` \ spec -> - returnP $ ForD (ForeignImport v ty (DNImport spec) False loc) + parseDImport entity >>= \ spec -> + return $ ForD (ForeignImport v ty (DNImport spec) False loc) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' @@ -779,9 +917,9 @@ parseCImport :: FastString parseCImport entity cconv safety v -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak | entity == FSLIT ("dynamic") = - returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) + return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) | entity == FSLIT ("wrapper") = - returnP $ CImport cconv safety nilFS nilFS CWrapper + return $ CImport cconv safety nilFS nilFS CWrapper | otherwise = parse0 (unpackFS entity) where -- using the static keyword? @@ -820,9 +958,9 @@ parseCImport entity cconv safety v where (first, rest) = break (== ' ') str -- - build cid header False lib = returnP $ + build cid header False lib = return $ CImport cconv safety header lib (CFunction (StaticTarget cid)) - build cid header True lib = returnP $ + build cid header True lib = return $ CImport cconv safety header lib (CLabel cid ) -- @@ -853,7 +991,7 @@ parseDImport entity = parse0 comps parse2 isStatic kind xs = parse3 isStatic kind "" xs parse3 isStatic kind assem [x] = - returnP (DNCallSpec isStatic kind assem x + return (DNCallSpec isStatic kind assem x -- these will be filled in once known. (error "FFI-dotnet-args") (error "FFI-dotnet-result")) @@ -867,7 +1005,7 @@ mkExport :: CallConv -> (FastString, RdrName, RdrNameHsType) -> SrcLoc -> P RdrNameHsDecl -mkExport (CCall cconv) (entity, v, ty) loc = returnP $ +mkExport (CCall cconv) (entity, v, ty) loc = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) where entity' | nullFastString entity = mkExtName v @@ -884,20 +1022,6 @@ mkExport DNCall (entity, v, ty) loc = -- mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) - --- --------------------------------------------------------------------------- --- Make the export list for an interface - -mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] -mkIfaceExports decls = map getExport decls - where getExport d = case d of - TyData{} -> tc_export - ClassDecl{} -> tc_export - _other -> var_export - where - tc_export = AvailTC (rdrNameOcc (tcdName d)) - (map (rdrNameOcc.fst) (tyClDeclNames d)) - var_export = Avail (rdrNameOcc (tcdName d)) \end{code} @@ -910,7 +1034,6 @@ showRdrName r = showSDoc (ppr r) parseError :: String -> P a parseError s = - getSrcLocP `thenP` \ loc -> - failMsgP (hcat [ppr loc, text ": ", text s]) + getSrcLoc >>= \ loc -> + failLocMsgP loc loc s \end{code} -