Fix Trac #3540: malformed types

Tidy up the way that predicates are handled inside types

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index a71da2e..7a7edb4 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -7,7 +7,7 @@
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcMonoBinds, tcPolyBinds,
-                 TcPragFun, tcSpecPrag, tcPrags, mkPragFun, 
+                 TcPragFun, tcPrags, mkPragFun, 
                  TcSigInfo(..), TcSigFun, mkTcSigFun,
                  badBootDeclErr ) where
 
@@ -423,21 +423,24 @@ pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
 tcPrag :: TcId -> Sig Name -> TcM Prag
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
-tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
-tcPrag poly_id (SpecInstSig hs_ty)   = tcSpecPrag poly_id hs_ty defaultInlineSpec
-tcPrag _       (InlineSig _ inl)     = return (InlinePrag inl)
-tcPrag _       sig                  = pprPanic "tcPrag" (ppr sig)
-
-
-tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
-tcSpecPrag poly_id hs_ty inl
+-- Most of the work of specialisation is done by 
+-- the desugarer, guided by the SpecPrag
+tcPrag poly_id (SpecSig _ hs_ty inl) 
   = do  { let name = idName poly_id
         ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
         ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
         ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
-        -- Most of the work of specialisation is done by 
-        -- the desugarer, guided by the SpecPrag
-  
+tcPrag poly_id (SpecInstSig hs_ty)
+  = do  { let name = idName poly_id
+        ; (tyvars, theta, tau) <- tcHsInstHead hs_ty   
+        ; let spec_ty = mkSigmaTy tyvars theta tau
+        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
+        ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) }
+
+tcPrag _  (InlineSig _ inl) = return (InlinePrag inl)
+tcPrag _  sig              = pprPanic "tcPrag" (ppr sig)
+
+
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 77fefc2..e277e5f 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -159,10 +159,26 @@ tcHsSigTypeNC ctxt hs_ty
 tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type)
 -- Typecheck an instance head.  We can't use 
 -- tcHsSigType, because it's not a valid user type.
-tcHsInstHead hs_ty
-  = do { kinded_ty <- kcHsSigType hs_ty
-       ; poly_ty   <- tcHsKindedType kinded_ty
-       ; return (tcSplitSigmaTy poly_ty) }
+tcHsInstHead (L loc ty)
+  = setSrcSpan loc   $ -- No need for an "In the type..." context
+    tc_inst_head ty     -- because that comes from the caller
+  where
+    -- tc_inst_head expects HsPredTy, which isn't usually even allowed
+    tc_inst_head (HsPredTy pred)
+      = do { pred'  <- kcHsPred pred
+          ; pred'' <- dsHsPred pred'
+           ; return ([], [], mkPredTy pred'') }
+
+    tc_inst_head (HsForAllTy _ tvs ctxt (L _ (HsPredTy pred)))
+      = kcHsTyVars tvs    $ \ tvs' ->
+       do { ctxt' <- kcHsContext ctxt
+          ; pred' <- kcHsPred    pred
+          ; tcTyVarBndrs tvs'  $ \ tvs'' ->
+       do { ctxt'' <- mapM dsHsLPred (unLoc ctxt')
+          ; pred'' <- dsHsPred pred'
+          ; return (tvs'', ctxt'', mkPredTy pred'') } }
+
+    tc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type"))
 
 tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
 -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
@@ -283,11 +299,6 @@ kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
        ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind
        ; return (mkHsAppTys fun_ty' arg_tys') }
 
-kc_check_hs_type ty@(HsPredTy (HsClassP cls tys)) exp_kind
-  = do { cls_kind <- kcClass cls
-       ; tys' <- kcCheckApps cls cls_kind tys ty exp_kind
-       ; return (HsPredTy (HsClassP cls tys')) }
-
 -- This is the general case: infer the kind and compare
 kc_check_hs_type ty exp_kind
   = do { (ty', act_kind) <- kc_hs_type ty
@@ -306,7 +317,6 @@ kc_check_hs_type ty exp_kind
     strip (HsBangTy _ (L _ ty))       = strip ty
     strip (HsForAllTy _ _ _ (L _ ty)) = strip ty
     strip ty                         = ty
-
 \end{code}
 
        Here comes the main function
@@ -381,12 +391,8 @@ kc_hs_type (HsAppTy ty1 ty2) = do
   where
     (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
 
-kc_hs_type (HsPredTy (HsEqualP _ _))
-  = wrongEqualityErr
-
-kc_hs_type (HsPredTy pred) = do
-    pred' <- kcHsPred pred
-    return (HsPredTy pred', liftedTypeKind)
+kc_hs_type (HsPredTy pred)
+  = wrongPredErr pred
 
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names         $ \ tv_names' ->
@@ -1080,8 +1086,7 @@ dupInScope n n' _
        2 (vcat [ptext (sLit "are bound to the same type (variable)"),
                ptext (sLit "Distinct scoped type variables must be distinct")])
 
-wrongEqualityErr :: TcM (HsType Name, TcKind)
-wrongEqualityErr
-  = failWithTc (text "Equality predicate used as a type")
+wrongPredErr :: HsPred Name -> TcM (HsType Name, TcKind)
+wrongPredErr pred = failWithTc (text "Predicate used as a type:" <+> ppr pred)
 \end{code}
 

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 94c2d25..6d6d102 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1078,12 +1078,14 @@ checkValidType ctxt ty = do
                      ThBrackCtxt | unboxed -> UT_Ok
                      _                     -> UT_NotOk
 
-       -- Check that the thing has kind Type, and is lifted if necessary
-    checkTc kind_ok (kindErr actual_kind)
-
        -- Check the internal validity of the type itself
     check_type rank ubx_tup ty
 
+       -- Check that the thing has kind Type, and is lifted if necessary
+       -- Do this second, becuase we can't usefully take the kind of an 
+       -- ill-formed type such as (a~Int)
+    checkTc kind_ok (kindErr actual_kind)
+
     traceTc (text "checkValidType done" <+> ppr ty)
 
 checkValidMonoType :: Type -> TcM ()
@@ -1138,15 +1140,12 @@ check_type rank ubx_tup ty
   where
     (tvs, theta, tau) = tcSplitSigmaTy ty
    
--- Naked PredTys don't usually show up, but they can as a result of
---     {-# SPECIALISE instance Ord Char #-}
--- The Right Thing would be to fix the way that SPECIALISE instance pragmas
--- are handled, but the quick thing is just to permit PredTys here.
-check_type _ _ (PredTy sty)
-  = do { dflags <- getDOpts
-       ; check_pred_ty dflags TypeCtxt sty }
+-- Naked PredTys should, I think, have been rejected before now
+check_type _ _ ty@(PredTy {})
+  = failWithTc (text "Predicate used as a type:" <+> ppr ty)
 
 check_type _ _ (TyVarTy _) = return ()
+
 check_type rank _ (FunTy arg_ty res_ty)
   = do { check_type (decRank rank) UT_NotOk arg_ty
        ; check_type rank           UT_Ok    res_ty }