X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FReadPrefix.lhs;h=9353e8740fa39bbc2124e284eb6ea390bb72f11d;hb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;hp=0fbd15be9cdbbcdf0e4aa0b58939d99a6d5fb3f9;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 0fbd15b..9353e87 100644
--- 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,13 +17,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 +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
@@ -84,8 +77,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!
@@ -308,7 +301,11 @@ wlkExpr expr
 
       U_negate nexp ->	 		-- prefix negation
 	wlkExpr nexp	`thenUgn` \ expr ->
-	returnUgn (NegApp expr)
+	-- 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 +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 ->
@@ -380,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
 	)
@@ -398,8 +401,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 +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)
@@ -560,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 ->
@@ -790,9 +790,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}
 
 %************************************************************************
@@ -899,10 +900,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}