Differentiate typed and untyped splices and brackets in the abstract …

…syntax.

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 --------------------
 
@@ -839,7 +840,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

compiler/hsSyn/HsExpr.lhs

@@ -1181,6 +1181,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)
@@ -1189,8 +1190,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'
@@ -1208,6 +1210,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
@@ -1222,10 +1225,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}
 
 %************************************************************************

compiler/hsSyn/HsUtils.lhs

@@ -55,7 +55,7 @@ module HsUtils(
   emptyRecStmt, mkRecStmt, 
 
   -- Template Haskell
-  unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
+  unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsTExpSplice, mkHsQuasiQuote, unqualQuasiQuote,
 
   -- Flags
   noRebindableInfo, 
@@ -244,7 +244,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

compiler/parser/Parser.y.pp

@@ -1488,18 +1488,18 @@
                                         (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)) }
         | SIMPLEQUOTE  qcon     { LL $ HsBracket (VarBr True  (unLoc $2)) }
         | 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 $2 >>= \p ->
                                         return (LL $ HsBracket (PatBr p)) }

compiler/parser/RdrHsSyn.lhs

@@ -204,9 +204,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)

compiler/rename/RnSplice.lhs

@@ -51,7 +51,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)
@@ -64,7 +64,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}
@@ -158,4 +158,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}

compiler/typecheck/TcSplice.lhs

@@ -416,6 +416,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
@@ -430,7 +436,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 {
@@ -530,7 +536,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 {