Improve error message in TcHsType

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

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 968ccfb..31cf70e 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -191,8 +191,7 @@ kcHsSigType ty           = kcTypeType ty
 kcHsLiftedSigType ty = kcLiftedType ty
 
 tcHsKindedType :: LHsType Name -> TcM Type
-  -- Don't do kind checking, nor validity checking, 
-  --   but do hoist for-alls to the top
+  -- Don't do kind checking, nor validity checking.
   -- This is used in type and class decls, where kinding is
   -- done in advance, and validity checking is done later
   -- [Validity checking done later because of knot-tying issues.]
@@ -242,15 +241,23 @@ kcCheckHsType (L span ty) exp_kind
                -- because checkExpectedKind already mentions
                -- 'ty' by name in any error message
 
-       ; checkExpectedKind ty act_kind exp_kind
+       ; checkExpectedKind (strip ty) act_kind exp_kind
        ; return (L span ty') }
   where
-       -- Wrap a context around only if we want to
-       -- show that contexts.  Omit invisble ones
-       -- and ones user's won't grok (HsPred p).
-    add_ctxt (HsPredTy p)                         thing = thing
-    add_ctxt (HsForAllTy Implicit tvs (L _ []) ty) thing = thing
+       -- Wrap a context around only if we want to show that contexts.  
+       -- Omit invisble ones and ones user's won't grok (HsPred p).
+    add_ctxt (HsPredTy p)                               thing = thing
+    add_ctxt (HsForAllTy Implicit tvs (L _ []) (L _ ty)) thing = add_ctxt ty thing
     add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing
+
+       -- We infer the kind of the type, and then complain if it's
+       -- not right.  But we don't want to complain about
+       --      (ty) or !(ty) or forall a. ty
+       -- when the real difficulty is with the 'ty' part.
+    strip (HsParTy (L _ ty))          = strip ty
+    strip (HsBangTy _ (L _ ty))       = strip ty
+    strip (HsForAllTy _ _ _ (L _ ty)) = strip ty
+    strip ty                         = ty
 \end{code}
 
        Here comes the main function
@@ -543,23 +550,26 @@ GADT constructor signatures
 
 \begin{code}
 tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy ty@(L span _) 
-  = setSrcSpan span $ 
-    addErrCtxt (gadtResCtxt ty) $
-    tc_con_res ty []
-
-tc_con_res (L _ (HsAppTy fun res_ty)) res_tys
-  = do { res_ty' <- dsHsType res_ty
-       ; tc_con_res fun (res_ty' : res_tys) }
-
-tc_con_res ty@(L _ (HsTyVar name)) res_tys
-  = do { thing <- tcLookup name
-       ; case thing of
-           AGlobal (ATyCon tc) -> return (tc, res_tys)
-           other -> failWithTc (badGadtDecl ty)
-       }
-
-tc_con_res ty _ = failWithTc (badGadtDecl ty)
+tcLHsConResTy res_ty
+  = addErrCtxt (gadtResCtxt res_ty) $
+    case get_largs res_ty [] of
+          (HsTyVar tc_name, args) 
+             -> do { args' <- mapM dsHsType args
+                   ; thing <- tcLookup tc_name
+                   ; case thing of
+                       AGlobal (ATyCon tc) -> return (tc, args')
+                       other -> failWithTc (badGadtDecl res_ty) }
+          other -> failWithTc (badGadtDecl res_ty)
+  where
+       -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
+       -- because that causes a black hole, and for good reason.  Building
+       -- the type means expanding type synonyms, and we can't do that
+       -- inside the "knot".  So we have to work by steam.
+    get_largs (L _ ty) args = get_args ty args
+    get_args (HsAppTy fun arg)                   args = get_largs fun (arg:args)
+    get_args (HsParTy ty)                        args = get_largs ty  args
+    get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
+    get_args ty                          args = (ty, args)
 
 gadtResCtxt ty
   = hang (ptext SLIT("In the result type of a data constructor:"))
@@ -610,7 +620,7 @@ tcTyVarBndrs bndrs thing_inside
 
 -----------------------------------
 tcDataKindSig :: Maybe Kind -> TcM [TyVar]
--- GADT decls can have a (perhpas partial) kind signature
+-- GADT decls can have a (perhaps partial) kind signature
 --     e.g.  data T :: * -> * -> * where ...
 -- This function makes up suitable (kinded) type variables for 
 -- the argument kinds, and checks that the result kind is indeed *