[project @ 2000-05-25 12:41:14 by simonpj]

~~~~~~~~~~~~
		Apr/May 2000
		~~~~~~~~~~~~

This is a pretty big commit!  It adds stuff I've been working on
over the last month or so.  DO NOT MERGE IT WITH 4.07!

Interface file formats have changed a little; you'll need
to make clean before remaking.

						Simon PJ

Recompilation checking
~~~~~~~~~~~~~~~~~~~~~~
Substantial improvement in recompilation checking.  The version management
is now entirely internal to GHC.  ghc-iface.lprl is dead!

The trick is to generate the new interface file in two steps:
  - first convert Types etc to HsTypes etc, and thereby
	build a new ParsedIface
  - then compare against the parsed (but not renamed) version of the old
	interface file
Doing this meant adding code to convert *to* HsSyn things, and to
compare HsSyn things for equality.  That is the main tedious bit.

Another improvement is that we now track version info for
fixities and rules, which was missing before.


Interface file reading
~~~~~~~~~~~~~~~~~~~~~~
Make interface files reading more robust.
  * If the old interface file is unreadable, don't fail. [bug fix]

  * If the old interface file mentions interfaces
    that are unreadable, don't fail. [bug fix]

  * When we can't find the interface file,
    print the directories we are looking in.  [feature]


Type signatures
~~~~~~~~~~~~~~~
  * New flag -ddump-types to print type signatures


Type pruning
~~~~~~~~~~~~
When importing
	data T = T1 A | T2 B | T3 C
it seems excessive to import the types A, B, C as well, unless
the constructors T1, T2 etc are used.  A,B,C might be more types,
and importing them may mean reading more interfaces, and so on.
 So the idea is that the renamer will just import the decl
	data T
unless one of the constructors is used.  This turns out to be quite
easy to implement.  The downside is that we must make sure the
constructors are always available if they are really needed, so
I regard this as an experimental feature.


Elimininate ThinAir names
~~~~~~~~~~~~~~~~~~~~~~~~~
Eliminate ThinAir.lhs and all its works.  It was always a hack, and now
the desugarer carries around an environment I think we can nuke ThinAir
altogether.

As part of this, I had to move all the Prelude RdrName defns from PrelInfo
to PrelMods --- so I renamed PrelMods as PrelNames.

I also had to move the builtinRules so that they are injected by the renamer
(rather than appearing out of the blue in SimplCore).  This is if anything simpler.

Miscellaneous
~~~~~~~~~~~~~
* Tidy up the data types involved in Rules

* Eliminate RnEnv.better_provenance; use Name.hasBetterProv instead

* Add Unique.hasKey :: Uniquable a => a -> Unique -> Bool
  It's useful in a lot of places

* Fix a bug in interface file parsing for __U[!]

4 files changed, 68 insertions, 66 deletions

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 0a247e0d03..4283c328dc 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -38,11 +38,11 @@ import List             ( isSuffixOf )
 
 import IdInfo		( InlinePragInfo(..), CprInfo(..) )
 import Name		( isLowerISO, isUpperISO )
