[project @ 1997-10-07 14:51:49 by simonm]

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

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 4c7c829..6f72409 100644 (file)
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -24,7 +24,7 @@ import HsSyn
 import HsTypes         ( HsTyVar(..) )
 import HsPragmas       ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
 import RdrHsSyn         
-import BasicTypes      ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes      ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
 import PrefixToHs
 
 import CmdLineOpts      ( opt_PprUserLength )
@@ -33,7 +33,7 @@ import FiniteMap      ( elemFM, FiniteMap )
 import Name            ( OccName(..), SYN_IE(Module) )
 import Lex             ( isLexConId )
 import Outputable      ( Outputable(..), PprStyle(..) )
-import PrelMods
+import PrelMods                ( pRELUDE )
 import Pretty
 import SrcLoc          ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
 import Util            ( nOfThem, pprError, panic )
@@ -75,14 +75,22 @@ wlkEntId = wlkQid (\occ -> if isLexConId occ
                           else VarOcc occ)
 
 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
+
+-- There are three kinds of qid:
+--     qualified name (noqual)         A.x
+--     unqualified name (aqual)        x
+--     special name (gid)              [], (), ->, (,,,)
+-- The special names always mean "Prelude.whatever"; that's why
+-- they are distinct.  So if you write "()", it's just as if  you
+-- had written "Prelude.()".  NB: The (qualified) prelude is always in scope,
+-- so the renamer will find it.
+
 wlkQid mk_occ_name (U_noqual name)
   = returnUgn (Unqual (mk_occ_name name))
 wlkQid mk_occ_name (U_aqual  mod name)
-  = returnUgn (Qual mod (mk_occ_name name))
-
-       -- I don't understand this one!  It is what shows up when we meet (), [], or (,,,).
+  = returnUgn (Qual mod (mk_occ_name name) HiFile)
 wlkQid mk_occ_name (U_gid n name)
-  = returnUgn (Unqual (mk_occ_name name))
+  = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
 
 rdTCId  pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
@@ -316,7 +324,7 @@ wlkExpr expr
       U_record con rbinds -> -- record construction
        wlkDataId  con          `thenUgn` \ rcon     ->
        wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
-       returnUgn (RecordCon (HsVar rcon) recbinds)
+       returnUgn (RecordCon rcon recbinds)
 
       U_rupdate updexp updbinds -> -- record update
        wlkExpr updexp           `thenUgn` \ aexp ->
@@ -374,6 +382,15 @@ wlkQuals cquals
                      binds = cvBinds sf cvValSig bs
                  in
                  returnUgn (LetStmt binds)
+               U_let letvdefs letvexpr -> 
+                   wlkBinding letvdefs `thenUgn` \ binding ->
+                   wlkExpr    letvexpr `thenUgn` \ expr    ->
+                   getSrcLocUgn        `thenUgn` \ loc ->
+                   getSrcFileUgn       `thenUgn` \ sf      ->
+                   let
+                    binds = cvBinds sf cvValSig binding
+                   in
+                   returnUgn (GuardStmt (HsLet binds expr) loc)
 \end{code}
 
 Patterns: just bear in mind that lists of patterns are represented as
@@ -512,8 +529,11 @@ wlkLiteral ulit
     as_integer s  = readInteger (_UNPK_ s)
 #if __GLASGOW_HASKELL__ == 201
     as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
-#elif __GLASGOW_HASKELL__ >= 202
-    as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a } -- ToDo, use non-std readRational__
+#elif __GLASGOW_HASKELL__ == 202
+    as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
+#elif __GLASGOW_HASKELL__ >= 203
+    as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__ 
+                                             -- to handle rationals with leading '-'
 #else
     as_rational s = _readRational (_UNPK_ s) -- non-std
 #endif
@@ -671,12 +691,6 @@ wlk_sig_thing (U_inline_uprag ivar srcline)
     wlkVarId   ivar            `thenUgn` \ var     ->
     returnUgn (RdrInlineValSig (InlineSig var src_loc))
 
-       -- "deforest me" user-pragma
-wlk_sig_thing (U_deforest_uprag ivar srcline)
-  = mkSrcLocUgn srcline                        $ \ src_loc ->
-    wlkVarId   ivar            `thenUgn` \ var     ->
-    returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-
        -- "magic" unfolding user-pragma
 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
   = mkSrcLocUgn srcline                        $ \ src_loc ->
@@ -901,11 +915,11 @@ rdImport :: ParseTree
         -> UgnM RdrNameImportDecl
 
 rdImport pt
-  = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
+  = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
     mkSrcLocUgn srcline                                $ \ src_loc      ->
     wlkMaybe rdU_stringId ias          `thenUgn` \ maybe_as    ->
     wlkMaybe rd_spec ispec             `thenUgn` \ maybe_spec  ->
-    returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
+    returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
   where
     rd_spec pt = rdU_either pt                 `thenUgn` \ spec ->
       case spec of
@@ -913,6 +927,9 @@ rdImport pt
                      returnUgn (False, ents)
        U_right pt -> rdEntities pt     `thenUgn` \ ents ->
                      returnUgn (True, ents)
+
+cvIfaceFlavour 0 = HiFile      -- No pragam
+cvIfaceFlavour 1 = HiBootFile  -- {-# SOURCE #-}
 \end{code}
 
 \begin{code}