X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FPrefixToHs.lhs;h=c638ca2f52393641fcd11beb3e189de6790a7a1c;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=c30abba2b41db340a69babd0dc8ef0569a2bccb4;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index c30abba..c638ca2 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -9,14 +9,13 @@ Support routines for reading prefix-form from the Lex/Yacc parser. #include "HsVersions.h" module PrefixToHs ( - cvBinds, + cvValSig, cvClassOpSig, cvInstDeclSig, + cvBinds, cvMatches, cvMonoBinds, cvSepdBinds, - cvValSig, - sepDeclsForInterface, sepDeclsForTopBinds, sepDeclsIntoSigsAndBinds ) where @@ -28,9 +27,8 @@ import HsSyn import RdrHsSyn import HsPragmas ( noGenPragmas, noClassOpPragmas ) -import ProtoName ( ProtoName(..) ) import SrcLoc ( mkSrcLoc2 ) -import Util ( panic, assertPanic ) +import Util ( mapAndUnzip, panic, assertPanic ) \end{code} %************************************************************************ @@ -44,17 +42,11 @@ these conversion functions: \begin{code} cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter -cvValSig (RdrTySig vars poly_ty pragmas src_loc) - = [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ] - where - cvt_pragmas RdrNoPragma = noGenPragmas - cvt_pragmas (RdrGenPragmas ps) = ps +cvValSig (RdrTySig vars poly_ty src_loc) + = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ] -cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc) - = [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ] - where - cvt_pragmas RdrNoPragma = noClassOpPragmas - cvt_pragmas (RdrClassOpPragmas ps) = ps +cvClassOpSig (RdrTySig vars poly_ty src_loc) + = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ] cvInstDeclSig (RdrSpecValSig sigs) = sigs cvInstDeclSig (RdrInlineValSig sig) = [ sig ] @@ -73,11 +65,11 @@ initially, and non recursive definitions are discovered by the dependency analyser. \begin{code} -cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameHsBinds +cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds cvBinds sf sig_cvtr raw_binding = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding) -cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameHsBinds +cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds cvSepdBinds sf sig_cvtr bindings = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) -> if (null sigs) @@ -85,7 +77,7 @@ cvSepdBinds sf sig_cvtr bindings else BindWith (RecBind mbs) sigs } -cvMonoBinds :: SrcFile -> [RdrBinding] -> ProtoNameMonoBinds +cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds cvMonoBinds sf bindings = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) -> if (null sigs) @@ -100,7 +92,7 @@ cvMonoBinds sf bindings mkMonoBindsAndSigs :: SrcFile -> SigConverter -> [RdrBinding] - -> (ProtoNameMonoBinds, [ProtoNameSig]) + -> (RdrNameMonoBinds, [RdrNameSig]) mkMonoBindsAndSigs sf sig_cvtr fbs = foldl mangle_bind (EmptyMonoBinds, []) fbs @@ -113,7 +105,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs -- function. Otherwise there is only one pattern, which is paired -- with a guarded right hand side. - mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _ _) + mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _) = (b_acc, s_acc ++ sig_cvtr sig) mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc) @@ -142,14 +134,14 @@ mkMonoBindsAndSigs sf sig_cvtr fbs mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings) -- must be a function binding... - = case (cvFunMonoBind sf patbindings) of { (var, matches) -> + = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) -> (b_acc `AndMonoBinds` - FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc) + FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc) } \end{code} \begin{code} -cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameHsBinds) +cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds) cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding) @@ -157,17 +149,24 @@ cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding) = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding) -cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch]) +cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch]) cvFunMonoBind sf matches - = (srcfun {- cheating ... -}, cvMatches sf False matches) + = (head srcfuns, head infixdefs, cvMatches sf False matches) where - srcfun = case (head matches) of - RdrMatch_NoGuard _ sfun _ _ _ -> sfun - RdrMatch_Guards _ sfun _ _ _ -> sfun + (srcfuns, infixdefs) = mapAndUnzip get_mdef matches + -- ToDo: Check for consistent srcfun and infixdef + + get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat + get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat + + get_pdef (ConPatIn fn _) = (fn, False) + get_pdef (ConOpPatIn _ op _) = (op, True) + get_pdef (ParPatIn pat) = get_pdef pat -cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch] -cvMatch :: SrcFile -> Bool -> RdrMatch -> ProtoNameMatch + +cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch] +cvMatch :: SrcFile -> Bool -> RdrMatch -> RdrNameMatch cvMatches sf is_case matches = map (cvMatch sf is_case) matches @@ -181,10 +180,11 @@ cvMatch sf is_case rdr_match -- we most certainly want to keep it! Hence the monkey busines... (if is_case then -- just one pattern: leave it untouched... - [pat'] - else - case pat' of - ConPatIn _ pats -> pats + [pat] + else -- function pattern; extract arg patterns... + case pat of ConPatIn fn pats -> pats + ConOpPatIn p1 op p2 -> [p1,p2] + ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn" ) where (pat, binding, guarded_exprs) @@ -192,17 +192,7 @@ cvMatch sf is_case rdr_match RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)]) RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps) - --------------------- - pat' = doctor_pat pat - - -- a ConOpPatIn in the corner may be handled by converting it to - -- ConPatIn... - - doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2] - doctor_pat other_pat = other_pat - -cvGRHS :: SrcFile -> SrcLine -> (ProtoNameHsExpr, ProtoNameHsExpr) -> ProtoNameGRHS - +cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl) \end{code} @@ -223,7 +213,6 @@ defaults RdrDefaultDecl binds RdrFunctionBinding RdrPatternBinding RdrTySig RdrSpecValSig RdrInlineValSig RdrDeforestSig RdrMagicUnfoldingSig -iimps RdrIfaceImportDecl (interfaces only) \end{display} This function isn't called directly; some other function calls it, @@ -232,99 +221,84 @@ then checks that what it got is appropriate for that situation. \begin{code} sepDecls (RdrTyDecl a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (a:tys,tysigs,classes,insts,instsigs,defaults,binds) sepDecls a@(RdrFunctionBinding _ _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls a@(RdrPatternBinding _ _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) -- RdrAndBindings catered for below... sepDecls (RdrClassDecl a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,a:classes,insts,instsigs,defaults,binds) sepDecls (RdrInstDecl a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,a:insts,instsigs,defaults,binds) sepDecls (RdrDefaultDecl a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps,ifixs) - -sepDecls a@(RdrTySig _ _ _ _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) - -sepDecls (RdrIfaceImportDecl a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,a:defaults,binds) -sepDecls (RdrIfaceFixities a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,a++ifixs) +sepDecls a@(RdrTySig _ _ _) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls a@(RdrSpecValSig _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls a@(RdrInlineValSig _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls a@(RdrDeforestSig _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls a@(RdrMagicUnfoldingSig _) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) sepDecls (RdrSpecInstSig a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,a:instsigs,defaults,binds) sepDecls (RdrSpecDataSig a) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,a:tysigs,classes,insts,instsigs,defaults,binds) sepDecls RdrNullBind - tys tysigs classes insts instsigs defaults binds iimps ifixs - = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,defaults,binds) sepDecls (RdrAndBindings bs1 bs2) - tys tysigs classes insts instsigs defaults binds iimps ifixs - = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps ifixs) of { - (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) -> - sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps ifixs + tys tysigs classes insts instsigs defaults binds + = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of { + (tys,tysigs,classes,insts,instsigs,defaults,binds) -> + sepDecls bs1 tys tysigs classes insts instsigs defaults binds } \end{code} \begin{code} sepDeclsForTopBinds binding - = case (sepDecls binding [] [] [] [] [] [] [] [] []) - of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) -> - ASSERT ((null iimps) - && (null ifixs)) - (tys,tysigs,classes,insts,instsigs,defaults,binds) - } + = sepDecls binding [] [] [] [] [] [] [] sepDeclsForBinds binding - = case (sepDecls binding [] [] [] [] [] [] [] [] []) - of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) -> + = case (sepDecls binding [] [] [] [] [] [] []) + of { (tys,tysigs,classes,insts,instsigs,defaults,binds) -> ASSERT ((null tys) && (null tysigs) && (null classes) && (null insts) && (null instsigs) - && (null defaults) - && (null iimps) - && (null ifixs)) + && (null defaults)) binds } @@ -333,7 +307,7 @@ sepDeclsIntoSigsAndBinds binding foldr sep_stuff ([],[]) sigs_and_binds } where - sep_stuff s@(RdrTySig _ _ _ _) (sigs,defs) = (s:sigs,defs) + sep_stuff s@(RdrTySig _ _ _) (sigs,defs) = (s:sigs,defs) sep_stuff s@(RdrSpecValSig _) (sigs,defs) = (s:sigs,defs) sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs) sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs) @@ -342,18 +316,4 @@ sepDeclsIntoSigsAndBinds binding sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs) -sepDeclsForInterface binding - = case (sepDecls binding [] [] [] [] [] [] [] [] []) - of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps,ifixs) -> - ASSERT ((null defaults) - && (null tysigs) - && (null instsigs)) - ASSERT (not (not_all_sigs sigs)) - (tys,classes,insts,sigs,iimps,ifixs) - } - where - not_all_sigs sigs = not (all is_a_sig sigs) - - is_a_sig (RdrTySig _ _ _ _) = True - is_a_sig anything_else = False \end{code}