-import PrelMods		( mkTupNameStr, mkUbxTupNameStr )
+import PrelNames	( mkTupNameStr )
 import CmdLineOpts	( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
 import Demand		( Demand(..) {- instance Read -} )
 import UniqFM           ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes	( NewOrData(..) )
+import BasicTypes	( NewOrData(..), Boxity(..) )
 import SrcLoc		( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
 			  replaceSrcLine, mkSrcLoc )
 
@@ -1018,7 +1018,7 @@ lex_tuple cont mod buf back_off =
    go n buf =
     case currentChar# buf of
       ','# -> go (n+1) (stepOn buf)
-      ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
+      ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
       _    -> back_off
 
 lex_ubx_tuple cont mod buf back_off =
@@ -1028,7 +1028,7 @@ lex_ubx_tuple cont mod buf back_off =
     case currentChar# buf of
       ','# -> go (n+1) (stepOn buf)
       '#'# -> case lookAhead# buf 1# of
-		')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
+		')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
 				 (stepOnBy# buf 2#)
 	        _    -> back_off
       _    -> back_off
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 93aa715702..3e7cafe184 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -18,7 +18,6 @@ module ParseUtil (
 	, checkPrec 		-- String -> P String
 	, checkContext		-- HsType -> P HsContext
 	, checkInstType		-- HsType -> P HsType
-	, checkAssertion	-- HsType -> P HsAsst
 	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
 	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
 	, checkPattern		-- HsExp -> P HsPat
@@ -54,11 +53,12 @@ import SrcLoc
 import RdrHsSyn
 import RdrName
 import CallConv
-import PrelMods 	( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
+import PrelNames 	( pRELUDE_Name, mkTupNameStr )
 import OccName  	( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
 import CmdLineOpts 	( opt_NoImplicitPrelude )
 import StringBuffer 	( lexemeToString )
 import FastString	( unpackFS )
+import BasicTypes	( Boxity(..) )
 import ErrUtils
 import UniqFM		( UniqFM, listToUFM, lookupUFM )
 import Outputable
@@ -86,9 +86,9 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType]
 
 splitForConApp  t ts = split t ts
  where
-	split (MonoTyApp t u) ts = split t (Unbanged u : ts)
+	split (HsAppTy t u) ts = split t (Unbanged u : ts)
 
-	split (MonoTyVar t)   ts  = returnP (con, ts)
+	split (HsTyVar t)   ts  = returnP (con, ts)
 	   where t_occ = rdrNameOcc t
 		 con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
 
@@ -117,17 +117,17 @@ checkInstType :: RdrNameHsType -> P RdrNameHsType
 checkInstType t 
   = case t of
 	HsForAllTy tvs ctxt ty ->
-		checkAssertion ty [] `thenP` \(c,ts)->
-	      	returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
+		checkDictTy ty [] `thenP` \ dict_ty ->
+	      	returnP (HsForAllTy tvs ctxt dict_ty)
 
-	ty ->   checkAssertion ty [] `thenP` \(c,ts)->
-	      	returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
+	ty ->   checkDictTy ty [] `thenP` \ dict_ty->
+	      	returnP (HsForAllTy Nothing [] dict_ty)
 
 checkContext :: RdrNameHsType -> P RdrNameContext
-checkContext (MonoTupleTy ts True) 
+checkContext (HsTupleTy _ ts) 
   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
     returnP ps
-checkContext (MonoTyVar t) -- empty contexts are allowed
+checkContext (HsTyVar t) -- empty contexts are allowed
   | t == unitTyCon_RDR = returnP []
 checkContext t 
   = checkPred t [] `thenP` \p ->
@@ -135,18 +135,17 @@ checkContext t
 
 checkPred :: RdrNameHsType -> [RdrNameHsType] 
 	-> P (HsPred RdrName)
-checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
+checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
   	= returnP (HsPClass t args)
-checkPred (MonoTyApp l r) args = checkPred l (r:args)
-checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
+checkPred (HsAppTy l r) args = checkPred l (r:args)
+checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
 checkPred _ _ = parseError "Illegal class assertion"
 
-checkAssertion :: RdrNameHsType -> [RdrNameHsType] 
-	-> P (HsClassAssertion RdrName)
-checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
-  	= returnP (t,args)
-checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
-checkAssertion _ _ = parseError "Illegal class assertion"
+checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
+checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
+  	= returnP (mkHsDictTy t args)
+checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
+checkDictTy _ _ = parseError "Illegal class assertion"
 
 checkDataHeader :: RdrNameHsType 
 	-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
@@ -158,9 +157,9 @@ checkDataHeader t =
    returnP ([],c,map UserTyVar ts)
 
 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
-checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a 
+checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
    = checkSimple l (a:xs)
-checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
+checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
 
 ---------------------------------------------------------------------------
@@ -431,25 +430,25 @@ funTyCon_RDR
 	| otherwise		= mkPreludeQual tcName pRELUDE_Name funName
 
 tupleCon_RDR arity
-  | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkTupNameStr arity))
+  | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkTupNameStr Boxed arity))
   | otherwise		  = mkPreludeQual dataName pRELUDE_Name
-				(snd (mkTupNameStr arity))
+				(snd (mkTupNameStr Boxed arity))
 
 tupleTyCon_RDR arity
-  | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkTupNameStr arity))
+  | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkTupNameStr Boxed arity))
   | otherwise		  = mkPreludeQual tcName pRELUDE_Name
-				(snd (mkTupNameStr arity))
+				(snd (mkTupNameStr Boxed arity))
 
 
 ubxTupleCon_RDR arity
