[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / compiler / reader / PrefixToHs.lhs

diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index 3536af8..ee4c224 100644 (file)
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -1,13 +1,11 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
 
 Support routines for reading prefix-form from the Lex/Yacc parser.
 
 \begin{code}
-#include "HsVersions.h"
-
 module PrefixToHs (
        cvValSig,
        cvClassOpSig,
@@ -16,16 +14,18 @@ module PrefixToHs (
        cvBinds,
        cvMonoBindsAndSigs,
        cvMatches,
-       cvOtherDecls
+       cvOtherDecls,
+       cvForeignDecls -- HACK
+
     ) where
 
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
 
 import PrefixSyn       -- and various syntaxen.
 import HsSyn
 import RdrHsSyn
-import HsPragmas       ( noGenPragmas, noClassOpPragmas )
 
+import BasicTypes      ( RecFlag(..) )
 import SrcLoc          ( mkSrcLoc )
 import Util            ( mapAndUnzip, panic, assertPanic )
 \end{code}
@@ -38,21 +38,19 @@ import Util         ( mapAndUnzip, panic, assertPanic )
 
 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 src_loc)
-  = [ Sig v poly_ty src_loc | v <- vars ]
+cvValSig      sig = sig
 
-cvClassOpSig (RdrTySig vars poly_ty src_loc)
-  = [ ClassOpSig v Nothing poly_ty src_loc | v <- vars ]
+cvInstDeclSig sig = sig
 
-cvInstDeclSig (RdrSpecValSig        sigs) = sigs
-cvInstDeclSig (RdrInlineValSig      sig)  = [ sig ]
-cvInstDeclSig (RdrDeforestSig      sig)  = [ sig ]
-cvInstDeclSig (RdrMagicUnfoldingSig sig)  = [ sig ]
+cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig sig                      = sig
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
@@ -67,7 +65,7 @@ analyser.
 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
 cvBinds sf sig_cvtr binding
   = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
-    MonoBind mbs sigs recursive
+    MonoBind mbs sigs Recursive
     }
 \end{code}
 
@@ -91,13 +89,8 @@ cvMonoBindsAndSigs sf sig_cvtr fb
     mangle_bind acc (RdrAndBindings fb1 fb2)
       = mangle_bind (mangle_bind acc fb1) fb2
 
-    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)
-    mangle_bind (b_acc, s_acc) (RdrInlineValSig      sig) = (b_acc, sig : s_acc)
-    mangle_bind (b_acc, s_acc) (RdrDeforestSig       sig) = (b_acc, sig : s_acc)
-    mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
+    mangle_bind (b_acc, s_acc) (RdrSig sig)
+      = (b_acc, sig_cvtr sig : s_acc)
 
     mangle_bind (b_acc, s_acc)
                (RdrPatternBinding lousy_srcline [patbinding])
@@ -126,13 +119,14 @@ cvMonoBindsAndSigs sf sig_cvtr fb
        }
 
     mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
+       -- Ignore class decls, instance decls etc
 \end{code}
 
 \begin{code}
 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
 
 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
-  = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding)
+  = (pat, unguardedRHS expr (mkSrcLoc 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)
@@ -177,11 +171,13 @@ cvMatch sf is_case rdr_match
   where
     (pat, binding, guarded_exprs)
       = case rdr_match of
-         RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
+         RdrMatch_NoGuard ln b c expr    d -> (c,d, unguardedRHS expr (mkSrcLoc sf ln))
          RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 
 cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
-cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
+cvGRHS sf sl (g, e) = GRHS (g ++ [ExprStmt e locn]) locn
+                   where
+                     locn = mkSrcLoc sf sl
 \end{code}
 
 %************************************************************************
@@ -203,4 +199,13 @@ cvOtherDecls b
     go acc (RdrInstDecl d)       = InstD d : acc 
     go acc (RdrDefaultDecl d)     = DefD d  : acc
     go acc other                 = acc
+       -- Ignore value bindings
+
+cvForeignDecls :: RdrBinding -> [RdrNameHsDecl]
+cvForeignDecls b = go [] b
+ where
+    go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+    go acc (RdrForeignDecl d)     = ForD d  : acc
+    go acc other                 = acc
+ 
 \end{code}