Add support for typed brackets and splices.

1 files changed, 82 insertions, 91 deletions

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f5c2cc12ef..e652a24869 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -47,7 +47,6 @@ import Name
 import NameEnv
 import NameSet
 import PrelNames
-import HscTypes
 import OccName
 import Hooks
 import Var
@@ -329,8 +328,8 @@ runAnnotation   _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
 tcBracket brack ps res_ty
   = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
                    2 (ppr brack)) $
-    do {        -- Check for nested brackets
-         cur_stage <- getStage
+    do { cur_stage <- getStage
+         -- Check for nested brackets
        ; case cur_stage of
            { Splice True  -> checkTc (isTypedBracket brack) illegalUntypedBracket
            ; Splice False -> checkTc (not (isTypedBracket brack)) illegalTypedBracket
@@ -338,48 +337,56 @@ tcBracket brack ps res_ty
            ; Brack {}     -> failWithTc illegalBracket
            }
 
-        -- Brackets are desugared to code that mentions the TH package
+       -- Brackets are desugared to code that mentions the TH package
        ; recordThUse
 
-        -- Typecheck expr to make sure it is valid,
-        -- but throw away the results.  We'll type check
-        -- it again when we actually use it.
+       -- Typecheck expr to make sure it is valid,
+       -- but throw away the results.  We'll type check
+       -- it again when we actually use it.
        ; ps_ref <- newMutVar []
        ; lie_var <- getConstraintVar
-       ; meta_ty <-
-           if isTypedBracket brack
-           then do { let brack_stage = Brack True cur_stage ps_ref lie_var
-                      -- We want to check that there aren't any constraints that
-                      -- can't be satisfied (e.g. Show Foo, where Foo has no Show
-                      -- instance), but we aren't otherwise interested in the
-                      -- results. Nor do we care about ambiguous dictionaries etc.
-                      -- We will type check this bracket again at its usage site.
-                      --
-                      -- We build a single implication constraint with a BracketSkol;
-                      -- that in turn tells simplifyTop to report only definite
-                      -- errors
-                   ; ((_binds1, meta_ty), lie) <- captureConstraints $
-                                      newImplication BracketSkol [] [] $
-                                      setStage brack_stage $
-                                      tc_bracket brack
-
-                      -- It's best to simplify the constraint now, even though in
-                      -- principle some later unification might be useful for it,
-                      -- because we don't want these essentially-junk TH implication
-                      -- contraints floating around nested inside other constraints
-                      -- See for example Trac #4949
-                   ; _binds2 <- simplifyTop lie
-                   ; return meta_ty }
-           else do { let brack_stage = Brack False cur_stage ps_ref lie_var
-                   ; setStage brack_stage $
-                         mapM_ tcPendingSplice ps
-                   ; tc_bracket brack
-                   }
-
-        -- Return the original expression, not the type-decorated one
-       ; ps' <- readMutVar ps_ref
-       ; co <- unifyType meta_ty res_ty
-       ; return (mkHsWrapCo co (HsBracketOut brack ps')) }
+       ; let brack_stage = Brack (isTypedBracket brack) cur_stage ps_ref lie_var
+       ; setStage brack_stage $
+         tc_bracket brack ps_ref
+       }
+  where
+    tcUntypedBracket :: HsBracket Name -> TcM TcType
+    tcUntypedBracket (VarBr _ _) = -- Result type is Var (not Q-monadic)
+                                   tcMetaTy nameTyConName
+    tcUntypedBracket (ExpBr _)   = -- Result type is ExpQ (= Q Exp)
+                                   tcMetaTy expQTyConName
+    tcUntypedBracket (TypBr _)   = -- Result type is Type (= Q Typ)
+                                   tcMetaTy typeQTyConName
+    tcUntypedBracket (DecBrG _)  = -- Result type is Q [Dec]
+                                   tcMetaTy decsQTyConName 
+    tcUntypedBracket (PatBr _)   = -- Result type is PatQ (= Q Pat)
+                                   tcMetaTy patQTyConName
+    tcUntypedBracket (DecBrL _)  = panic "tcUntypedBracket: Unexpected DecBrL"
+    tcUntypedBracket (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"
+
+    tc_bracket :: HsBracket Name -> TcRef [PendingSplice] -> TcM (HsExpr TcId)
+    tc_bracket brack ps_ref
+      | not (isTypedBracket brack)
+      = do { mapM_ tcPendingSplice ps
+           ; meta_ty <- tcUntypedBracket brack
+           ; ps' <- readMutVar ps_ref
+           ; co <- unifyType meta_ty res_ty
+           ; return (mkHsWrapCo co (HsBracketOut brack ps'))
+           }
+
+    tc_bracket (TExpBr expr) ps_ref
+      = do { any_ty <- newFlexiTyVarTy openTypeKind
+             -- NC for no context; tcBracket does that
+           ; _ <- tcMonoExprNC expr any_ty
+           ; meta_ty <- tcTExpTy any_ty
+           ; ps' <- readMutVar ps_ref
+           ; co <- unifyType meta_ty res_ty
+           ; d <- tcLookupDataCon tExpDataConName
+           ; return (mkHsWrapCo co (unLoc (mkHsConApp d [any_ty] [HsBracketOut brack ps'])))
+           }
+
+    tc_bracket _ _
+      = panic "tc_bracket: Expected untyped splice"
 
 tcPendingSplice :: PendingSplice -> TcM ()
 tcPendingSplice (PendingRnExpSplice n expr) 
@@ -402,36 +409,6 @@ tcPendingSplice (PendingRnTypeSplice n expr)
 tcPendingSplice (PendingTcSplice _ expr) 
   = pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr)
 
-tc_bracket :: HsBracket Name -> TcM TcType
-tc_bracket (VarBr _ _)     -- Note [Quoting names]
-  = tcMetaTy nameTyConName
-    -- Result type is Var (not Q-monadic)
-
-tc_bracket (ExpBr _)
-  = tcMetaTy expQTyConName
-    -- Result type is ExpQ (= Q Exp)
-
-tc_bracket (TypBr _)
-  = tcMetaTy typeQTyConName
-    -- Result type is Type (= Q Typ)
-
-tc_bracket (DecBrG _)
-  = tcMetaTy decsQTyConName 
-    -- Result type is Q [Dec]
-
-tc_bracket (PatBr _)
-  = tcMetaTy patQTyConName
-    -- Result type is PatQ (= Q 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
-        ; tcTExpTy any_ty }
-        -- Result type is TExp tau
-
 tcTExpTy :: TcType -> TcM TcType
 tcTExpTy tau = do
     t <- tcLookupTyCon tExpTyConName
@@ -456,33 +433,47 @@ tcSpliceExpr splice@(HsSplice isTypedSplice name expr) res_ty
         ; Comp      -> tcTopSplice expr res_ty
         ; Brack isTypedBrack pop_stage ps_var lie_var -> do
 
-        -- See Note [How brackets and nested splices are handled]
-        -- A splice inside brackets
-        -- NB: ignore res_ty, apart from zapping it to a mono-type
-        -- e.g.   [| reverse $(h 4) |]
-        -- Here (h 4) :: Q Exp
-        -- but $(h 4) :: forall a.a     i.e. anything!
-
      { when (isTypedBrack && not isTypedSplice) $
            failWithTc illegalUntypedSplice
      ; when (not isTypedBrack && isTypedSplice) $
            failWithTc illegalTypedSplice
-     ; meta_exp_ty <- if isTypedSplice
-                      then do { any_ty <- newFlexiTyVarTy openTypeKind
-                              ; tcTExpTy any_ty
-                              }
-                      else tcMetaTy expQTyConName
-
-     ; expr' <- setStage pop_stage $
-                setConstraintVar lie_var    $
-                tcMonoExpr expr meta_exp_ty
 
-        -- Write the pending splice into the bucket
-     ; ps <- readMutVar ps_var
-     ; writeMutVar ps_var (PendingTcSplice name expr' : ps)
+     ; tc_splice_expr isTypedSplice pop_stage ps_var lie_var
 
-     ; return (panic "tcSpliceExpr")    -- The returned expression is ignored
+       -- The returned expression is ignored
+     ; return (panic "tcSpliceExpr")    
      }}}
+  where
+    tc_splice_expr :: Bool
+                   -> ThStage -> TcRef [PendingSplice] -> TcRef WantedConstraints
+                   -> TcM ()
+    -- See Note [How brackets and nested splices are handled]
+    -- A splice inside brackets
+    -- NB: ignore res_ty, apart from zapping it to a mono-type
+    -- e.g.   [| reverse $(h 4) |]
+    -- Here (h 4) :: Q Exp
+    -- but $(h 4) :: forall a.a     i.e. anything!
+    tc_splice_expr False pop_stage ps_var lie_var
+      = do { meta_exp_ty <- tcMetaTy expQTyConName
+           ; expr' <- setStage pop_stage $
+                      setConstraintVar lie_var $
+                      tcMonoExpr expr meta_exp_ty
+           ; ps <- readMutVar ps_var
+           ; writeMutVar ps_var (PendingTcSplice name expr' : ps)
+           ; return ()
+           }
+
+    tc_splice_expr True pop_stage ps_var lie_var
+      = do { meta_exp_ty <- tcTExpTy res_ty
+           ; expr' <- setStage pop_stage $
+                      setConstraintVar lie_var $
+                      tcMonoExpr expr meta_exp_ty
+           ; unt <- tcLookupId unTypeName
+           ; let expr'' = mkHsApp (nlHsTyApp unt [res_ty]) expr'
+           ; ps <- readMutVar ps_var
+           ; writeMutVar ps_var (PendingTcSplice name expr'' : ps)
+           ; return ()
+           }
 
 tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
 tcTopSplice expr res_ty