[project @ 2003-12-16 16:24:55 by simonpj]

--------------------
	Towards type splices
	--------------------

Starts the move to supporting type splices, by making
HsExpr.HsSplice a separate type of its own, and adding
HsSpliceTy constructor to HsType.

5 files changed, 40 insertions, 36 deletions

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index fb32abeead..59d0dd180f 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -12,12 +12,12 @@ free variables.
 \begin{code}
 module RnExpr (
 	rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
-	checkPrecMatch
+	checkPrecMatch, checkTH
    ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups ) 
+import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice ) 
 
 -- 	RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
 --	RnBinds	 imports RnExpr.rnMatch, etc
@@ -29,7 +29,7 @@ import TcRnMonad
 import RnEnv
 import OccName		( plusOccEnv )
 import RnNames		( importsFromLocalDecls )
-import RnTypes		( rnHsTypeFVs, rnLPat, litFVs, rnOverLit, rnPatsAndThen,
+import RnTypes		( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
 			  dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
 			  checkTupSize )
 import CmdLineOpts	( DynFlag(..) )
@@ -177,8 +177,8 @@ rnExpr (HsIPVar v)
     returnM (HsIPVar name, emptyFVs)
 
 rnExpr (HsLit lit) 
-  = litFVs lit		`thenM` \ fvs -> 
-    returnM (HsLit lit, fvs)
+  = rnLit lit		`thenM_`
+    returnM (HsLit lit, emptyFVs)
 
 rnExpr (HsOverLit lit) 
   = rnOverLit lit		`thenM` \ (lit', fvs) ->
@@ -227,12 +227,9 @@ rnExpr e@(HsBracket br_body)
     rnBracket br_body		`thenM` \ (body', fvs_e) ->
     returnM (HsBracket body', fvs_e)
 
-rnExpr e@(HsSplice n splice)
-  = checkTH e "splice"		`thenM_`
-    getSrcSpanM 		`thenM` \ loc ->
-    newLocalsRn [L loc n]	`thenM` \ [n'] ->
-    rnLExpr splice 		`thenM` \ (splice', fvs_e) ->
-    returnM (HsSplice n' splice', fvs_e)
+rnExpr e@(HsSpliceE splice)
+  = rnSplice splice 		`thenM` \ (splice', fvs) ->
+    returnM (HsSpliceE splice', fvs)
 
 rnExpr section@(SectionL expr op)
   = rnLExpr expr	 	`thenM` \ (expr', fvs_expr) ->
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 5e30960c1d..5d316727ca 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -56,6 +56,7 @@ extractHsTyNames ty
     get (HsParTy ty)           = getl ty
     get (HsNumTy n)            = emptyNameSet
     get (HsTyVar tv)	       = unitNameSet tv
+    get (HsSpliceTy _)         = emptyNameSet	-- Type splices mention no type variables
     get (HsKindSig ty k)       = getl ty
     get (HsForAllTy _ tvs 
 		    ctxt ty)   = (extractHsCtxtTyNames ctxt
diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6
index 4c0ac50a25..e4d5e3bdcc 100644
--- a/ghc/compiler/rename/RnSource.hi-boot-6
+++ b/ghc/compiler/rename/RnSource.hi-boot-6
@@ -9,5 +9,8 @@ rnBindGroups :: [HsBinds.HsBindGroup RdrName.RdrName]
 	-> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ;
 
 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
-	   -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name)
+	   -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) ;
+
+rnSplice :: HsExpr.HsSplice RdrName.RdrName 
+	 -> TcRnTypes.RnM (HsExpr.HsSplice Name.Name, NameSet.FreeVars)
 
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index c70e7f6f95..43e644ee62 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -7,7 +7,7 @@
 module RnSource ( 
 	rnSrcDecls, addTcgDUs, 
 	rnTyClDecls, checkModDeprec,
-	rnBindGroups, rnBindGroupsAndThen
+	rnBindGroups, rnBindGroupsAndThen, rnSplice
     ) where
 
 #include "HsVersions.h"
@@ -16,7 +16,7 @@ import HsSyn
 import RdrName		( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
 import RdrHsSyn		( extractGenericPatTyVars )
 import RnHsSyn
-import RnExpr		( rnLExpr )
+import RnExpr		( rnLExpr, checkTH )
 import RnTypes		( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext )
 import RnBinds		( rnTopBinds, rnBinds, rnMethodBinds, 
 			  rnBindsAndThen, renameSigs, checkSigs )
@@ -677,3 +677,19 @@ rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 rnHsTyvar doc tyvar = lookupOccRn tyvar
 \end{code}
 
+
+%*********************************************************
+%*							*
+		Splices
+%*							*
+%*********************************************************
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+  = checkTH expr "splice"	`thenM_`
+    getSrcSpanM 		`thenM` \ loc ->
+    newLocalsRn [L loc n]	`thenM` \ [n'] ->
+    rnLExpr expr 		`thenM` \ (expr', fvs) ->
+    returnM (HsSplice n' expr', fvs)
+\end{code}
\ No newline at end of file
diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs
index e41c7752a5..c5c541b55a 100644
--- a/ghc/compiler/rename/RnTypes.lhs
+++ b/ghc/compiler/rename/RnTypes.lhs
@@ -7,7 +7,7 @@
 module RnTypes ( rnHsType, rnLHsType, rnContext,
 		 rnHsSigType, rnHsTypeFVs,
 		 rnLPat, rnPat, rnPatsAndThen,		-- Here because it's not part 
-		 rnOverLit, litFVs,		-- of any mutual recursion	
+		 rnLit, rnOverLit, 			-- of any mutual recursion	
 		 precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
   ) where
 
@@ -338,12 +338,9 @@ rnPat (SigPatIn pat ty)
   where
     doc = text "In a pattern type-signature"
     
-rnPat (LitPat s@(HsString _)) 
-  = returnM (LitPat s, unitFV eqStringName)
-
 rnPat (LitPat lit) 
-  = litFVs lit		`thenM` \ fvs ->
-    returnM (LitPat lit, fvs) 
+  = rnLit lit 	`thenM_` 
+    returnM (LitPat lit, emptyFVs) 
 
 rnPat (NPatIn lit mb_neg) 
   = rnOverLit lit			`thenM` \ (lit', fvs1) ->
@@ -484,22 +481,9 @@ that the types and classes they involve
 are made available.
 
 \begin{code}
-litFVs (HsChar c)
-   = checkErr (inCharRange c) (bogusCharError c) `thenM_`
-     returnM (unitFV charTyCon_name)
-
-litFVs (HsCharPrim c)         = returnM (unitFV (getName charPrimTyCon))
-litFVs (HsString s)           = returnM (mkFVs [listTyCon_name, charTyCon_name])
-litFVs (HsStringPrim s)       = returnM (unitFV (getName addrPrimTyCon))
-litFVs (HsInt i)	      = returnM (unitFV (getName intTyCon))
-litFVs (HsIntPrim i)          = returnM (unitFV (getName intPrimTyCon))
-litFVs (HsFloatPrim f)        = returnM (unitFV (getName floatPrimTyCon))
-litFVs (HsDoublePrim d)       = returnM (unitFV (getName doublePrimTyCon))
-litFVs lit		      = pprPanic "RnExpr.litFVs" (ppr lit)
-					-- HsInteger and HsRat only appear 
-					-- in post-typechecker translations
-bogusCharError c
-  = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
+rnLit :: HsLit -> RnM ()
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit other	 = returnM ()
 
 rnOverLit (HsIntegral i _)
   = lookupSyntaxName fromIntegerName	`thenM` \ (from_integer_name, fvs) ->
@@ -557,6 +541,9 @@ forAllWarn doc ty (L loc tyvar)
 		   doc
                 )
 
+bogusCharError c
+  = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
+
 precParseErr op1 op2 
   = hang (ptext SLIT("precedence parsing error"))
       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),