[project @ 1996-06-26 10:26:00 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 74cf5d8..17f2a49 100644 (file)
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -6,11 +6,10 @@
 \begin{code}
 #include "HsVersions.h"
 
-module ReadPrefix (
-       rdModule
-    )  where
+module ReadPrefix ( rdModule )  where
 
-import Ubiq
+IMP_Ubiq()
+IMPORT_1_3(IO(hPutStr, stderr))
 
 import UgenAll         -- all Yacc parser gumpff...
 import PrefixSyn       -- and various syntaxen.
@@ -19,13 +18,11 @@ import HsPragmas    ( noDataPragmas, noClassPragmas, noInstancePragmas )
 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(..), 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 )
@@ -65,12 +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)
+  = returnUgn (preludeQual name)
 
 cvFlag :: U_long -> Bool
 cvFlag 0 = False
@@ -84,13 +78,21 @@ cvFlag 1 = True
 %************************************************************************
 
 \begin{code}
-rdModule :: MainIO (Module,            -- this module's name
-                   RdrNameHsModule)    -- the main goods
+#if __GLASGOW_HASKELL__ >= 200
+# define PACK_STR packCString
+# define CCALL_THEN `GHCbase.ccallThen`
+#else
+# define PACK_STR _packCString
+# define CCALL_THEN `thenPrimIO`
+#endif
+
+rdModule :: IO (Module,                    -- this module's name
+               RdrNameHsModule)    -- the main goods
 
 rdModule
-  = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
+  = _ccall_ hspmain CCALL_THEN \ pt -> -- call the Yacc parser!
     let
-       srcfile  = _packCString ``input_filename'' -- What A Great Hack! (TM)
+       srcfile  = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
     in
     initUgn              $
     rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
@@ -98,12 +100,12 @@ rdModule
 
     setSrcFileUgn srcfile $
     setSrcModUgn  modname $
-    mkSrcLocUgn srcline          $                         \ src_loc   ->
+    mkSrcLocUgn srcline          $                \ src_loc    ->
 
-    wlkMaybe rdEntities                 hexplist `thenUgn` \ exports   ->
-    wlkList  rdImport            himplist `thenUgn` \ imports  ->
-    wlkList  rdFixOp            hfixlist `thenUgn` \ fixities  ->
-    wlkBinding                  hmodlist `thenUgn` \ binding   ->
+    wlkMaybe rdEntities        hexplist `thenUgn` \ exports    ->
+    wlkList  rdImport   himplist `thenUgn` \ imports   ->
+    wlkList  rdFixOp   hfixlist `thenUgn` \ fixities   ->
+    wlkBinding         hmodlist `thenUgn` \ binding    ->
 
     case sepDeclsForTopBinds binding of
     (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
@@ -308,7 +310,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 ->
@@ -360,7 +366,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 ->
@@ -380,7 +392,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
        )
@@ -398,8 +410,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) ->
@@ -454,7 +466,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)
@@ -468,7 +480,11 @@ wlkLiteral ulit
   where
     as_char s     = _HEAD_ s
     as_integer s  = readInteger (_UNPK_ s)
+#if __GLASGOW_HASKELL__ >= 200
+    as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
+#else
     as_rational s = _readRational (_UNPK_ s) -- non-std
+#endif
     as_string s   = s
 \end{code}
 
@@ -560,12 +576,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{-from here-} modname uprags noInstancePragmas src_loc))
 
        -- "default" declaration
       U_dbind dbindts srcline ->
@@ -790,9 +803,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}
 
 %************************************************************************