-  | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkUbxTupNameStr arity))
+  | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkTupNameStr Unboxed arity))
   | otherwise		  = mkPreludeQual dataName pRELUDE_Name 
-				(snd (mkUbxTupNameStr arity))
+				(snd (mkTupNameStr Unboxed arity))
 
 ubxTupleTyCon_RDR arity
-  | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkUbxTupNameStr arity))
+  | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkTupNameStr Unboxed arity))
   | otherwise		  = mkPreludeQual tcName pRELUDE_Name 
-				(snd (mkUbxTupNameStr arity))
+				(snd (mkTupNameStr Unboxed arity))
 
 unitName = SLIT("()")
 funName  = SLIT("(->)")
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index d5521bfdf0..51bd67a901 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $
+$Id: Parser.y,v 1.31 2000/05/25 12:41:17 simonpj Exp $
 
 Haskell grammar.
 
@@ -13,18 +13,19 @@ module Parser ( parse ) where
 
 import HsSyn
 import HsPragmas
+import HsTypes		( mkHsTupCon )
 
 import RdrHsSyn
 import Lex
 import ParseUtil
 import RdrName
-import PrelMods		( mAIN_Name )
-import OccName		( varName, ipName, dataName, tcClsName, tvName )
+import PrelInfo		( mAIN_Name )
+import OccName		( varName, ipName, tcName, dataName, tcClsName, tvName )
 import SrcLoc		( SrcLoc )
 import Module
 import CallConv
 import CmdLineOpts	( opt_SccProfilingOn )
-import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
 
 import GlaExts
@@ -332,13 +333,13 @@ topdecl :: { RdrBinding }
 	| srcloc 'data' ctype '=' constrs deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
 		   returnP (RdrHsDecl (TyClD
-		      (TyData DataType cs c ts (reverse $5) $6
+		      (TyData DataType cs c ts (reverse $5) (length $5) $6
 			NoDataPragmas $1))) }
 
 	| srcloc 'newtype' ctype '=' newconstr deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
 		   returnP (RdrHsDecl (TyClD
-		      (TyData NewType cs c ts [$5] $6
+		      (TyData NewType cs c ts [$5] 1 $6
 			NoDataPragmas $1))) }
 
 	| srcloc 'class' ctype fds where
@@ -372,7 +373,9 @@ topdecl :: { RdrBinding }
 		{ RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
 					defaultCallConv $1)) }
 
-      	| decl		{ $1 }
+	| '{-# DEPRECATED' deprecations '#-}'	 	{ $2 }
+	| '{-# RULES' rules '#-}'		 	{ $2 }
+      	| decl						{ $1 }
 
 decls 	:: { [RdrBinding] }
 	: decls ';' decl		{ $3 : $1 }
