Fix bug in error message

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

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 4c56b08..43bcb45 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -33,7 +33,7 @@ import TcType         ( TcType, TcTyVar, TcSigmaType, TcRhoType,
                          emptyTvSubst, substTyVar, substTy, mkTopTvSubst, zipTopTvSubst, zipOpenTvSubst,
                          mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy,
                          mkFunTy, mkFunTys, exactTyVarsOfTypes,
-                         tidyOpenTypes )
+                         tidyOpenType, tidyOpenTypes )
 import VarSet          ( elemVarSet, mkVarSet )
 import Kind            ( liftedTypeKind, openTypeKind )
 import TcUnify         ( boxySplitTyConApp, boxySplitListTy, 
@@ -129,7 +129,7 @@ tcCheckExistentialPat (LetPat _) pats ex_tvs pat_tys body_ty
   = failWithTc (existentialExplode pats)
 
 tcCheckExistentialPat ctxt pats ex_tvs pat_tys body_ty
-  = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys)  $
+  = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty)  $
     checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
 
 data PatState = PS {
@@ -278,7 +278,7 @@ tc_pat pstate (BangPat pat) pat_ty thing_inside
   = do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
        ; return (BangPat pat', tvs, res) }
 
--- There's a wrinkle with irrefuatable patterns, namely that we
+-- There's a wrinkle with irrefutable patterns, namely that we
 -- must not propagate type refinement from them.  For example
 --     data T a where { T1 :: Int -> T Int; ... }
 --     f :: T a -> Int -> a
@@ -293,8 +293,14 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
                                  thing_inside pstate
                                        -- Ignore refined pstate',
                                        -- revert to pstate
+       -- Check no existentials
        ; if (null pat_tvs) then return ()
          else lazyPatErr lpat pat_tvs
+
+       -- Check that the pattern has a lifted type
+       ; pat_tv <- newBoxyTyVar liftedTypeKind
+       ; boxyUnify pat_ty (mkTyVarTy pat_tv)
+
        ; return (LazyPat pat', [], res) }
 
 tc_pat pstate (WildPat _) pat_ty thing_inside
@@ -404,6 +410,8 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
     
        ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
        ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
+
+tc_pat _ _other_pat _ _ = panic "tc_pat"       -- DictPat, ConPatOut, SigPatOut, VarPatOut
 \end{code}
 
 
@@ -683,8 +691,7 @@ newLitInst orig lit res_ty  -- Make a LitInst
   = do         { loc <- getInstLoc orig
        ; res_tau <- zapToMonotype res_ty
        ; new_uniq <- newUnique
-       ; let
-               lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
+       ; let   lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
                lit_inst = LitInst lit_nm lit res_tau loc
        ; extendLIE lit_inst
        ; return (HsVar (instToId lit_inst)) }
@@ -774,19 +781,18 @@ existentialExplode pats
                text "In the binding group for"])
        4 (vcat (map ppr pats))
 
-sigPatCtxt bound_ids bound_tvs tys tidy_env 
-  =    -- tys is (body_ty : pat_tys)  
-    mapM zonkTcType tys                `thenM` \ tys' ->
-    let
-       (env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
-       (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
-    in
-    returnM (env1,
+sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env 
+  = do { pat_tys' <- mapM zonkTcType pat_tys
+       ; body_ty' <- zonkTcType body_ty
+       ; let (env1,  tidy_tys)    = tidyOpenTypes tidy_env (map idType show_ids)
+             (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
+             (env3, tidy_body_ty) = tidyOpenType  env2 body_ty'
+       ; return (env3,
                 sep [ptext SLIT("When checking an existential match that binds"),
                      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
                      ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
                      ptext SLIT("The body has type:") <+> ppr tidy_body_ty
-               ])
+               ]) }
   where
     show_ids = filter is_interesting bound_ids
     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs