[project @ 2002-05-27 15:28:07 by simonpj]

Allow infix type constructors

This commit adds infix type constructors (but not yet class constructors).
The documentation describes what should be the case.  Lots of tiresome
changes, but nothing exciting.

Allows infix type constructors everwhere a type can occur, and in a data
or type synonym decl.  E.g.

	data a :*: b = ....


You can give fixity decls for type constructors, but the fixity decl
applies both to the tycon and the corresponding data con.

1 files changed, 115 insertions, 10 deletions

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 1cb95da528..3f4ca43857 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -8,13 +8,14 @@ module RnEnv where		-- Export everything
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} RnHiFiles
+import {-# SOURCE #-} RnHiFiles( loadInterface )
 
 import FlattenInfo      ( namesNeededForFlattening )
 import HsSyn
-import RdrHsSyn		( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
+import RnHsSyn		( RenamedFixitySig )
+import RdrHsSyn		( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
 import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
-			  mkRdrUnqual, mkRdrQual, 
+			  mkRdrUnqual, mkRdrQual, setRdrNameOcc,
 			  lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
 			  unqualifyRdrName
 			)
@@ -24,18 +25,19 @@ import HscTypes		( Provenance(..), pprNameProvenance, hasBetterProv,
 			  AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), 
 			  ModIface(..), GhciMode(..),
 			  Deprecations(..), lookupDeprec,
-			  extendLocalRdrEnv
+			  extendLocalRdrEnv, lookupFixity
 			)
 import RnMonad
 import Name		( Name, 
 			  getSrcLoc, nameIsLocalOrFrom,
 			  mkInternalName, mkExternalName,
 			  mkIPName, nameOccName, nameModule_maybe,
-			  setNameModuleAndLoc
+			  setNameModuleAndLoc, nameModule
 			)
 import NameEnv
 import NameSet
-import OccName		( OccName, occNameUserString, occNameFlavour )
+import OccName		( OccName, occNameUserString, occNameFlavour, 
+			  isDataSymOcc, setOccNameSpace, tcName )
 import Module		( ModuleName, moduleName, mkVanillaModule, 
 			  mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
 import PrelNames	( mkUnboundName, 
@@ -54,10 +56,11 @@ import SrcLoc		( SrcLoc, noSrcLoc )
 import Outputable
 import ListSetOps	( removeDups, equivClasses )
 import Util		( sortLt )
-import BasicTypes	( mapIPName )
+import BasicTypes	( mapIPName, defaultFixity )
 import List		( nub )
 import UniqFM		( lookupWithDefaultUFM )
 import Maybe		( mapMaybe )
+import Maybes		( orElse, catMaybes )
 import CmdLineOpts
 import FastString	( FastString )
 \end{code}
@@ -240,9 +243,9 @@ lookupTopBndrRn rdr_name
 	Just name -> returnRn name
 	Nothing	  -> failWithRn (mkUnboundName rdr_name)
 		  	        (unknownNameErr rdr_name)
-  where
-    lookup_local mod global_env rdr_name
-      = case lookupRdrEnv global_env rdr_name of
+
+lookup_local mod global_env rdr_name
+  = case lookupRdrEnv global_env rdr_name of
 	  Nothing   -> Nothing
 	  Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of
 			 []     -> Nothing
@@ -420,6 +423,103 @@ lookupSysBinder rdr_name
 
 %*********************************************************
 %*							*
+\subsection{Looking up fixities}
+%*							*
+%*********************************************************
+
+lookupFixity is a bit strange.  
+
+* Nested local fixity decls are put in the local fixity env, which we
+  find with getFixtyEnv
+
+* Imported fixities are found in the HIT or PIT
+
+* Top-level fixity decls in this module may be for Names that are
+    either  Global	   (constructors, class operations)
+    or 	    Local/Exported (everything else)
+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+  We put them all in the local fixity environment
+
+\begin{code}
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
+  = getModuleRn				`thenRn` \ this_mod ->
+    if nameIsLocalOrFrom this_mod name
+    then	-- It's defined in this module
+	getFixityEnv			`thenRn` \ local_fix_env ->
+	returnRn (lookupLocalFixity local_fix_env name)
+
+    else	-- It's imported
+      -- For imported names, we have to get their fixities by doing a
+      -- loadHomeInterface, and consulting the Ifaces that comes back
+      -- from that, because the interface file for the Name might not
+      -- have been loaded yet.  Why not?  Suppose you import module A,
+      -- which exports a function 'f', thus;
+      --        module CurrentModule where
+      --	  import A( f )
+      -- 	module A( f ) where
+      --	  import B( f )
+      -- Then B isn't loaded right away (after all, it's possible that
+      -- nothing from B will be used).  When we come across a use of
+      -- 'f', we need to know its fixity, and it's then, and only
+      -- then, that we load B.hi.  That is what's happening here.
+        loadInterface doc name_mod ImportBySystem	`thenRn` \ iface ->
+	returnRn (lookupFixity (mi_fixities iface) name)
+  where
+    doc      = ptext SLIT("Checking fixity for") <+> ppr name
+    name_mod = moduleName (nameModule name)
+
+--------------------------------
+lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
+lookupLocalFixity env name
+  = case lookupNameEnv env name of 
+	Just (FixitySig _ fix _) -> fix
+	Nothing		  	 -> defaultFixity
+
+extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
+-- Used for nested fixity decls
+-- No need to worry about type constructors here,
+-- Should check for duplicates but we don't
+extendNestedFixityEnv fixes enclosed_scope
+  = getFixityEnv 	`thenRn` \ fix_env ->
+    let
+	new_fix_env = extendNameEnvList fix_env fixes
+    in
+    setFixityEnv new_fix_env enclosed_scope
+
+mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv
+mkTopFixityEnv gbl_env fix_sigs 
+  = getModuleRn				`thenRn` \ mod -> 
+    let
+		-- GHC extension: look up both the tycon and data con 
+		-- for con-like things
+		-- If neither are in scope, report an error; otherwise
+		-- add both to the fixity env
+	go fix_env (FixitySig rdr_name fixity loc)
+	  = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of
+		  [] -> addErrRn (unknownNameErr rdr_name)	`thenRn_`
+	 	        returnRn fix_env
+		  ns -> foldlRn add fix_env ns
+
+	  where
+	    add fix_env name 
+	      = case lookupNameEnv fix_env name of
+	          Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')	`thenRn_`
+					       returnRn fix_env
+		  Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc))
+	    
+	    rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc]
+		      | otherwise 	     = [rdr_name]
+
+	    occ 	= rdrNameOcc rdr_name
+	    rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName)
+    in
+    foldlRn go emptyLocalFixityEnv fix_sigs
+\end{code}
+
+
+%*********************************************************
+%*							*
 \subsection{Implicit free vars and sugar names}
 %*							*
 %*********************************************************
@@ -1080,5 +1180,10 @@ warnDeprec name txt
     addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> 
 		     quotes (ppr name) <+> text "is deprecated:", 
 		     nest 4 (ppr txt) ])
+
+dupFixityDecl rdr_name loc1 loc2
+  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+	  ptext SLIT("at ") <+> ppr loc1,
+	  ptext SLIT("and") <+> ppr loc2]
 \end{code}