Template Haskell: allow type splices

At last!  Trac #1476 and #3177

This patch extends Template Haskell by allowing splices in
types.  For example

  f :: Int -> $(burble 3)

A type splice should work anywhere a type is expected.  This feature
has been long requested, and quite a while ago I'd re-engineered the
type checker to make it easier, but had never got around to finishing
the job.  With luck, this does it.

There's a ToDo in the HsSpliceTy case of RnTypes.rnHsType, where I
am not dealing properly with the used variables; but that's awaiting
the refactoring of the way we report unused names.

9 files changed, 122 insertions, 92 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a8eb1f7515..f9976b4985 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1078,6 +1078,10 @@ atype :: { LHsType RdrName }
 	| '[:' ctype ':]'		{ LL $ HsPArrTy  $2 }
 	| '(' ctype ')'		        { LL $ HsParTy   $2 }
 	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 (unLoc $4) }
+	| '$(' exp ')'	      		{ LL $ HsSpliceTy (mkHsSplice $2 ) }
+	| TH_ID_SPLICE	      		{ LL $ HsSpliceTy (mkHsSplice 
+					         (L1 $ HsVar (mkUnqual varName 
+							        (getTH_ID_SPLICE $1)))) } -- $x
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index f86a04e6c0..32d4c4c379 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -20,14 +20,14 @@ module RnExpr (
 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
 #endif 	/* GHCI */
 
-import RnSource  ( rnSrcDecls, rnSplice, checkTH ) 
+import RnSource  ( rnSrcDecls )
 import RnBinds   ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
                    rnMatchGroup, makeMiniFixityEnv) 
 import HsSyn
 import TcRnMonad
 import TcEnv		( thRnBrack )
 import RnEnv
