From: simonpj@microsoft.com Date: Wed, 27 May 2009 18:12:42 +0000 (+0000) Subject: Template Haskell: allow type splices X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=389cca214f33a29646e08d57e3dca862140007b2 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. --- diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a8eb1f7..f9976b4 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 f86a04e..32d4c4c 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 d471257..442d465 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 4f9672b..61731e8 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 b7cbc1e..c8c0efc 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 525ba0d..08a3cbd 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 650c0b4..7b92b81 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 9b13356..11606da 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 2d45334..738f1cd 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")