Allow type signatures in instance decls (Trac #5676)

This new feature-ette, enable with -XInstanceSigs, lets
you give a type signature in an instance declaration:

   instance Eq Int where
     (==) :: Int -> Int -> Bool
     (==) = ...blah...

Scoped type variables work too.

6 files changed, 82 insertions, 33 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3cab4423c8..de844ea3b5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -402,7 +402,8 @@ data ExtensionFlag
    | Opt_RebindableSyntax
    | Opt_ConstraintKinds
    | Opt_PolyKinds                -- Kind polymorphism
-
+   | Opt_InstanceSigs
+ 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
    | Opt_DeriveFunctor
@@ -1934,6 +1935,7 @@ xFlags = [
   ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),
   ( "ConstraintKinds",                  Opt_ConstraintKinds, nop ),
   ( "PolyKinds",                        Opt_PolyKinds, nop ),
+  ( "InstanceSigs",                     Opt_InstanceSigs, nop ),
   ( "MonoPatBinds",                     Opt_MonoPatBinds,
     \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 0da8070438..969a517629 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -728,14 +728,14 @@ okHsSig ctxt (L _ sig)
      (GenericSig {}, ClsDeclCtxt {}) -> True
      (GenericSig {}, _)              -> False
 
-     (TypeSig {}, InstDeclCtxt {}) -> False
-     (TypeSig {}, _)               -> True
+     (TypeSig {}, _)              -> True
 
      (FixSig {}, InstDeclCtxt {}) -> False
      (FixSig {}, _)               -> True
 
-     (IdSig {}, TopSigCtxt) -> True
-     (IdSig {}, _)          -> False
+     (IdSig {}, TopSigCtxt)      -> True
+     (IdSig {}, InstDeclCtxt {}) -> True
+     (IdSig {}, _)               -> False
 
      (InlineSig {}, HsBootCtxt) -> False
      (InlineSig {}, _)          -> True
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index d79dcb868e..31c7c336be 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -52,6 +52,7 @@ import ListSetOps       ( findDupsEq )
 import Digraph		( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
+import Data.List( partition )
 import Maybes( orElse )
 import Data.Maybe( isNothing )
 \end{code}
@@ -427,6 +428,16 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- Used for both source and interface file decls
   = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
+             (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
+
+       -- Rename the associated types, and type signatures
+       -- Both need to have the instance type variables in scope
+       ; ((ats', other_sigs'), more_fvs) 
+             <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
+                do { (ats', at_fvs) <- rnATInsts cls ats
+                   ; other_sigs'    <- renameSigs (InstDeclCtxt cls) other_sigs
+                   ; return ( (ats', other_sigs')
+                            , at_fvs `plusFV` hsSigsFVs other_sigs') }
 
 	-- Rename the bindings
 	-- The typechecker (not the renamer) checks that all 
@@ -434,29 +445,24 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- (Slightly strangely) when scoped type variables are on, the 
         -- forall-d tyvars scope over the method bindings too
        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
-                                rnMethodBinds cls (\_ -> [])	-- No scoped tyvars
+                                rnMethodBinds cls (mkSigTvFn other_sigs')
 					          mbinds    
 
-       -- Rename the associated types
-       -- NB: We allow duplicate associated-type decls; 
-       --     See Note [Associated type instances] in TcInstDcls
-       ; (ats', at_fvs) <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
-                           rnATInsts cls ats
-
-	-- Rename the prags and signatures.
-	-- Note that the type variables are not in scope here,
+	-- Rename the SPECIALISE instance pramas
+	-- Annoyingly the type variables are not in scope here,
 	-- so that	instance Eq a => Eq (T a) where
 	--			{-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-	-- works OK. 
+	-- works OK. That's why we did the partition game above
 	--
 	-- But the (unqualified) method names are in scope
-       ; let binders = collectHsBindsBinders mbinds'
-       ; uprags' <- bindLocalNames binders $
-	            renameSigs (InstDeclCtxt cls) uprags
+--       ; let binders = collectHsBindsBinders mbinds'
+       ; spec_inst_prags' <- -- bindLocalNames binders $
+	                     renameSigs (InstDeclCtxt cls) spec_inst_prags
 
+       ; let uprags' = spec_inst_prags' ++ other_sigs'
        ; return (InstDecl inst_ty' mbinds' uprags' ats',
-	         meth_fvs `plusFV` at_fvs
-                          `plusFV` hsSigsFVs uprags'
+	         meth_fvs `plusFV` more_fvs
+                          `plusFV` hsSigsFVs spec_inst_prags'
 		      	  `plusFV` extractHsTyNames inst_ty') }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
@@ -474,6 +480,8 @@ Renaming of the associated types in instances.
 
 \begin{code}
 rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+       -- NB: We allow duplicate associated-type decls; 
+       --     See Note [Associated type instances] in TcInstDcls
 rnATInsts cls atDecls = rnList rnATInst atDecls
   where
     rnATInst tydecl@TyData     {} = rnTyClDecl (Just cls) tydecl
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 5e128c7613..224cc18474 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -1197,11 +1197,10 @@ mkSigFun sigs = lookupNameEnv env
 
 \begin{code}
 tcTySig :: LSig Name -> TcM [TcId]
-tcTySig (L span (TypeSig names ty))
-  = setSrcSpan span $ mapM f names
-  where
-    f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-                       ; return (mkLocalId name sigma_ty) }
+tcTySig (L span (TypeSig names@(L _ name1 : _) ty))
+  = setSrcSpan span $ 
+    do { sigma_ty <- tcHsSigType (FunSigCtxt name1) ty
+       ; return [ mkLocalId name sigma_ty | L _ name <- names ] }
 tcTySig (L _ (IdSig id))
   = return [id]
 tcTySig s = pprPanic "tcTySig" (ppr s)
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 7ec86fcc6b..1eaf927ffd 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -790,6 +790,38 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    loc       = getSrcSpan dfun_id
 
 ------------------------------
+checkInstSig :: Class -> [TcType] -> LSig Name -> TcM ()
+-- Check that any type signatures have exactly the right type
+checkInstSig clas inst_tys (L loc (TypeSig names@(L _ name1:_) hs_ty))
+  = setSrcSpan loc $ 
+    do { inst_sigs <- xoptM Opt_InstanceSigs
+       ; if inst_sigs then 
+           do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
+              ; mapM_ (check sigma_ty) names }
+         else
+           addErrTc (misplacedInstSig names hs_ty) }
+  where
+    check sigma_ty (L _ n) 
+      = do { sel_id <- tcLookupId n
+           ; let meth_ty = instantiateMethod clas sel_id inst_tys
+           ; checkTc (sigma_ty `eqType` meth_ty)
+                     (badInstSigErr n meth_ty) }
+ 
+checkInstSig _ _ _ = return ()
+
+badInstSigErr :: Name -> Type -> SDoc
+badInstSigErr meth ty
+  = hang (ptext (sLit "Method signature does not match class; it should be"))
+       2 (pprPrefixName meth <+> dcolon <+> ppr ty)
+
+misplacedInstSig :: [Located Name] -> LHsType Name -> SDoc
+misplacedInstSig names hs_ty
+  = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
+              2 (hang (hsep $ punctuate comma (map (pprPrefixName . unLoc) names))
+                    2 (dcolon <+> ppr hs_ty))
+         , ptext (sLit "(Use -XInstanceSigs to allow this)") ]
+
+------------------------------
 tcSuperClass :: [TcTyVar] -> [EvVar]
              -> (Id, PredType)
              -> TcM (TcId, LHsBinds TcId)
@@ -936,8 +968,9 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
         --      forall tvs. theta => ...
 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   (spec_inst_prags, prag_fn)
-                  op_items (VanillaInst binds _ standalone_deriv)
-  = mapAndUnzipM tc_item op_items
+                  op_items (VanillaInst binds sigs standalone_deriv)
+  = do { mapM_ (checkInstSig clas inst_tys) sigs
+       ; mapAndUnzipM tc_item op_items }
   where
     ----------------------
     tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
@@ -953,12 +986,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
       = add_meth_ctxt sel_id generated_code rn_bind $
         do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
                                                    inst_tys sel_id
-           ; let prags = prag_fn (idName sel_id)
+           ; let sel_name = idName sel_id
+                 prags = prag_fn (idName sel_id)
            ; meth_id1 <- addInlinePrags meth_id prags
            ; spec_prags <- tcSpecPrags meth_id1 prags
            ; bind <- tcInstanceMethodBody InstSkol
                           tyvars dfun_ev_vars
-                          meth_id1 local_meth_id meth_sig_fn
+                          meth_id1 local_meth_id 
+                          (mk_meth_sig_fn sel_name)
                           (mk_meth_spec_prags meth_id1 spec_prags)
                           rn_bind
            ; return (meth_id1, bind) }
@@ -1038,8 +1073,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                    [ L loc (SpecPrag meth_id wrap inl)
                    | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
 
-    loc = getSrcSpan dfun_id
-    meth_sig_fn _ = Just ([],loc)       -- The 'Just' says "yes, there's a type sig"
+    loc    = getSrcSpan dfun_id
+    sig_fn = mkSigFun sigs
+    mk_meth_sig_fn sel_name _meth_name 
+       = case sig_fn sel_name of 
+            Nothing -> Just ([],loc)
+            Just r  -> Just r 
+        -- The orElse 'Just' says "yes, in effect there's always a type sig"
         -- But there are no scoped type variables from local_method_id
         -- Only the ones from the instance decl itself, which are already
         -- in scope.  Example:
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 4cdc28bfc5..2c38b2ffde 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -160,8 +160,8 @@ unifyKindTcS ty1 ty2 ki1 ki2
   = wrapTcS $ TcM.addErrCtxtM ctxt $ do
       (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2)
       return (maybe False (const True) mb_r)
-  where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2
-
+  where 
+    ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2
 \end{code}
 
 %************************************************************************