X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FReadPrefix.lhs;h=4b185e175629ca1025a3b842022921bec9450e9b;hb=1fa984a9b60e333a20ef31a42719ad611dddab0e;hp=2fb30288433a7059dd2319e84043674fd34ba01b;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 2fb3028..4b185e1 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -24,22 +24,19 @@ import HsSyn
 import HsTypes		( HsTyVar(..) )
 import HsPragmas	( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
 import RdrHsSyn         
+import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
 import PrefixToHs
 
+import CmdLineOpts      ( opt_PprUserLength )
 import ErrUtils		( addErrLoc, ghcExit )
 import FiniteMap	( elemFM, FiniteMap )
 import Name		( OccName(..), SYN_IE(Module) )
 import Lex		( isLexConId )
-import PprStyle		( PprStyle(..) )
+import Outputable	( Outputable(..), PprStyle(..) )
 import PrelMods
 import Pretty
 import SrcLoc		( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
 import Util		( nOfThem, pprError, panic )
-
-#if __GLASGOW_HASKELL__ >= 202
-import Outputable       ( Outputable(..) )
-#endif
-
 \end{code}
 
 %************************************************************************
@@ -81,7 +78,7 @@ wlkQid	:: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
 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))
+  = returnUgn (Qual mod (mk_occ_name name) HiFile)
 
 	-- I don't understand this one!  It is what shows up when we meet (), [], or (,,,).
 wlkQid mk_occ_name (U_gid n name)
@@ -319,7 +316,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 ->
@@ -377,6 +374,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
@@ -433,7 +439,7 @@ wlkPat pat
 		 let
 		     err = addErrLoc loc "Illegal pattern `application'"
 			             (\sty -> hsep (map (ppr sty) (lpat:lpats)))
-		     msg = show (err PprForUser)
+		     msg = show (err (PprForUser opt_PprUserLength))
 		 in
 #if __GLASGOW_HASKELL__ == 201
 	         ioToUgnM  (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
@@ -515,8 +521,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
@@ -777,7 +786,7 @@ mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
 
 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
 mk_class_assertion other
-  = pprError "ERROR: malformed type context: " (ppr PprForUser other)
+  = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
     -- regrettably, the parser does let some junk past
     -- e.g., f :: Num {-nothing-} => a -> ...
 \end{code}
@@ -904,11 +913,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
@@ -916,6 +925,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}