Refactor default methods (Trac #11105)

This patch does some signficant refactoring to the treatment
of default methods in class declarations, and more generally
to the type checking of type/class decls.

Highlights:

* When the class has a generic-default method, such as
     class C a where
       op :: a -> a -> Bool
       default op :: Ord a => a -> a -> a
  the ClassOpItem records the type of the generic-default,
  in this case the type (Ord a => a -> a -> a)

* I killed off Class.DefMeth in favour of the very-similar
  BasicTypes.DefMethSpec.  However it turned out to be better
  to use a Maybe, thus
      Maybe (DefMethSpec Type)
  with Nothing meaning "no default method".

* In TcTyClsDecls.tcTyClGroup, we used to accumulate a [TyThing],
  but I found a way to make it much simpler, accumulating only
  a [TyCon].  Much less wrapping and unwrapping.

* On the way I also fixed Trac #10896 in a better way. Instead
  of killing off all ambiguity checks whenever there are any type
  errors (the fix in commit 8e8b9ed), I instead recover in
  TcTyClsDecls.checkValidTyCl.

There was a lot of associated simplification all round

5 files changed, 61 insertions, 29 deletions

diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 6085b0cc3c..0b8680d164 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -230,7 +230,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
 
 -- ------------------------------------------------------
 
-type TcMethInfo = (Name, DefMethSpec, Type)
+type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
         -- A temporary intermediate, to communicate between
         -- tcClassSigs and buildClass.
 
@@ -279,7 +279,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
                 --     class C a => D a
                 -- we don't get a newtype with no arguments!
               args      = sc_sel_names ++ op_names
-              op_tys    = [ty | (_,_,ty) <- sig_stuff]
+              op_tys    = [ty | (_,ty,_) <- sig_stuff]
               op_names  = [op | (op,_,_) <- sig_stuff]
               arg_tys   = sc_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
@@ -327,13 +327,11 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
     no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
-    mk_op_item rec_clas (op_name, dm_spec, _)
+    mk_op_item rec_clas (op_name, _, dm_spec)
       = do { dm_info <- case dm_spec of
-                          NoDM      -> return NoDefMeth
-                          GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
-                                          ; return (GenDefMeth dm_name) }
-                          VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
-                                          ; return (DefMeth dm_name) }
+                          Nothing   -> return Nothing
+                          Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+                                          ; return (Just (dm_name, spec)) }
            ; return (mkDictSelId op_name rec_clas, dm_info) }
 
 {-
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 41d6779785..463078ce67 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -173,10 +173,13 @@ data IfaceFamTyConFlav
   | IfaceAbstractClosedSynFamilyTyCon
   | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
 
-data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
-        -- Nothing    => no default method
-        -- Just False => ordinary polymorphic default method
-        -- Just True  => generic default method
+data IfaceClassOp
+  = IfaceClassOp IfaceTopBndr
+                 IfaceType                         -- Class op type
+                 (Maybe (DefMethSpec IfaceType))   -- Default method
+                 -- The types of both the class op itself,
+                 -- and the default method, are *not* quantifed
+                 -- over the class variables
 
 data IfaceAT = IfaceAT  -- See Class.ClassATItem
                   IfaceDecl          -- The associated type declaration
@@ -814,9 +817,14 @@ instance Outputable IfaceClassOp where
    ppr = pprIfaceClassOp showAll
 
 pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
-pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty)
-  where opHdr = pprPrefixIfDeclBndr ss n
-                <+> ppShowIface ss (ppr dm) <+> dcolon
+pprIfaceClassOp ss (IfaceClassOp n ty dm)
+  = pp_sig n ty $$ generic_dm
+  where
+   generic_dm | Just (GenericDM dm_ty) <- dm
+              =  ptext (sLit "default") <+> pp_sig n dm_ty
+              | otherwise
+              = empty
+   pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty
 
 instance Outputable IfaceAT where
    ppr = pprIfaceAT showAll
@@ -1182,7 +1190,11 @@ freeNamesIfAT (IfaceAT decl mb_def)
       Just rhs -> freeNamesIfType rhs
 
 freeNamesIfClsSig :: IfaceClassOp -> NameSet
-freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
+freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
+
+freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
+freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
+freeNamesDM _                     = emptyNameSet
 
 freeNamesIfConDecls :: IfaceConDecls -> NameSet
 freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