@@ -390,8 +393,6 @@ decl 	:: { RdrBinding }
 		    (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
 	| '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
 		{ RdrSig (SpecInstSig $4 $2) }
-	| '{-# RULES' rules '#-}' 	{ $2 }
-	| '{-# DEPRECATED' deprecations '#-}' 	{ $2 }
 
 opt_phase :: { Maybe Int }
           : INTEGER                     { Just (fromInteger $1) }
@@ -428,7 +429,7 @@ rules	:: { RdrBinding }
 
 rule  	:: { RdrBinding }
 	: STRING rule_forall fexp '=' srcloc exp
-	     { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
+	     { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) }
 
 rule_forall :: { [RdrNameRuleBndr] }
 	: 'forall' rule_var_list '.'            { $2 }
@@ -454,7 +455,8 @@ deprecations :: { RdrBinding }
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 deprecation :: { RdrBinding }
 	: srcloc exportlist STRING
-		{ foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] }
+		{ foldr RdrAndBindings RdrNullBind 
+			[ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
 
 -----------------------------------------------------------------------------
 -- Foreign import/export
@@ -508,20 +510,20 @@ ctype	:: { RdrNameHsType }
 	| type				{ $1 }
 
 type :: { RdrNameHsType }
-	: btype '->' type		{ MonoFunTy $1 $3 }
-	| ipvar '::' type		{ MonoIParamTy $1 $3 }
+	: btype '->' type		{ HsFunTy $1 $3 }
+	| ipvar '::' type		{ mkHsIParamTy $1 $3 }
 	| btype				{ $1 }
 
 btype :: { RdrNameHsType }
-	: btype atype			{ MonoTyApp $1 $2 }
+	: btype atype			{ HsAppTy $1 $2 }
 	| atype				{ $1 }
 
 atype :: { RdrNameHsType }
-	: gtycon			{ MonoTyVar $1 }
-	| tyvar				{ MonoTyVar $1 }
-	| '(' type ',' types ')'	{ MonoTupleTy ($2 : reverse $4) True }
-	| '(#' types '#)'		{ MonoTupleTy (reverse $2) False }
-	| '[' type ']'			{ MonoListTy $2 }
+	: gtycon			{ HsTyVar $1 }
+	| tyvar				{ HsTyVar $1 }
+	| '(' type ',' types ')'	{ HsTupleTy (mkHsTupCon tcName Boxed  ($2:$4)) ($2 : reverse $4) }
+	| '(#' types '#)'		{ HsTupleTy (mkHsTupCon tcName Unboxed     $2) (reverse $2)	 }
+	| '[' type ']'			{ HsListTy $2 }
 	| '(' ctype ')'			{ $2 }
 
 gtycon 	:: { RdrName }
@@ -737,8 +739,8 @@ aexp1	:: { RdrNameHsExpr }
 	| gcon				{ HsVar $1 }
   	| literal			{ HsLit $1 }
 	| '(' exp ')'			{ HsPar $2 }
-	| '(' exp ',' texps ')'		{ ExplicitTuple ($2 : reverse $4) True }
-	| '(#' texps '#)'		{ ExplicitTuple (reverse $2) False }
+	| '(' exp ',' texps ')'		{ ExplicitTuple ($2 : reverse $4) Boxed}
+	| '(#' texps '#)'		{ ExplicitTuple (reverse $2)      Unboxed }
 	| '[' list ']'                  { $2 }
 	| '(' infixexp qop ')'		{ SectionL $2 $3  }
 	| '(' qopm infixexp ')'		{ SectionR $2 $3 }
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 4455fdba1e..0d0a01f660 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -38,6 +38,7 @@ module RdrHsSyn (
 	RdrNameRuleBndr,
 	RdrNameDeprecation,
 	RdrNameHsRecordBinds,
+	RdrNameFixitySig,
 
 	RdrBinding(..),
 	RdrMatch(..),
@@ -106,13 +107,14 @@ type RdrNameMatch		= Match			RdrName RdrNamePat
 type RdrNameMonoBinds		= MonoBinds		RdrName RdrNamePat
 type RdrNamePat			= InPat			RdrName
 type RdrNameHsType		= HsType		RdrName
-type RdrNameHsTyVar		= HsTyVar		RdrName
+type RdrNameHsTyVar		= HsTyVarBndr		RdrName
 type RdrNameSig			= Sig			RdrName
 type RdrNameStmt		= Stmt			RdrName RdrNamePat
 type RdrNameTyClDecl		= TyClDecl		RdrName RdrNamePat
 type RdrNameRuleBndr            = RuleBndr              RdrName
 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
-type RdrNameDeprecation         = Deprecation           RdrName
+type RdrNameDeprecation         = DeprecDecl            RdrName
+type RdrNameFixitySig		= FixitySig		RdrName
 
 type RdrNameHsRecordBinds	= HsRecordBinds		RdrName RdrNamePat
 
@@ -159,15 +161,14 @@ extract_pred (HsPIParam n ty) acc	= extract_ty ty acc
 
 extract_tys tys acc = foldr extract_ty acc tys
 
-extract_ty (MonoTyApp ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty)              acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _)          acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoIParamTy n ty)		acc = extract_ty ty acc
-extract_ty (MonoDictTy cls tys)         acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty)           acc = extract_ty ty acc
-extract_ty (MonoUsgForAllTy uv ty)      acc = extract_ty ty acc
-extract_ty (MonoTyVar tv)               acc = tv : acc
+extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsListTy ty)              acc = extract_ty ty acc
+extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
+extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsPredTy p)		      acc = extract_pred p acc
+extract_ty (HsUsgTy usg ty)           acc = extract_ty ty acc
+extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
+extract_ty (HsTyVar tv)               acc = tv : acc
 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                 acc = acc ++
@@ -293,7 +294,7 @@ cvValSig      sig = sig
 cvInstDeclSig sig = sig
 
 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
-							(panic "cvClassOpSig:dm_present")
+							False
 							poly_ty src_loc
 cvClassOpSig sig 		       = sig
 \end{code}