X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Freader%2FPrefixToHs.lhs;h=c638ca2f52393641fcd11beb3e189de6790a7a1c;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=96c993c8757b09dfac44715fb903512577cf7ac5;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 96c993c..c638ca2 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax} @@ -9,30 +9,26 @@ Support routines for reading prefix-form from the Lex/Yacc parser. #include "HsVersions.h" module PrefixToHs ( - cvBinds, + cvValSig, cvClassOpSig, cvInstDeclSig, - cvInstDecls, + cvBinds, cvMatches, cvMonoBinds, cvSepdBinds, - cvValSig, - sepDeclsForInterface, sepDeclsForTopBinds, sepDeclsIntoSigsAndBinds ) where -IMPORT_Trace -- ToDo: rm -import Pretty +import Ubiq{-uitous-} + +import PrefixSyn -- and various syntaxen. +import HsSyn +import RdrHsSyn +import HsPragmas ( noGenPragmas, noClassOpPragmas ) -import AbsSyn -import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** -import Outputable -import PrefixSyn -import ProtoName -- ProtoName(..), etc. import SrcLoc ( mkSrcLoc2 ) -import Util +import Util ( mapAndUnzip, panic, assertPanic ) \end{code} %************************************************************************ @@ -41,32 +37,16 @@ import Util %* * %************************************************************************ -\begin{code} -cvInstDecls :: Bool -> FAST_STRING -> FAST_STRING - -> [FAST_STRING -> FAST_STRING -> Bool -> ProtoNameInstDecl] -- incomplete InstDecls - -> [ProtoNameInstDecl] - -cvInstDecls from_here orig_modname informant_modname decls - = [ decl_almost orig_modname informant_modname from_here - | decl_almost <- decls ] -\end{code} - We make a point not to throw any user-pragma ``sigs'' at 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 ] @@ -76,7 +56,7 @@ cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ] %************************************************************************ %* * -\subsection[cvBinds-etc]{Converting to @Binds@, @MonoBinds@, etc.} +\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.} %* * %************************************************************************ @@ -85,11 +65,11 @@ initially, and non recursive definitions are discovered by the dependency analyser. \begin{code} -cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameBinds +cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds cvBinds sf sig_cvtr raw_binding = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding) -cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameBinds +cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds cvSepdBinds sf sig_cvtr bindings = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) -> if (null sigs) @@ -97,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) @@ -112,7 +92,7 @@ cvMonoBinds sf bindings mkMonoBindsAndSigs :: SrcFile -> SigConverter -> [RdrBinding] - -> (ProtoNameMonoBinds, [ProtoNameSig]) + -> (RdrNameMonoBinds, [RdrNameSig]) mkMonoBindsAndSigs sf sig_cvtr fbs = foldl mangle_bind (EmptyMonoBinds, []) fbs @@ -125,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) @@ -134,7 +114,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc) mangle_bind (b_acc, s_acc) - (RdrPatternBinding lousy_srcline [patbinding@(RdrMatch good_srcline _ _ _ _)]) + (RdrPatternBinding lousy_srcline [patbinding]) -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings. = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) -> let @@ -143,74 +123,77 @@ mkMonoBindsAndSigs sf sig_cvtr fbs (b_acc `AndMonoBinds` PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc) } + where + good_srcline = case patbinding of + RdrMatch_NoGuard ln _ _ _ _ -> ln + RdrMatch_Guards ln _ _ _ _ -> ln + mangle_bind _ (RdrPatternBinding _ _) = panic "mangleBinding: more than one pattern on a RdrPatternBinding" 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], ProtoNameBinds) +cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds) -cvPatMonoBind sf (RdrMatch srcline srcfun pat guardedexprs binding) - = (pat, cvGRHSs srcfun sf srcline guardedexprs, cvBinds sf cvValSig binding) +cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) + = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding) + +cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding) + = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding) + +cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch]) + +cvFunMonoBind sf matches + = (head srcfuns, head infixdefs, cvMatches sf False matches) + where + (srcfuns, infixdefs) = mapAndUnzip get_mdef matches + -- ToDo: Check for consistent srcfun and infixdef -cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch]) + get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat + get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat -cvFunMonoBind sf matches@((RdrMatch srcline srcfun pat guardedexprs binding):_) - = ( Unk srcfun, -- cheating ... - cvMatches sf False matches ) + 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 -cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding) +cvMatch sf is_case rdr_match = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn (cvGRHSs srcfun sf srcline guardedexprs) - (cvBinds sf cvValSig binding))) + (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding))) -- For a FunMonoBinds, the first flattened "pattern" is -- just the function name, and we don't want to keep it. -- For a case expr, it's (presumably) a constructor name -- and -- we most certainly want to keep it! Hence the monkey busines... --- (trace ("cvMatch:"++(ppShow 80 (ppr PprDebug pat))) ( (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' = 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 - -cvGRHSs :: FAST_STRING -> SrcFile -> SrcLine -> [(ProtoNameExpr, ProtoNameExpr)] -> [ProtoNameGRHS] + (pat, binding, guarded_exprs) + = case rdr_match of + 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) -cvGRHSs sfun sf sl guarded_exprs = map (cvGRHS sfun sf sl) guarded_exprs - -cvGRHS :: FAST_STRING -> SrcFile -> SrcLine -> (ProtoNameExpr, ProtoNameExpr) -> ProtoNameGRHS - -cvGRHS sfun sf sl (Var v@(Unk str), e) - | str == SLIT("__o") -- "__otherwise" ToDo: de-urgh-ify - = OtherwiseGRHS e (mkSrcLoc2 sf sl) - -cvGRHS sfun sf sl (g, e) - = GRHS g e (mkSrcLoc2 sf sl) +cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS +cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl) \end{code} %************************************************************************ @@ -221,16 +204,15 @@ cvGRHS sfun sf sl (g, e) Separate declarations into all the various kinds: \begin{display} -tys RdrTyData RdrTySynonym -type "sigs" RdrAbstractTypeSig RdrSpecDataSig +tys RdrTyDecl +ty "sigs" RdrSpecDataSig classes RdrClassDecl -instances RdrInstDecl -instance "sigs" RdrSpecInstSig +insts RdrInstDecl +inst "sigs" RdrSpecInstSig 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, @@ -238,102 +220,85 @@ then checks that what it got is appropriate for that situation. (Those functions follow...) \begin{code} -sepDecls (RdrTyData a) - tys tysigs classes insts instsigs defaults binds iimps - = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) - -sepDecls (RdrTySynonym a) - tys tysigs classes insts instsigs defaults binds iimps - = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) +sepDecls (RdrTyDecl a) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps) + 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 - = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps) + tys tysigs classes insts instsigs defaults binds + = (tys,tysigs,classes,insts,instsigs,a:defaults,binds) -sepDecls a@(RdrTySig _ _ _ _) - tys tysigs classes insts instsigs defaults binds iimps - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) - -sepDecls (RdrIfaceImportDecl a) - tys tysigs classes insts instsigs defaults binds iimps - = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps) +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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + 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 - = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps) - -sepDecls (RdrAbstractTypeSig a) - tys tysigs classes insts instsigs defaults binds iimps - = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps) + 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 - = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps) + 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 - = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) + 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 - = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps) of { - (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) -> - sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps + 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) -> - ASSERT (null iimps) - (tys,tysigs,classes,insts,instsigs,defaults,binds) - } + = sepDecls binding [] [] [] [] [] [] [] sepDeclsForBinds binding - = case (sepDecls binding [] [] [] [] [] [] [] []) - of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) -> + = 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 defaults)) binds } @@ -342,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) @@ -351,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) -> - ASSERT ((null defaults) - && (null tysigs) - && (null instsigs)) - ASSERT (not (not_all_sigs sigs)) - (tys,classes,insts,sigs,iimps) - } - where - not_all_sigs sigs = not (all is_a_sig sigs) - - is_a_sig (RdrTySig _ _ _ _) = True - is_a_sig anything_else = False \end{code}