@@ -1538,16 +1550,16 @@ instance Binary IfaceFamTyConFlav where
                                   (ppr (fromIntegral h :: Int)) }
 
 instance Binary IfaceClassOp where
-    put_ bh (IfaceClassOp n def ty) = do
+    put_ bh (IfaceClassOp n ty def) = do
         put_ bh (occNameFS n)
-        put_ bh def
         put_ bh ty
+        put_ bh def
     get bh = do
         n   <- get bh
-        def <- get bh
         ty  <- get bh
+        def <- get bh
         occ <- return $! mkVarOccFS n
-        return (IfaceClassOp occ def ty)
+        return (IfaceClassOp occ ty def)
 
 instance Binary IfaceAT where
     put_ bh (IfaceAT dec defs) = do
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 8be97dfe40..7bf949e24f 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -6,7 +6,9 @@
 This module defines interface types and binders
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, FlexibleInstances #-}
+    -- FlexibleInstances for Binary (DefMethSpec IfaceType)
+
 module IfaceType (
         IfExtName, IfLclName,
 
@@ -1007,6 +1009,15 @@ instance Binary IfaceCoercion where
                    return $ IfaceAxiomRuleCo a b c
            _ -> panic ("get IfaceCoercion " ++ show tag)
 
+instance Binary (DefMethSpec IfaceType) where
+    put_ bh VanillaDM     = putByte bh 0
+    put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return VanillaDM
+              _ -> do { t <- get bh; return (GenericDM t) }
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 98b8830e01..d955fa5fd9 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1529,8 +1529,9 @@ classToIfaceDecl env clas
 
     toIfaceClassOp (sel_id, def_meth)
         = ASSERT(sel_tyvars == clas_tyvars)
-          IfaceClassOp (getOccName sel_id) (toDmSpec def_meth)
+          IfaceClassOp (getOccName sel_id)
                        (tidyToIfaceType env1 op_ty)
+                       (fmap toDmSpec def_meth)
         where
                 -- Be careful when splitting the type, because of things
                 -- like         class Foo a where
@@ -1540,9 +1541,9 @@ classToIfaceDecl env clas
           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
           op_ty                = funResultTy rho_ty
 
-    toDmSpec NoDefMeth      = NoDM
-    toDmSpec (GenDefMeth _) = GenericDM
-    toDmSpec (DefMeth _)    = VanillaDM
+    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+    toDmSpec (_, VanillaDM)       = VanillaDM
+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
 
     toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1,
                               map (getFS . tidyTyVar env1) tvs2)
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 45b583cd91..da94136218 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -50,7 +50,7 @@ import PrelNames
 import TysWiredIn
 import TysPrim          ( superKindTyConName )
 import BasicTypes       ( strongLoopBreaker, Arity, TupleSort(..)
-                        , Boxity(..), pprRuleName )
+                        , Boxity(..), DefMethSpec(..), pprRuleName )
 import Literal
 import qualified Var
 import VarEnv
@@ -419,13 +419,23 @@ tc_iface_decl _parent ignore_prags
         -- Here the associated type T is knot-tied with the class, and
         -- so we must not pull on T too eagerly.  See Trac #5970
 
-   tc_sig (IfaceClassOp occ dm rdr_ty)
+   tc_sig :: IfaceClassOp -> IfL TcMethInfo
+   tc_sig (IfaceClassOp occ rdr_ty dm)
      = do { op_name <- lookupIfaceTop occ
-          ; op_ty   <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
+          ; ~(op_ty, dm') <- forkM (mk_op_doc op_name rdr_ty) $
+                             do { ty <- tcIfaceType rdr_ty
+                                ; dm' <- tc_dm dm
+                                ; return (ty, dm') }
                 -- Must be done lazily for just the same reason as the
                 -- type of a data con; to avoid sucking in types that
                 -- it mentions unless it's necessary to do so
-          ; return (op_name, dm, op_ty) }
+          ; return (op_name, op_ty, dm') }
+
+   tc_dm :: Maybe (DefMethSpec IfaceType) -> IfL (Maybe (DefMethSpec Type))
+   tc_dm Nothing               = return Nothing
+   tc_dm (Just VanillaDM)      = return (Just VanillaDM)
+   tc_dm (Just (GenericDM ty)) = do { ty' <- tcIfaceType ty
+                                    ; return (Just (GenericDM ty')) }
 
    tc_at cls (IfaceAT tc_decl if_def)
      = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl