\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.
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, preludeQual )
import PprStyle ( PprStyle(..) )
+import PrelMods ( pRELUDE )
import Pretty
import SrcLoc ( SrcLoc )
import Util ( nOfThem, pprError, panic )
wlkQid (U_aqual mod name)
= returnUgn (Qual mod name)
wlkQid (U_gid n name)
- = returnUgn (Unqual name)
+ = returnUgn (preludeQual name)
cvFlag :: U_long -> Bool
cvFlag 0 = False
%************************************************************************
\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!
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 ->
= 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 ->
U_ident nn -> -- simple identifier
wlkQid nn `thenUgn` \ n ->
returnUgn (
- if isConopRdr n
+ if isRdrLexConOrSpecial n
then ConPatIn n []
else VarPatIn n
)
(\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) ->
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)
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 ->
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}
%************************************************************************
-- 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}