X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=7b92b810d71339729738d160b175ba5b033ddd19;hb=5cc715b218c2da096055a38a453054cbe0b676c0;hp=e0b5f3dcc9601b935ec53f6f2c21a19363b7f5bb;hpb=3517c53d8a66149dcc3f971cf0577719e99d6d70;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index e0b5f3d..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)
 
@@ -911,9 +912,13 @@ reifyTyCon tc
   | isOpenTyCon tc
   = let flavour = reifyFamFlavour tc
         tvs     = tyConTyVars tc
+        kind    = tyConKind tc
+        kind'
+          | isLiftedTypeKind kind = Nothing
+          | otherwise             = Just $ reifyKind kind
     in
     return (TH.TyConI $
-              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs))
+              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
@@ -982,6 +987,18 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
 
+reifyKind :: Kind -> TH.Kind
+reifyKind  ki
+  = let (kis, ki') = splitKindFunTys ki
+        kis_rep    = map reifyKind kis
+        ki'_rep    = reifyNonArrowKind ki'
+    in
+    foldl TH.ArrowK ki'_rep kis_rep
+  where
+    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
+                        | otherwise          = pprPanic "Exotic form of kind" 
+                                                        (ppr k)
+
 reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
 
@@ -994,8 +1011,14 @@ reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
                    | otherwise         
                    = panic "TcSplice.reifyFamFlavour: not a type family"
 
-reifyTyVars :: [TyVar] -> [TH.Name]
-reifyTyVars = map reifyName
+reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
+reifyTyVars = map reifyTyVar
+  where
+    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
+                  | otherwise             = TH.KindedTV name (reifyKind kind)
+      where
+        kind = tyVarKind tv
+        name = reifyName tv
 
 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys = do { tys' <- reifyTypes tys