diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 58ece822f1f6..69d4b8b4f44c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -82,6 +82,7 @@ dsBracket brack splices do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } {- -------------- Examples -------------------- @@ -875,7 +876,7 @@ repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) repSplice :: HsSplice Name -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsSplice n _) +repSplice (HsSplice _ n _) = do { mb_val <- dsLookupMetaEnv n ; case mb_val of Just (Splice e) -> do { e' <- dsExpr e diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index ccbfc63a3112..7f683c1d4827 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1306,6 +1306,7 @@ pprQuals quals = interpp'SP quals \begin{code} data HsSplice id = HsSplice -- $z or $(f 4) + Bool -- True if typed, False if untyped id -- The id is just a unique name to (LHsExpr id) -- identify this splice point deriving (Data, Typeable) @@ -1314,8 +1315,9 @@ instance OutputableBndr id => Outputable (HsSplice id) where ppr = pprSplice pprSplice :: OutputableBndr id => HsSplice id -> SDoc -pprSplice (HsSplice n e) - = char '$' <> ifPprDebug (brackets (ppr n)) <> eDoc +pprSplice (HsSplice isTyped n e) + = (if isTyped then ptext (sLit "$$") else char '$') + <> ifPprDebug (brackets (ppr n)) <> eDoc where -- We use pprLExpr to match pprParendExpr: -- Using pprLExpr makes sure that we go 'deeper' @@ -1333,6 +1335,7 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | TypBr (LHsType id) -- [t| type |] | VarBr Bool id -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) + | TExpBr (LHsExpr id) -- [|| expr ||] deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsBracket id) where @@ -1347,10 +1350,14 @@ pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) pprHsBracket (VarBr True n) = char '\'' <> ppr n pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n +pprHsBracket (TExpBr e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> pp_body <+> ptext (sLit "|]") + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 1fa949653e0a..657b3d7f4a70 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -54,7 +54,7 @@ module HsUtils( emptyRecStmt, mkRecStmt, -- Template Haskell - unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote, + unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsTExpSplice, mkHsQuasiQuote, unqualQuasiQuote, -- Flags noRebindableInfo, @@ -247,7 +247,10 @@ mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName -mkHsSplice e = HsSplice unqualSplice e +mkHsSplice e = HsSplice False unqualSplice e + +mkHsTExpSplice :: LHsExpr RdrName -> HsSplice RdrName +mkHsTExpSplice e = HsSplice True unqualSplice e mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 285ded696bd7..c4c3dd22bc5f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1541,10 +1541,10 @@ (L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1)))) } | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } - | TH_ID_TY_SPLICE { L1 $ HsSpliceE (mkHsSplice + | TH_ID_TY_SPLICE { L1 $ HsSpliceE (mkHsTExpSplice (L1 $ HsVar (mkUnqual varName (getTH_ID_TY_SPLICE $1)))) } - | '$$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } + | '$$(' exp ')' { LL $ HsSpliceE (mkHsTExpSplice $2) } | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) } @@ -1552,7 +1552,7 @@ | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr False (unLoc $2)) } | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr False (unLoc $2)) } | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } - | '[||' exp '||]' { LL $ HsBracket (ExpBr $2) } + | '[||' exp '||]' { LL $ HsBracket (TExpBr $2) } | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> return (LL $ HsBracket (PatBr p)) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 3695daef5855..87962d3ce196 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -219,9 +219,9 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName -- but if she wrote, say, -- f x then behave as if she'd written $(f x) -- ie a SpliceD -mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq -mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit) -mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) +mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq +mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ _ expr))) = SpliceD (SpliceDecl expr Explicit) +mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index afa16821e49e..a73d91ea3a4d 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -52,7 +52,7 @@ type checker. Not very satisfactory really. \begin{code} rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -rnSplice (HsSplice n expr) +rnSplice (HsSplice isTyped n expr) = do { checkTH expr "splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc n) @@ -65,7 +65,7 @@ rnSplice (HsSplice n expr) isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + ; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } \end{code} \begin{code} @@ -159,4 +159,7 @@ rn_bracket (DecBrL decls) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rn_bracket (DecBrG _) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket (TExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr e', fvs) } \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 2561bd967c5f..e65ce900acfa 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -422,6 +422,12 @@ tc_bracket _ (PatBr pat) tc_bracket _ (DecBrL _) = panic "tc_bracket: Unexpected DecBrL" +tc_bracket _ (TExpBr expr) + = do { any_ty <- newFlexiTyVarTy openTypeKind + ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that + ; tcMetaTy expQTyConName } + -- Result type is ExpQ (= Q Exp) + quotedNameStageErr :: HsBracket Name -> SDoc quotedNameStageErr br = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br @@ -436,7 +442,7 @@ quotedNameStageErr br %************************************************************************ \begin{code} -tcSpliceExpr (HsSplice name expr) res_ty +tcSpliceExpr (HsSplice _ name expr) res_ty = setSrcSpan (getLoc expr) $ do { stage <- getStage ; case stage of { @@ -536,7 +542,7 @@ We don't want the type checker to see these bogus unbound variables. Very like splicing an expression, but we don't yet share code. \begin{code} -tcSpliceType (HsSplice name hs_expr) _ +tcSpliceType (HsSplice _ name hs_expr) _ = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of {