[project @ 1996-06-05 06:44:31 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 1ed9bd2..88ddda0 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.
@@ -20,11 +18,11 @@ import RdrHsSyn
 import PrefixToHs
 
 import CmdLineOpts     ( opt_CompilingPrelude )
-import ErrUtils                ( addErrLoc )
+import ErrUtils                ( addErrLoc, ghcExit )
 import FiniteMap       ( elemFM, FiniteMap )
-import MainMonad       ( writeMn, exitMn, MainIO(..) )
-import Name            ( RdrName(..), isConopRdr )
+import Name            ( RdrName(..), isRdrLexConOrSpecial )
 import PprStyle                ( PprStyle(..) )
+import PrelMods                ( fromPrelude, pRELUDE )
 import Pretty
 import SrcLoc          ( SrcLoc )
 import Util            ( nOfThem, pprError, panic )
@@ -64,6 +62,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)
@@ -80,8 +81,8 @@ cvFlag 1 = True
 %************************************************************************
 
 \begin{code}
-rdModule :: MainIO (Module,            -- this module's name
-                   RdrNameHsModule)    -- the main goods
+rdModule :: IO (Module,                    -- this module's name
+               RdrNameHsModule)    -- the main goods
 
 rdModule
   = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
@@ -304,7 +305,14 @@ wlkExpr expr
 
       U_negate nexp ->                 -- prefix negation
        wlkExpr nexp    `thenUgn` \ expr ->
-       returnUgn (NegApp expr)
+       -- this is a hack
+       let
+           neg = SLIT("negate")
+           rdr = if opt_CompilingPrelude
+                 then Unqual neg
+                 else Qual   pRELUDE neg
+       in
+       returnUgn (NegApp expr (HsVar rdr))
 
       U_llist llist -> -- explicit list
        wlkList rdExpr llist `thenUgn` \ exprs ->
@@ -356,7 +364,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 ->
@@ -376,7 +390,7 @@ wlkPat pat
       U_ident nn ->                    -- simple identifier
        wlkQid nn       `thenUgn` \ n ->
        returnUgn (
-         if isConopRdr n
+         if isRdrLexConOrSpecial n
          then ConPatIn n []
          else VarPatIn n
        )
@@ -394,8 +408,8 @@ wlkPat pat
                                     (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
                     msg = ppShow 100 (err PprForUser)
                 in
-                ioToUgnM  (writeMn stderr msg) `thenUgn` \ _ ->
-                ioToUgnM  (exitMn 1)           `thenUgn` \ _ ->
+                ioToUgnM  (hPutStr stderr msg) `thenUgn` \ _ ->
+                ioToUgnM  (ghcExit 1)          `thenUgn` \ _ ->
                 returnUgn (error "ReadPrefix")
 
        )                       `thenUgn` \ (n, arg_pats) ->
@@ -450,7 +464,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)
@@ -786,9 +800,10 @@ rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
 
 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 
-wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged   ty)
-wlkBangType uty                  = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
-
+wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
+                           returnUgn (Banged   (HsPreForAllTy [] ty))
+wlkBangType uty                  = wlkMonoType uty `thenUgn` \ ty ->
+                           returnUgn (Unbanged (HsPreForAllTy [] ty))
 \end{code}
 
 %************************************************************************
@@ -895,10 +910,9 @@ rdEntity pt
                                -- with specified constrs/methods
        wlkQid  x               `thenUgn` \ thing ->
        wlkList rdQid ns        `thenUgn` \ names -> 
-       returnUgn (IEThingAll thing)
-       -- returnUgn (IEThingWith thing names)
+       returnUgn (IEThingWith thing names)
 
-      U_entmod mod -> -- everything provided by a module
+      U_entmod mod ->          -- everything provided unqualified by a module
        returnUgn (IEModuleContents mod)
 \end{code}