Kinding wibble in TH brackets

[ghc-hetmet.git] / ghc / compiler / typecheck / TcExpr.lhs

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 8227e67..e7c7f3b 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -21,11 +21,13 @@ import qualified DsMeta
 #endif
 
 import HsSyn           ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
-                         HsMatchContext(..), HsRecordBinds, mkHsApp, mkHsDictApp, mkHsTyApp )
+                         HsMatchContext(..), HsRecordBinds, 
+                         mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
 import TcHsSyn         ( hsLitType )
 import TcRnMonad
 import TcUnify         ( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-                         boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, unBox )
+                         boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, 
+                         unBox )
 import BasicTypes      ( Arity, isMarkedStrict )
 import Inst            ( newMethodFromName, newIPDict, instToId,
                          newDicts, newMethodWithGivenTy, tcInstStupidTheta )
@@ -105,7 +107,7 @@ tcPolyExprNC expr res_ty
   = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
                -- Note the recursive call to tcPolyExpr, because the
                -- type may have multiple layers of for-alls
-       ; return (L (getLoc expr') (HsCoerce gen_fn (unLoc expr'))) }
+       ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) }
 
   | otherwise
   = tcMonoExpr expr res_ty
@@ -181,7 +183,7 @@ tcExpr (HsIPVar ip) res_ty
        ; co_fn <- tcSubExp ip_ty res_ty
        ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
        ; extendLIE inst
-       ; return (HsCoerce co_fn (HsIPVar ip')) }
+       ; return (mkHsCoerce co_fn (HsIPVar ip')) }
 
 tcExpr (HsApp e1 e2) res_ty 
   = go e1 [e2]
@@ -195,13 +197,13 @@ tcExpr (HsApp e1 e2) res_ty
 
 tcExpr (HsLam match) res_ty
   = do { (co_fn, match') <- tcMatchLambda match res_ty
-       ; return (HsCoerce co_fn (HsLam match')) }
+       ; return (mkHsCoerce co_fn (HsLam match')) }
 
 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do  { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
        ; expr' <- tcPolyExpr expr sig_tc_ty
        ; co_fn <- tcSubExp sig_tc_ty res_ty
-       ; return (HsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
+       ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
 
 tcExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -247,7 +249,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
   = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
                                   tcApp op 2 (tc_args arg1_ty') res_ty'
-       ; return (HsCoerce co_fn (SectionR (L loc op') arg2')) }
+       ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) }
   where
     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
                <+> ptext SLIT("takes one argument")
@@ -489,7 +491,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
     extendLIEs dicts                   `thenM_`
 
        -- Phew!
-    returnM (HsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+    returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
 \end{code}
 
 
@@ -607,7 +609,7 @@ tcApp (HsVar fun_name) n_args arg_checker res_ty
   = tcIdApp fun_name n_args arg_checker res_ty
 
 tcApp fun n_args arg_checker res_ty    -- The vanilla case (rula APP)
-  = do { arg_boxes <- newBoxyTyVars n_args
+  = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
        ; fun'      <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
        ; arg_tys'  <- mapM readFilledBox arg_boxes
        ; args'     <- arg_checker arg_tys'
@@ -647,7 +649,7 @@ tcIdApp fun_name n_args arg_checker res_ty
 
        -- Match the result type of the function with the
        -- result type of the context, to get an inital substitution
-       ; extra_arg_boxes <- newBoxyTyVars n_missing_args
+       ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
        ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
              res_ty'        = mkFunTys extra_arg_tys' res_ty
              subst          = boxySubMatchType arg_qtvs fun_res_ty res_ty'
@@ -694,7 +696,7 @@ tcIdApp fun_name n_args arg_checker res_ty
        -- tcFun work nicely for OpApp and Sections too
        ; fun' <- instFun fun_id qtvs qtys'' tv_theta_prs
        ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
-       ; return (HsCoerce co_fn' fun', args') }
+       ; return (mkHsCoerce co_fn' fun', args') }
 \end{code}
 
 Note [Silly type synonyms in smart-app]
@@ -742,7 +744,7 @@ tcId orig fun_name res_ty
 
        -- And pack up the results
        ; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs 
-       ; return (HsCoerce co_fn fun') }
+       ; return (mkHsCoerce co_fn fun') }
 
 --     Note [Push result type in]
 --
@@ -991,8 +993,14 @@ thBrackId orig id_name id ps_var lie_var
               -- solve this, and it's probably unimportant, so I'm
               -- just going to flag an error for now
    
+       ; id_ty' <- zapToMonotype id_ty
+               -- The id_ty might have an OpenTypeKind, but we
+               -- can't instantiate the Lift class at that kind,
+               -- so we zap it to a LiftedTypeKind monotype
+               -- C.f. the call in TcPat.newLitInst
+
        ; setLIEVar lie_var     $ do
-       { lift <- newMethodFromName orig id_ty DsMeta.liftName
+       { lift <- newMethodFromName orig id_ty' DsMeta.liftName
                   -- Put the 'lift' constraint into the right LIE
           
                   -- Update the pending splices