[project @ 1996-06-11 13:18:54 by partain]

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

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index cb8be08..9353e87 100644 (file)
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -6,11 +6,9 @@
 \begin{code}
 #include "HsVersions.h"
 
-module ReadPrefix (
-       rdModule
-    )  where
+module ReadPrefix ( rdModule )  where
 
-import Ubiq
+IMP_Ubiq()
 
 import UgenAll         -- all Yacc parser gumpff...
 import PrefixSyn       -- and various syntaxen.
@@ -19,12 +17,11 @@ import HsPragmas    ( noDataPragmas, noClassPragmas, noInstancePragmas )
 import RdrHsSyn
 import PrefixToHs
 
-import CmdLineOpts     ( opt_CompilingPrelude )
 import ErrUtils                ( addErrLoc, ghcExit )
 import FiniteMap       ( elemFM, FiniteMap )
-import Name            ( RdrName(..), isRdrLexCon )
+import Name            ( RdrName(..), isRdrLexConOrSpecial, preludeQual )
 import PprStyle                ( PprStyle(..) )
-import PrelMods                ( fromPrelude )
+import PrelMods                ( pRELUDE )
 import Pretty
 import SrcLoc          ( SrcLoc )
 import Util            ( nOfThem, pprError, panic )
@@ -64,12 +61,9 @@ wlkQid       :: U_qid -> UgnM RdrName
 wlkQid (U_noqual name)
   = returnUgn (Unqual name)
 wlkQid (U_aqual  mod name)
-  | fromPrelude mod
-  = returnUgn (Unqual name)
-  | otherwise
   = returnUgn (Qual mod name)
 wlkQid (U_gid n name)
-  = returnUgn (Unqual name)
+  = returnUgn (preludeQual name)
 
 cvFlag :: U_long -> Bool
 cvFlag 0 = False
@@ -307,7 +301,11 @@ wlkExpr expr
 
       U_negate nexp ->                 -- prefix negation
        wlkExpr nexp    `thenUgn` \ expr ->
-       returnUgn (NegApp expr (Unqual SLIT("negate")) )
+       -- this is a hack
+       let
+           rdr = preludeQual SLIT("negate")
+       in
+       returnUgn (NegApp expr (HsVar rdr))
 
       U_llist llist -> -- explicit list
        wlkList rdExpr llist `thenUgn` \ exprs ->
@@ -359,7 +357,13 @@ wlkPat pat
   = case pat of
       U_par ppat ->                    -- parenthesised pattern
        wlkPat ppat     `thenUgn` \ pat ->
-       returnUgn (ParPatIn pat)
+       -- tidy things up a little:
+       returnUgn (
+       case pat of
+         VarPatIn _ -> pat
+         WildPatIn  -> pat
+         other      -> ParPatIn pat
+       )
 
       U_as avar as_pat ->              -- "as" pattern
        wlkQid avar     `thenUgn` \ var ->
@@ -379,7 +383,7 @@ wlkPat pat
       U_ident nn ->                    -- simple identifier
        wlkQid nn       `thenUgn` \ n ->
        returnUgn (
-         if isRdrLexCon n
+         if isRdrLexConOrSpecial n
          then ConPatIn n []
          else VarPatIn n
        )
@@ -453,7 +457,7 @@ wlkLiteral :: U_literal -> UgnM HsLit
 wlkLiteral ulit
   = returnUgn (
     case ulit of
-      U_integer    s -> HsInt         (as_integer  s)
+      U_integer    s -> HsInt       (as_integer  s)
       U_floatr     s -> HsFrac       (as_rational s)
       U_intprim    s -> HsIntPrim    (as_integer  s)
       U_doubleprim s -> HsDoublePrim (as_rational s)
@@ -559,12 +563,9 @@ wlkBinding binding
            binds     = cvMonoBinds sf bs
            uprags    = concat (map cvInstDeclSig ss)
            ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
-           maybe_mod = if opt_CompilingPrelude
-                       then Nothing
-                       else Just modname
        in
        returnUgn (RdrInstDecl
-          (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
+          (InstDecl clas ctxt_inst_ty binds True modname uprags noInstancePragmas src_loc))
 
        -- "default" declaration
       U_dbind dbindts srcline ->