-import RnTypes		( rnHsTypeFVs, 
+import RnTypes		( rnHsTypeFVs, rnSplice, checkTH,
 			  mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
 import RnPat
 import DynFlags		( DynFlag(..) )
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index d47125743d..442d4652d6 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -5,9 +5,7 @@
 
 \begin{code}
 module RnSource ( 
-	rnSrcDecls, addTcgDUs, 
-	rnTyClDecls, 
-	rnSplice, checkTH
+	rnSrcDecls, addTcgDUs, rnTyClDecls 
     ) where
 
 #include "HsVersions.h"
@@ -15,8 +13,7 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
-import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, 
-			  globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
+import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
 import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
@@ -40,7 +37,6 @@ import Class		( FunDep )
 import Name		( Name, nameOccName )
 import NameSet
 import NameEnv
-import OccName 
 import Outputable
 import Bag
 import FastString
@@ -809,6 +805,7 @@ badGadtStupidTheta _
 	  ptext (sLit "(You can put a context on each contructor, though.)")]
 \end{code}
 
+
 %*********************************************************
 %*							*
 \subsection{Support code for type/data declarations}
@@ -1099,55 +1096,3 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar
 \end{code}
 
 
-%*********************************************************
-%*							*
-		Splices
-%*							*
-%*********************************************************
-
-Note [Splices]
-~~~~~~~~~~~~~~
-Consider
-	f = ...
-	h = ...$(thing "f")...
-
-The splice can expand into literally anything, so when we do dependency
-analysis we must assume that it might mention 'f'.  So we simply treat
-all locally-defined names as mentioned by any splice.  This is terribly
-brutal, but I don't see what else to do.  For example, it'll mean
-that every locally-defined thing will appear to be used, so no unused-binding
-warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
-and that will crash the type checker because 'f' isn't in scope.
-
-Currently, I'm not treating a splice as also mentioning every import,
-which is a bit inconsistent -- but there are a lot of them.  We might
-thereby get some bogus unused-import warnings, but we won't crash the
-type checker.  Not very satisfactory really.
-
-\begin{code}
-rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice (HsSplice n expr)
-  = do	{ checkTH expr "splice"
-	; loc  <- getSrcSpanM
-	; [n'] <- newLocalsRn [L loc n]
-	; (expr', fvs) <- rnLExpr expr
-
-	-- Ugh!  See Note [Splices] above
-	; lcl_rdr <- getLocalRdrEnv
-	; gbl_rdr <- getGlobalRdrEnv
-	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
-						    isLocalGRE gre]
-	      lcl_names = mkNameSet (occEnvElts lcl_rdr)
-
-	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
-
-checkTH :: Outputable a => a -> String -> RnM ()
-#ifdef GHCI 
-checkTH _ _ = return ()	-- OK
-#else
-checkTH e what 	-- Raise an error in a stage-1 compiler
-  = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
-	          ptext (sLit "illegal in a stage-1 compiler"),
-	          nest 2 (ppr e)])
-#endif   
-\end{code}
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 4f9672bb8c..61731e8726 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -11,9 +11,14 @@ module RnTypes (
 
 	-- Precence related stuff
 	mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
-	checkPrecMatch, checkSectionPrec
+	checkPrecMatch, checkSectionPrec,
+
+	-- Splice related stuff
+	rnSplice, checkTH
   ) where
 
+import {-# SOURCE #-} RnExpr( rnLExpr )
+
 import DynFlags
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
@@ -173,8 +178,9 @@ rnHsType doc (HsPredTy pred) = do
     pred' <- rnPred doc pred
     return (HsPredTy pred')
 
-rnHsType _ (HsSpliceTy _) =
-    failWith (ptext (sLit "Type splices are not yet implemented"))
+rnHsType _ (HsSpliceTy sp)
+  = do { (sp', _fvs) <- rnSplice sp	-- ToDo: deal with fvs
+       ; return (HsSpliceTy sp') }
 
 rnHsType doc (HsDocTy ty haddock_doc) = do
     ty' <- rnLHsType doc ty
@@ -559,3 +565,56 @@ opTyErr op ty@(HsOpTy ty1 _ _)
     forall_head _other		     = False
 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
 \end{code}
+
+%*********************************************************
+%*							*
+		Splices
+%*							*
+%*********************************************************
+
+Note [Splices]
+~~~~~~~~~~~~~~
+Consider
+	f = ...
+	h = ...$(thing "f")...
+
+The splice can expand into literally anything, so when we do dependency
+analysis we must assume that it might mention 'f'.  So we simply treat
+all locally-defined names as mentioned by any splice.  This is terribly
+brutal, but I don't see what else to do.  For example, it'll mean
+that every locally-defined thing will appear to be used, so no unused-binding
+warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
+and that will crash the type checker because 'f' isn't in scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them.  We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker.  Not very satisfactory really.
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+  = do	{ checkTH expr "splice"
+	; loc  <- getSrcSpanM
+	; [n'] <- newLocalsRn [L loc n]
+	; (expr', fvs) <- rnLExpr expr
+
+	-- Ugh!  See Note [Splices] above
+	; lcl_rdr <- getLocalRdrEnv
+	; gbl_rdr <- getGlobalRdrEnv
+	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
+						    isLocalGRE gre]
+	      lcl_names = mkNameSet (occEnvElts lcl_rdr)
+
+	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+
+checkTH :: Outputable a => a -> String -> RnM ()
+#ifdef GHCI 
+checkTH _ _ = return ()	-- OK
+#else
+checkTH e what 	-- Raise an error in a stage-1 compiler
+  = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
+	          ptext (sLit "illegal in a stage-1 compiler"),
+	          nest 2 (ppr e)])
+#endif   
+\end{code}
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index b7cbc1ec75..c8c0efcde4 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -6,7 +6,7 @@
 
 \begin{code}
 module TcHsType (
-	tcHsSigType, tcHsDeriv, 
+	tcHsSigType, tcHsSigTypeNC, tcHsDeriv, 
 	tcHsInstHead, tcHsQuantifiedType,
 	UserTypeCtxt(..), 
 
@@ -25,6 +25,10 @@ module TcHsType (
 
 #include "HsVersions.h"
 
+#ifdef GHCI 	/* Only if bootstrapped */
+import {-# SOURCE #-}	TcSplice( kcSpliceType )
+#endif
+
 import HsSyn
 import RnHsSyn
 import TcRnMonad
@@ -136,14 +140,19 @@ the TyCon being defined.
 %************************************************************************
 
 \begin{code}
-tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
+tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
   -- Do kind checking, and hoist for-alls to the top
   -- NB: it's important that the foralls that come from the top-level
   --	 HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
 tcHsSigType ctxt hs_ty 
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
-    do	{ kinded_ty <- kcTypeType hs_ty
+    tcHsSigTypeNC ctxt hs_ty
+
+tcHsSigTypeNC ctxt hs_ty
+  = do	{ (kinded_ty, _kind) <- kc_lhs_type hs_ty
+    	  -- The kind is checked by checkValidType, and isn't necessarily
+	  -- of kind * in a Template Haskell quote eg [t| Maybe |]
 	; ty <- tcHsKindedType kinded_ty
 	; checkValidType ctxt ty	
 	; return ty }
@@ -399,8 +408,11 @@ kc_hs_type (HsBangTy b ty) = do
     (ty', kind) <- kc_lhs_type ty
     return (HsBangTy b ty', kind)
 
-kc_hs_type ty@(HsSpliceTy _)
-  = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#ifdef GHCI	/* Only if bootstrapped */
+kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+#else
+kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#endif
 
 -- remove the doc nodes here, no need to worry about the location since
 -- its the same for a doc node and it's child type node
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 525ba0d29a..08a3cbd6ee 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1059,11 +1059,13 @@ checkValidType ctxt ty = do
 
 		 ForSigCtxt _	-> gen_rank 1
 		 SpecInstCtxt   -> gen_rank 1
+		 ThBrackCtxt    -> gen_rank 1
 
 	actual_kind = typeKind ty
 
 	kind_ok = case ctxt of
 			TySynCtxt _  -> True -- Any kind will do
+			ThBrackCtxt  -> True -- Any kind will do
 			ResSigCtxt   -> isSubOpenTypeKind actual_kind
 			ExprSigCtxt  -> isSubOpenTypeKind actual_kind
 			GenPatCtxt   -> isLiftedTypeKind actual_kind
@@ -1073,6 +1075,7 @@ checkValidType ctxt ty = do
 	ubx_tup = case ctxt of
 	              TySynCtxt _ | unboxed -> UT_Ok
 	              ExprSigCtxt | unboxed -> UT_Ok
+	              ThBrackCtxt | unboxed -> UT_Ok
 	              _                     -> UT_NotOk
 
 	-- Check that the thing has kind Type, and is lifted if necessary
@@ -1223,13 +1226,14 @@ check_arg_type :: Rank -> Type -> TcM ()
 
 check_arg_type rank ty 
   = do	{ impred <- doptM Opt_ImpredicativeTypes
-	; let rank' = if impred then ArbitraryRank  -- Arg of tycon can have arby rank, regardless
-	              else case rank of 	    -- Predictive => must be monotype
-	      	        MustBeMonoType -> MustBeMonoType 
-			_	       -> TyConArgMonoType
+	; let rank' = case rank of 	    -- Predictive => must be monotype
+	      	        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
+			_other | impred    -> ArbitraryRank
+			       | otherwise -> TyConArgMonoType
 			-- Make sure that MustBeMonoType is propagated, 
 			-- so that we don't suggest -XImpredicativeTypes in
 			--    (Ord (forall a.a)) => a -> a
+			-- and so that if it Must be a monotype, we check that it is!
 
 	; check_type rank' UT_NotOk ty
 	; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 650c0b40da..7b92b810d7 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -13,7 +13,7 @@ TcSplice: Template Haskell splices
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
+module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  lookupThName_maybe,
                  runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
 
@@ -213,30 +213,31 @@ Desugared:	f = do { s7 <- g Int 3
 		       ; return (ConE "Data.Maybe.Just" s7) }
 
 \begin{code}
-tcBracket brack res_ty = do
-   level <- getStage
-   case bracketOK level of {
-	Nothing         -> failWithTc (illegalBracket level) ;
-	Just next_level -> do
+tcBracket brack res_ty 
+  = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
+                   2 (ppr brack)) $
+    do { level <- getStage
+       ; case bracketOK level of {
+ 	   Nothing         -> failWithTc (illegalBracket level) ;
+	   Just next_level -> do {
 
    	-- Typecheck expr to make sure it is valid,
 	-- but throw away the results.  We'll type check
 	-- it again when we actually use it.
-    recordThUse
-    pending_splices <- newMutVar []
-    lie_var <- getLIEVar
+          recordThUse
+       ; pending_splices <- newMutVar []
+       ; lie_var <- getLIEVar
 
-    (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
-                               (getLIE (tc_bracket next_level brack))
-    tcSimplifyBracket lie
+       ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
+                                    (getLIE (tc_bracket next_level brack))
+       ; tcSimplifyBracket lie
 
 	-- Make the expected type have the right shape
-    boxyUnify meta_ty res_ty
+       ; boxyUnify meta_ty res_ty
 
 	-- Return the original expression, not the type-decorated one
-    pendings <- readMutVar pending_splices
-    return (noLoc (HsBracketOut brack pendings))
-    }
+       ; pendings <- readMutVar pending_splices
+       ; return (noLoc (HsBracketOut brack pendings)) }}}
 
 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
 tc_bracket use_lvl (VarBr name) 	-- Note [Quoting names]
@@ -256,12 +257,12 @@ tc_bracket use_lvl (VarBr name) 	-- Note [Quoting names]
 
 tc_bracket _ (ExpBr expr) 
   = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
-	; tcMonoExpr expr any_ty
+	; tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
 	; tcMetaTy expQTyConName }
 	-- Result type is Expr (= Q Exp)
 
 tc_bracket _ (TypBr typ) 
-  = do	{ tcHsSigType ExprSigCtxt typ
+  = do	{ tcHsSigTypeNC ThBrackCtxt typ
 	; tcMetaTy typeQTyConName }
 	-- Result type is Type (= Q Typ)
 
diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index 9b133566ea..11606dad73 100644
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -1,11 +1,11 @@
 \begin{code}
 module TcSplice where
 import HsSyn	( HsSplice, HsBracket, HsQuasiQuote,
-                  HsExpr, LHsExpr, LPat, LHsDecl )
+                  HsExpr, HsType, LHsExpr, LPat, LHsDecl )
 import Name	( Name )
 import RdrName	( RdrName )
 import TcRnTypes( TcM, TcId )
-import TcType	( BoxyRhoType )
+import TcType	( BoxyRhoType, TcKind )
 import Annotations ( Annotation, CoreAnnTarget )
 import qualified Language.Haskell.TH as TH
 
@@ -13,6 +13,9 @@ tcSpliceExpr :: HsSplice Name
 	     -> BoxyRhoType
 	     -> TcM (HsExpr TcId)
 
+kcSpliceType :: HsSplice Name
+	     -> TcM (HsType Name, TcKind)
+
 tcBracket :: HsBracket Name 
 	  -> BoxyRhoType
 	  -> TcM (LHsExpr TcId)
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 2d45334671..738f1cd009 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -353,6 +353,7 @@ data UserTypeCtxt
   | ForSigCtxt Name	-- Foreign inport or export signature
   | DefaultDeclCtxt	-- Types in a default declaration
   | SpecInstCtxt	-- SPECIALISE instance pragma
+  | ThBrackCtxt		-- Template Haskell type brackets [t| ... |]
 
 -- Notes re TySynCtxt
 -- We allow type synonyms that aren't types; e.g.  type List = []
@@ -410,6 +411,7 @@ pprUserTypeCtxt ExprSigCtxt     = ptext (sLit "an expression type signature")
 pprUserTypeCtxt (ConArgCtxt c)  = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
 pprUserTypeCtxt (TySynCtxt c)   = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
 pprUserTypeCtxt GenPatCtxt      = ptext (sLit "the type pattern of a generic definition")
+pprUserTypeCtxt ThBrackCtxt     = ptext (sLit "a Template Haskell quotation [t|...|]")
 pprUserTypeCtxt LamPatSigCtxt   = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt BindPatSigCtxt  = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt ResSigCtxt      = ptext (sLit "a result type signature")