Commit 389cca21 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.

parent 97a8fe87
......@@ -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)) }
......
......@@ -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(..) )
......
......@@ -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}
......@@ -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}
......@@ -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
......
......@@ -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) }
......
......@@ -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)
......
\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)
......
......@@ -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")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment