Eliminate so-called "silent superclass parameters"
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 23 Dec 2014 15:39:50 +0000 (15:39 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 23 Dec 2014 16:01:23 +0000 (16:01 +0000)
The purpose of silent superclass parameters was to solve the
awkward problem of superclass dictinaries being bound to bottom.
See THE PROBLEM in Note [Recursive superclasses] in TcInstDcls

Although the silent-superclass idea worked,

  * It had non-local consequences, and had effects even in Haddock,
    where we had to discard silent parameters before displaying
    instance declarations

  * It had unexpected peformance costs, shown up by Trac #3064 and its
    test case.  In monad-transformer code, when constructing a Monad
    dictionary you had to pass an Applicative dictionary; and to
    construct that you neede a Functor dictionary. Yet these extra
    dictionaries were often never used.  (All this got much worse when
    we added Applicative as a superclass of Monad.) Test T3064
    compiled *far* faster after silent superclasses were eliminated.

  * It introduced new bugs.  For example SilentParametersOverlapping,
    T5051, and T7862, all failed to compile because of instance overlap
    directly because of the silent-superclass trick.

So this patch takes a new approach, which I worked out with Dimitrios
in the closing hours before Christmas.  It is described in detail
in THE PROBLEM in Note [Recursive superclasses] in TcInstDcls.

Seems to work great!

Quite a bit of knock-on effect

 * The main implementation work is in tcSuperClasses in TcInstDcls
   Everything else is fall-out

 * IdInfo.DFunId no longer needs its n-silent argument
   * Ditto IDFunId in IfaceSyn
   * Hence interface file format changes

 * Now that DFunIds do not have silent superclass parameters, printing
   out instance declarations is simpler. There is tiny knock-on effect
   in Haddock, so that submodule is updated

 * I realised that when computing the "size of a dictionary type"
   in TcValidity.sizePred, we should be rather conservative about
   type functions, which can arbitrarily increase the size of a type.
   Hence the new datatype TypeSize, which has a TSBig constructor for
   "arbitrarily big".

 * instDFunType moves from TcSMonad to Inst

 * Interestingly, CmmNode and CmmExpr both now need a non-silent
   (Ord r) in a couple of instance declarations. These were previously
   silent but must now be explicit.

 * Quite a bit of wibbling in error messages

44 files changed:
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/basicTypes/MkId.hs
compiler/basicTypes/OccName.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmNode.hs
compiler/coreSyn/CoreUtils.hs
compiler/deSugar/DsBinds.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/types/InstEnv.hs
testsuite/tests/deriving/should_fail/drvfail002.stderr
testsuite/tests/indexed-types/should_compile/InstContextNorm.hs
testsuite/tests/indexed-types/should_fail/T7862.hs
testsuite/tests/indexed-types/should_fail/T7862.stderr
testsuite/tests/indexed-types/should_fail/all.T
testsuite/tests/perf/compiler/all.T
testsuite/tests/simplCore/should_compile/Simpl020_A.hs
testsuite/tests/simplCore/should_compile/T8848.stderr
testsuite/tests/simplCore/should_compile/all.T
testsuite/tests/simplCore/should_compile/simpl020.stderr
testsuite/tests/typecheck/should_fail/SilentParametersOverlapping.stderr [deleted file]
testsuite/tests/typecheck/should_fail/T5051.hs
testsuite/tests/typecheck/should_fail/T5051.stderr
testsuite/tests/typecheck/should_fail/T5691.stderr
testsuite/tests/typecheck/should_fail/T6161.hs
testsuite/tests/typecheck/should_fail/T6161.stderr
testsuite/tests/typecheck/should_fail/T8603.stderr
testsuite/tests/typecheck/should_fail/all.T
testsuite/tests/typecheck/should_fail/tcfail017.stderr
testsuite/tests/typecheck/should_fail/tcfail019.stderr
testsuite/tests/typecheck/should_fail/tcfail020.stderr
testsuite/tests/typecheck/should_fail/tcfail042.stderr
testsuite/tests/typecheck/should_fail/tcfail106.stderr
utils/haddock

index ccd6c9b..3e6473f 100644 (file)
@@ -61,7 +61,7 @@ module Id (
         hasNoBinding,
 
         -- ** Evidence variables
-        DictId, isDictId, dfunNSilent, isEvVar,
+        DictId, isDictId, isEvVar,
 
         -- ** Inline pragma stuff
         idInlinePragma, setInlinePragma, modifyInlinePragma,
@@ -392,11 +392,6 @@ isDFunId id = case Var.idDetails id of
                         DFunId {} -> True
                         _         -> False
 
-dfunNSilent :: Id -> Int
-dfunNSilent id = case Var.idDetails id of
-                   DFunId ns _ -> ns
-                   _ -> pprPanic "dfunSilent: not a dfun:" (ppr id)
-
 isPrimOpId_maybe id = case Var.idDetails id of
                         PrimOpId op -> Just op
                         _           -> Nothing
index d2179dc..3242f5e 100644 (file)
@@ -130,14 +130,7 @@ data IdDetails
 
   | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
 
-  | DFunId Int Bool             -- ^ A dictionary function.
-       -- Int = the number of "silent" arguments to the dfun
-       --       e.g.  class D a => C a where ...
-       --             instance C a => C [a]
-       --       has is_silent = 1, because the dfun
-       --       has type  dfun :: (D a, C a) => C [a]
-       --       See Note [Silent superclass arguments] in TcInstDcls
-       --
+  | DFunId Bool                 -- ^ A dictionary function.
        -- Bool = True <=> the class has only one method, so may be
        --                  implemented with a newtype, so it might be bad
        --                  to be strict on this dictionary
@@ -159,9 +152,7 @@ pprIdDetails other     = brackets (pp other)
    pp (PrimOpId _)      = ptext (sLit "PrimOp")
    pp (FCallId _)       = ptext (sLit "ForeignCall")
    pp (TickBoxOpId _)   = ptext (sLit "TickBoxOp")
-   pp (DFunId ns nt)    = ptext (sLit "DFunId")
-                             <> ppWhen (ns /= 0) (brackets (int ns))
-                             <> ppWhen nt (ptext (sLit "(nt)"))
+   pp (DFunId nt)       = ptext (sLit "DFunId") <> ppWhen nt (ptext (sLit "(nt)"))
    pp (RecSelId { sel_naughty = is_naughty })
                          = brackets $ ptext (sLit "RecSel")
                             <> ppWhen is_naughty (ptext (sLit "(naughty)"))
index 14ed9b6..cfdc738 100644 (file)
@@ -961,28 +961,16 @@ mkDictFunId :: Name      -- Name to use for the dict fun;
 -- See Note [Dict funs and default methods]
 
 mkDictFunId dfun_name tvs theta clas tys
-  = mkExportedLocalId (DFunId n_silent is_nt)
+  = mkExportedLocalId (DFunId is_nt)
                       dfun_name
                       dfun_ty
   where
     is_nt = isNewTyCon (classTyCon clas)
-    (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
+    dfun_ty = mkDictFunTy tvs theta clas tys
 
-mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
+mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
 mkDictFunTy tvs theta clas tys
-  = (length silent_theta, dfun_ty)
-  where
-    dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
-    silent_theta
-      | null tvs, null theta
-      = []
-      | otherwise
-      = filterOut discard $
-        substTheta (zipTopTvSubst (classTyVars clas) tys)
-                   (classSCTheta clas)
-                   -- See Note [Silent Superclass Arguments]
-    discard pred = any (`eqPred` pred) theta
-                 -- See the DFun Superclass Invariant in TcInstDcls
+ = mkSigmaTy tvs theta (mkClassPred clas tys)
 
 {-
 ************************************************************************
index 0c23ddc..efa871d 100644 (file)
@@ -63,7 +63,8 @@ module OccName (
         mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
         mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
-        mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
+        mkSuperDictSelOcc, mkSuperDictAuxOcc,
+        mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
         mkInstTyCoOcc, mkEqPredCoOcc,
         mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
         mkPDataTyConOcc,  mkPDataDataConOcc,
@@ -686,6 +687,10 @@ mk_simple_deriv_with sp px (Just with) occ = mk_deriv sp (px ++ with ++ "_") (oc
 -- to VarName
 mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
 
+mkSuperDictAuxOcc :: Int -> OccName -> OccName
+mkSuperDictAuxOcc index cls_tc_occ
+  = mk_deriv varName "$cp" (show index ++ occNameString cls_tc_occ)
+
 mkSuperDictSelOcc :: Int        -- ^ Index of superclass, e.g. 3
                   -> OccName    -- ^ Class, e.g. @Ord@
                   -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@
index 1d6c97f..4d9bbf8 100644 (file)
@@ -347,7 +347,9 @@ instance Ord r => DefinerOfRegs r r where
 instance Ord r => UserOfRegs r (RegSet r) where
     foldRegsUsed _ f = Set.fold (flip f)
 
-instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
   foldRegsUsed dflags f z e = expr z e
     where expr z (CmmLit _)          = z
           expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr
index 0f26d37..73f9971 100644 (file)
@@ -333,7 +333,9 @@ instance UserOfRegs GlobalReg (CmmNode e x) where
                        (b -> GlobalReg -> b) -> b -> a -> b
           fold f z n = foldRegsUsed dflags f z n
 
-instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where
+instance (Ord r, UserOfRegs r CmmExpr) => UserOfRegs r ForeignTarget where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
   foldRegsUsed _      _ z (PrimTarget _)      = z
   foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e
 
index 913dda3..135f81a 100644 (file)
@@ -1064,7 +1064,7 @@ expr_ok primop_ok other_expr
 app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
 app_ok primop_ok fun args
   = case idDetails fun of
-      DFunId new_type ->  not new_type
+      DFunId new_type ->  not new_type
          -- DFuns terminate, unless the dict is implemented
          -- with a newtype in which case they may not
 
index b512fbb..e79c88c 100644 (file)
@@ -215,7 +215,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
   | is_default_method                 -- Default methods are *always* inlined
   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 
-  | DFunId is_newtype <- idDetails gbl_id
+  | DFunId is_newtype <- idDetails gbl_id
   = (mk_dfun_w_stuff is_newtype, rhs)
 
   | otherwise
index ead3da4..7cd875f 100644 (file)
@@ -298,7 +298,7 @@ data IfaceUnfolding
 data IfaceIdDetails
   = IfVanillaId
   | IfRecSelId IfaceTyCon Bool
-  | IfDFunId Int          -- Number of silent args
+  | IfDFunId
 
 {-
 Note [Versioning of instances]
@@ -993,7 +993,7 @@ instance Outputable IfaceIdDetails where
                           <+> if b
                                 then ptext (sLit "<naughty>")
                                 else Outputable.empty
-  ppr (IfDFunId ns)     = ptext (sLit "DFunId") <> brackets (int ns)
+  ppr IfDFunId          = ptext (sLit "DFunId")
 
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = Outputable.empty
@@ -1600,13 +1600,13 @@ instance Binary IfaceAnnotation where
 instance Binary IfaceIdDetails where
     put_ bh IfVanillaId      = putByte bh 0
     put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
-    put_ bh (IfDFunId n)     = do { putByte bh 2; put_ bh n }
+    put_ bh IfDFunId         = putByte bh 2
     get bh = do
         h <- getByte bh
         case h of
             0 -> return IfVanillaId
             1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
-            _ -> do { n <- get bh; return (IfDFunId n) }
+            _ -> return IfDFunId 
 
 instance Binary IfaceIdInfo where
     put_ bh NoInfo      = putByte bh 0
index c0a603f..7226cb0 100644 (file)
@@ -1841,7 +1841,7 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
 toIfaceIdDetails VanillaId                      = IfVanillaId
-toIfaceIdDetails (DFunId ns _)                  = IfDFunId ns
+toIfaceIdDetails (DFunId {})                    = IfDFunId
 toIfaceIdDetails (RecSelId { sel_naughty = n
                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
 toIfaceIdDetails other                          = pprTrace "toIfaceIdDetails" (ppr other)
index 4c0440f..0d504e2 100644 (file)
@@ -1106,8 +1106,8 @@ tcIfaceDataAlt con inst_tys arg_strs rhs
 
 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
 tcIdDetails _  IfVanillaId = return VanillaId
-tcIdDetails ty (IfDFunId ns)
-  = return (DFunId ns (isNewTyCon (classTyCon cls)))
+tcIdDetails ty IfDFunId
+  = return (DFunId (isNewTyCon (classTyCon cls)))
   where
     (_, _, cls, _) = tcSplitDFunTy ty
 
index b91498f..d38f281 100644 (file)
@@ -9,8 +9,8 @@ The @Inst@ type: dictionaries or method instances
 {-# LANGUAGE CPP #-}
 
 module Inst (
-       deeplySkolemise,
-       deeplyInstantiate, instCall, instStupidTheta,
+       deeplySkolemise, deeplyInstantiate, 
+       instCall, instDFunType, instStupidTheta,
        emitWanted, emitWanteds,
 
        newOverloadedLit, mkOverLit,
@@ -236,6 +236,25 @@ instCallConstraints orig preds
           | otherwise
           = orig
 
+instDFunType :: DFunId -> [DFunInstType] -> TcM ([TcType], TcThetaType)
+-- See Note [DFunInstType: instantiating types] in InstEnv
+instDFunType dfun_id dfun_inst_tys
+  = do { (subst, inst_tys) <- go (mkTopTvSubst []) dfun_tvs dfun_inst_tys
+       ; return (inst_tys, substTheta subst dfun_theta) }
+  where
+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
+
+    go :: TvSubst -> [TyVar] -> [DFunInstType] -> TcM (TvSubst, [TcType])
+    go subst [] [] = return (subst, [])
+    go subst (tv:tvs) (Just ty : mb_tys)
+      = do { (subst', tys) <- go (extendTvSubst subst tv ty) tvs mb_tys
+           ; return (subst', ty : tys) }
+    go subst (tv:tvs) (Nothing : mb_tys)
+      = do { (subst', tv') <- tcInstTyVarX subst tv
+           ; (subst'', tys) <- go subst' tvs mb_tys
+           ; return (subst'', mkTyVarTy tv' : tys) }
+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
+
 ----------------
 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
 -- Similar to instCall, but only emit the constraints in the LIE
index 3b182de..1955c1f 100644 (file)
@@ -32,7 +32,7 @@ import TcDeriv
 import TcEnv
 import TcHsType
 import TcUnify
-import Coercion   ( pprCoAxiom )
+import Coercion   ( pprCoAxiom, isReflCo, mkSymCo, mkSubCo )
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
 import Type
 import TcEvidence
@@ -826,7 +826,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
 
        ; dfun_ev_vars <- newEvVars dfun_theta
 
-       ; sc_ev_vars <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
+       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
+       ; fam_envs <- tcGetFamInstEnvs
+       ; (sc_ids, sc_binds) <- tcSuperClasses fam_envs loc clas inst_tyvars 
+                                              dfun_ev_vars sc_theta' inst_tys
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
@@ -855,8 +858,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
              con_app_tys  = wrapId (mkWpTyApps inst_tys)
                                    (dataConWrapId dict_constr)
-             con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
-             con_app_args = foldl app_to_meth con_app_scs meth_ids
+--              con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
+             con_app_args = foldl app_to_meth con_app_tys (sc_ids ++ meth_ids)
 
              app_to_meth :: HsExpr Id -> Id -> HsExpr Id
              app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
@@ -882,37 +885,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                                   , abs_binds = unitBag dict_bind }
 
        ; return (unitBag (L loc main_bind) `unionBags`
-                 listToBag meth_binds)
+                 listToBag meth_binds      `unionBags`
+                 listToBag sc_binds)
        }
  where
    dfun_id = instanceDFunId ispec
    loc     = getSrcSpan dfun_id
 
-------------------------------
-tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType
-               -> TcM [EvVar]
--- See Note [Silent superclass arguments]
-tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
-  | null inst_tyvars && null dfun_ev_vars
-  = emitWanteds ScOrigin sc_theta
-
-  | otherwise
-  = do {   -- Check that all superclasses can be deduced from
-           -- the originally-specified dfun arguments
-       ; _ <- checkConstraints InstSkol inst_tyvars orig_ev_vars $
-              emitWanteds ScOrigin sc_theta
-
-       ; return (map (find dfun_ev_vars) sc_theta) }
-  where
-    n_silent     = dfunNSilent dfun_id
-    orig_ev_vars = drop n_silent dfun_ev_vars
-
-    find [] pred
-      = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
-    find (ev:evs) pred
-      | pred `eqPred` evVarPred ev = ev
-      | otherwise                  = find evs pred
-
 ----------------------
 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
           -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
@@ -970,15 +949,6 @@ misplacedInstSig name hs_ty
                     2 (dcolon <+> ppr hs_ty))
          , ptext (sLit "(Use InstanceSigs to allow this)") ]
 
-------------------------------
-tcSpecInstPrags :: DFunId -> InstBindings Name
-                -> TcM ([Located TcSpecPrag], PragFun)
-tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
-  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
-                            filter isSpecInstLSig uprags
-             -- The filter removes the pragmas for methods
-       ; return (spec_inst_prags, mkPragFun uprags binds) }
-
 {-
 Note [Instance method signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1009,14 +979,133 @@ call in mkExport.  We have to pass the HsWrapper into
 tcInstanceMethodBody.
 
 
-Note [Silent superclass arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #3731, #4809, #5751, #5913, #6117, which all
+************************************************************************
+*                                                                      *
+      Type-checking superclases
+*                                                                      *
+************************************************************************
+-}
+
+tcSuperClasses :: FamInstEnvs -> SrcSpan
+               -> Class -> [TcTyVar] -> [EvVar]
+               -> TcThetaType -> [TcType]
+               -> TcM ([EvVar], [LHsBind Id])
+-- Make a new top-level function binding for each superclass,
+-- something like
+--    $Ordp0 :: forall a. Ord a => Eq [a]
+--    $Ordp0 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
+--
+-- See Note [Recursive superclasses] for why this is so hard!
+-- In effect, be build a special-purpose solver for the first step
+-- of solving each superclass constraint
+tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
+  = do { traceTc "tcSuperClasses" (ppr cls $$ ppr inst_tys $$ ppr given_cls_preds)
+       ; mapAndUnzipM tc_super (zip sc_theta [0..]) }
+  where
+    head_size = sizeTypes inst_tys
+
+    ------------
+    given_cls_preds :: [(EvTerm, TcType)] -- (ev_term, type of that ev_term)
+    -- given_cls_preds is the list of (ev_term, type) that can be derived
+    -- from the dfun_evs, using the rules (sc1) and (sc3) of
+    -- Note [Recursive superclasses] below
+    -- When solving for superclasses, we search this list
+    given_cls_preds
+      = [ ev_pr | dfun_ev <- dfun_evs
+                , ev_pr <- super_classes (EvId dfun_ev, idType dfun_ev) ]
+
+    ------------
+    super_classes ev_pair
+      | (ev_tm, pred) <- normalise_pr ev_pair
+      , ClassPred cls tys <- classifyPredType pred
+      = (ev_tm, pred) : super_classes_help ev_tm cls tys
+      | otherwise
+      = []
+
+    ------------
+    super_classes_help :: EvTerm -> Class -> [TcType] -> [(EvTerm, TcType)]
+    super_classes_help ev_tm cls tys  -- ev_tm :: cls tys
+      | sizeTypes tys >= head_size  -- Here is where we test for
+      = []                          -- a smaller dictionary
+      | otherwise
+      = concatMap super_classes ([EvSuperClass ev_tm i | i <- [0..]]
+                                 `zip` immSuperClasses cls tys)
+
+    ------------
+    normalise_pr :: (EvTerm, TcPredType) -> (EvTerm, TcPredType)
+    -- Normalise type functions as much as possible
+    normalise_pr (ev_tm, pred)
+      | isReflCo norm_co = (ev_tm,                pred)
+      | otherwise        = (mkEvCast ev_tm tc_co, norm_pred)
+      where
+        (norm_co, norm_pred) = normaliseType fam_envs Nominal pred
+        tc_co = TcCoercion (mkSubCo norm_co)
+
+    ------------
+    tc_super (sc_pred, n)
+      = do { (ev_binds, sc_ev_id) <- checkScConstraints InstSkol tyvars dfun_evs $
+                                     emit_sc_pred fam_envs sc_pred
+
+           ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
+           ; let sc_top_ty = mkForAllTys tyvars (mkPiTypes dfun_evs sc_pred)
+                 sc_top_id = mkLocalId sc_top_name sc_top_ty
+                 export = ABE { abe_wrap = idHsWrapper, abe_poly = sc_top_id
+                              , abe_mono = sc_ev_id
+                              , abe_prags = SpecPrags [] }
+                 bind = AbsBinds { abs_tvs      = tyvars
+                                 , abs_ev_vars  = dfun_evs
+                                 , abs_exports  = [export]
+                                 , abs_ev_binds = ev_binds
+                                 , abs_binds    = emptyBag }
+           ; return (sc_top_id, L loc bind) }
+
+    -------------------
+    emit_sc_pred fam_envs sc_pred ev_binds
+      | (sc_co, norm_sc_pred) <- normaliseType fam_envs Nominal sc_pred
+                                 -- sc_co :: sc_pred ~ norm_sc_pred
+      , ClassPred cls tys <- classifyPredType norm_sc_pred
+      = do { (ok, sc_ev_tm) <- emit_sc_cls_pred norm_sc_pred cls tys
+           ; sc_ev_id <- newEvVar sc_pred
+           ; let tc_co = TcCoercion (mkSubCo (mkSymCo sc_co))
+           ; addTcEvBind ev_binds sc_ev_id (mkEvCast sc_ev_tm tc_co)
+           ; return (ok, sc_ev_id) }
+
+      | otherwise
+      = do { sc_ev_id <- emitWanted ScOrigin sc_pred
+           ; traceTc "tcSuperClass 4" (ppr sc_pred $$ ppr sc_ev_id)
+           ; return (True, sc_ev_id) }
+
+    -------------------
+    emit_sc_cls_pred sc_pred cls tys
+      | (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds
+                             , ev_ty `tcEqType` sc_pred ]
+      = do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm)
+           ; return (True, ev_tm) }
+
+      | otherwise
+      = do { inst_envs <- tcGetInstEnvs
+           ; case lookupInstEnv inst_envs cls tys of
+               ([(ispec, dfun_inst_tys)], [], _) -- A single match
+                 -> do { let dfun_id = instanceDFunId ispec
+                       ; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys
+                       ; arg_evs  <- emitWanteds ScOrigin inst_theta
+                       ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs)
+                       ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app)
+                       ; return (True, dict_app) }
+
+               _ -> do { sc_ev_id <- emitWanted ScOrigin sc_pred
+                       ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev_id)
+                       ; return (False, EvId sc_ev_id) } }
+
+
+{-
+Note [Recursive superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
 describe somewhat more complicated situations, but ones
 encountered in practice.
 
-      THE PROBLEM
-
+----- THE PROBLEM --------
 The problem is that it is all too easy to create a class whose
 superclass is bottom when it should not be.
 
@@ -1044,7 +1133,84 @@ The instance we want is:
        dfunD :: forall a. D [a] -> D [a]
        dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
 
-      THE SOLUTION
+----- THE SOLUTION --------
+The basic solution is simple: be very careful about using superclass
+selection to generate a superclass witness in a dictionary function
+definition.  More precisely:
+
+  Superclass Invariant: in every class dictionary,
+                        every superclass dictionary field
+                        is non-bottom
+
+To achieve the Superclass Invariant, in a dfun definition we can
+generate a guaranteed-non-bottom superclass witness from:
+  (sc1) one of the dictionary arguments itself (all non-bottom)
+  (sc2) a call of a dfun (always returns a dictionary constructor)
+  (sc3) an immediate superclass of a smaller dictionary
+
+The tricky case is (sc3).  We proceed by induction on the size of
+the (type of) the dictionary, defined by TcValidity.sizePred.
+Let's suppose we are building a dictionary of size 3, and
+suppose the Superclass Invariant holds of smaller dictionaries.
+Then if we have a smaller dictionary, its immediate superclasses
+will be non-bottom by induction.
+
+What does "we have a smaller dictionary" mean?  It might be
+one of the arguments of the instance, or one of its superclasses.
+Here is an example, taken from CmmExpr:
+       class Ord r => UserOfRegs r a where ...
+(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where
+(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+
+For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
+since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
+
+But for (i2) that isn't the case, so we must add an explicit, and
+perhaps surprising, (Ord r) argument to the instance declaration.
+
+Here's another example from Trac #6161:
+
+       class       Super a => Duper a  where ...
+       class Duper (Fam a) => Foo a    where ...
+(i3)   instance Foo a => Duper (Fam a) where ...
+(i4)   instance              Foo Float where ...
+
+It would be horribly wrong to define
+   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)
+   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
+
+   dfFooFloat :: Foo Float               -- from (i4)
+   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
+
+Now the Super superclass of Duper is definitely bottom!
+
+This won't happen because when processing (i3) we can use the
+superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But
+that is *not* smaller than the target so we can't take *its*
+superclasses.  As a result the program is rightly rejected, unless you
+add (Super (Fam a)) to the context of (i3).
+
+
+
+Note [Silent superclass arguments] (historical interest)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB1: this note describes our *old* solution to the
+     recursive-superclass problem. I'm keeping the Note
+     for now, just as institutional memory.
+     However, the code for silent superclass arguments
+     was removed in late Dec 2014
+
+NB2: the silent-superclass solution introduced new problems
+     of its own, in the form of instance overlap.  Tests
+     SilentParametersOverlapping, T5051, and T7862 are examples
+
+NB3: the silent-superclass solution also generated tons of
+     extra dictionaries.  For example, in monad-transformer
+     code, when constructing a Monad dictionary you had to pass
+     an Applicative dictionary; and to construct that you neede
+     a Functor dictionary. Yet these extra dictionaries were
+     often never used.  Test T3064 compiled *far* faster after
+     silent superclasses were eliminated.
 
 Our solution to this problem "silent superclass arguments".  We pass
 to each dfun some ``silent superclass arguments’’, which are the
@@ -1080,16 +1246,12 @@ that were in the original instance declaration.
 DFun types are built (only) by MkId.mkDictFunId, so that is where we
 decide what silent arguments are to be added.
 
-In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
-    dw := dfun d1 d2
-    [Wanted] (d1 :: C [a])
-    [Wanted] (d2 :: D [a])
 
-And now, though we *can* solve:
-     d2 := dw
-That's fine; and we solve d1:C[a] separately.
-
-Test case SCLoop tests this fix.
+************************************************************************
+*                                                                      *
+        Specialise instance pragmas
+*                                                                      *
+************************************************************************
 
 Note [SPECIALISE instance pragmas]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1150,12 +1312,20 @@ Note that
     just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
 -}
 
+tcSpecInstPrags :: DFunId -> InstBindings Name
+                -> TcM ([Located TcSpecPrag], PragFun)
+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+             -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragFun uprags binds) }
+
+------------------------------
 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
   = addErrCtxt (spec_ctxt prag) $
     do  { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
-        ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
-
+        ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
         ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty
         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
   where
index c67e437..41f508d 100644 (file)
@@ -13,7 +13,7 @@ import TcFlatten
 import VarSet
 import Type
 import Unify
-import InstEnv( lookupInstEnv, instanceDFunId )
+import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
 import CoAxiom(sfInteractTop, sfInteractInert)
 
 import Var
@@ -2030,20 +2030,16 @@ matchClassInst inerts clas tys loc
    where
      pred = mkClassPred clas tys
 
-     match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult
+     match_one :: DFunId -> [DFunInstType] -> TcS LookupInstResult
                   -- See Note [DFunInstType: instantiating types] in InstEnv
      match_one dfun_id mb_inst_tys
        = do { checkWellStagedDFun pred dfun_id loc
-            ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
-            ; let (theta, _) = tcSplitPhiTy dfun_phi
-            ; if null theta then
-                  return (GenInst [] (EvDFunApp dfun_id tys []))
-              else do
-            { evc_vars <- instDFunConstraints loc theta
+            ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+            ; evc_vars <- mapM (newWantedEvVar loc) theta
             ; let new_ev_vars = freshGoals evc_vars
                       -- new_ev_vars are only the real new variables that can be emitted
                   dfun_app = EvDFunApp dfun_id tys (map (ctEvTerm . fst) evc_vars)
-            ; return $ GenInst new_ev_vars dfun_app } }
+            ; return $ GenInst new_ev_vars dfun_app }
 
      givens_for_this_clas :: Cts
      givens_for_this_clas
index 90e0762..d740f7c 100644 (file)
@@ -34,7 +34,7 @@ module TcMType (
 
   --------------------------------
   -- Instantiation
-  tcInstTyVars, newSigTyVar,
+  tcInstTyVars, tcInstTyVarX, newSigTyVar,
   tcInstType,
   tcInstSkolTyVars, tcInstSuperSkolTyVarsX,
   tcInstSigTyVarsLoc, tcInstSigTyVars,
index 4c9ab2f..a04bf9f 100644 (file)
@@ -31,7 +31,6 @@ module TcSMonad (
     setEvBind,
     newEvVar, newGivenEvVar, newGivenEvVars,
     newDerived, emitNewDerived,
-    instDFunConstraints,
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
@@ -93,7 +92,7 @@ module TcSMonad (
 
 import HscTypes
 
-import Inst
+import qualified Inst as TcM
 import InstEnv
 import FamInst
 import FamInstEnv
@@ -123,7 +122,6 @@ import UniqSupply
 
 import FastString
 import Util
-import Id
 import TcRnTypes
 
 import Unique
@@ -1405,7 +1403,7 @@ getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 getInstEnvs :: TcS InstEnvs
-getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
 
 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
@@ -1556,24 +1554,9 @@ extendFlatCache tc xi_args stuff
 -- Instantiations
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcType)
-instDFunType dfun_id mb_inst_tys
-  = wrapTcS $ go dfun_tvs mb_inst_tys (mkTopTvSubst [])
-  where
-    (dfun_tvs, dfun_phi) = tcSplitForAllTys (idType dfun_id)
-
-    go :: [TyVar] -> [DFunInstType] -> TvSubst -> TcM ([TcType], TcType)
-    go [] [] subst = return ([], substTy subst dfun_phi)
-    go (tv:tvs) (Just ty : mb_tys) subst
-      = do { (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty)
-           ; return (ty : tys, phi) }
-    go (tv:tvs) (Nothing : mb_tys) subst
-      = do { ty <- instFlexiTcSHelper (tyVarName tv) (substTy subst (tyVarKind tv))
-                         -- Don't forget to instantiate the kind!
-                         -- cf TcMType.tcInstTyVarX
-           ; (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty)
-           ; return (ty : tys, phi) }
-    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys)
+instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)
+instDFunType dfun_id inst_tys
+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys
 
 newFlexiTcSTy :: Kind -> TcS TcType
 newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
@@ -1734,9 +1717,6 @@ newDerived loc pred
                     Just {} -> Nothing
                     Nothing -> Just (CtDerived { ctev_pred = pred, ctev_loc = loc })) }
 
-instDFunConstraints :: CtLoc -> TcThetaType -> TcS [(CtEvidence, Freshness)]
-instDFunConstraints loc = mapM (newWantedEvVar loc)
-
 
 matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
 matchFam tycon args = wrapTcS $ matchFamTcM tycon args
index 776cb63..617a6fc 100644 (file)
@@ -1352,7 +1352,7 @@ reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
                               -- variables, not *kind* variables
                    -> ClsInst -> TcM TH.Dec
 reifyClassInstance is_poly_tvs i
-  = do { cxt <- reifyCxt (drop n_silent theta)
+  = do { cxt <- reifyCxt theta
        ; let types_only = filterOut isKind types
        ; thtypes <- reifyTypes types_only
        ; annot_thtypes <- zipWith3M annotThType is_poly_tvs types_only thtypes
@@ -1360,8 +1360,7 @@ reifyClassInstance is_poly_tvs i
        ; return $ (TH.InstanceD cxt head_ty []) }
   where
      (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
-     dfun     = instanceDFunId i
-     n_silent = dfunNSilent dfun
+     dfun = instanceDFunId i
 
 ------------------------------
 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
index 5d8ef5d..21e81db 100644 (file)
@@ -12,7 +12,7 @@ module TcUnify (
   -- Full-blown subsumption
   tcWrapResult, tcGen,
   tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
-  checkConstraints, newImplication,
+  checkConstraints, checkScConstraints,
 
   -- Various unifications
   unifyType, unifyTypeList, unifyTheta,
@@ -565,12 +565,6 @@ checkConstraints skol_info skol_tvs given thing_inside
       -- tcPolyExpr, which uses tcGen and hence checkConstraints.
 
   | otherwise
-  = newImplication skol_info skol_tvs given thing_inside
-
-newImplication :: SkolemInfo -> [TcTyVar]
-               -> [EvVar] -> TcM result
-               -> TcM (TcEvBinds, result)
-newImplication skol_info skol_tvs given thing_inside
   = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
     ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
     do { ((result, tclvl), wanted) <- captureConstraints  $
@@ -599,6 +593,35 @@ newImplication skol_info skol_tvs given thing_inside
 
        ; return (TcEvBinds ev_binds_var, result) } }
 
+checkScConstraints :: SkolemInfo
+                   -> [TcTyVar]           -- Skolems
+                   -> [EvVar]             -- Given
+                   -> (EvBindsVar -> TcM (Bool, result))
+                   -> TcM (TcEvBinds, result)
+
+-- Like checkConstraints, but the thing_inside 
+-- can generate its own evidence bindings
+checkScConstraints skol_info skol_tvs given thing_inside
+  = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
+    ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
+    do { ev_binds_var <- newTcEvBinds
+       ; (((ok, result), tclvl), wanted) <- captureConstraints  $
+                                            captureTcLevel $
+                                            thing_inside ev_binds_var
+
+       ; env <- getLclEnv
+       ; emitImplication $ Implic { ic_tclvl  = tclvl
+                                  , ic_skols  = skol_tvs
+                                  , ic_no_eqs = False
+                                  , ic_given  = if ok then given else []
+                                  , ic_wanted = wanted
+                                  , ic_insol  = insolubleWC wanted
+                                  , ic_binds  = ev_binds_var
+                                  , ic_env    = env
+                                  , ic_info   = skol_info }
+
+       ; return (TcEvBinds ev_binds_var, result) }
+
 {-
 ************************************************************************
 *                                                                      *
index ca8b63a..5078ede 100644 (file)
@@ -11,7 +11,7 @@ module TcValidity (
   checkValidTheta, checkValidFamPats,
   checkValidInstance, validDerivPred,
   checkInstTermination, checkValidTyFamInst, checkTyFamFreeness,
-  checkConsistentFamInst,
+  checkConsistentFamInst, sizeTypes,
   arityErr, badATErr
   ) where
 
@@ -883,7 +883,7 @@ validDerivPred tv_set pred
        _                     -> True   -- Non-class predicates are ok
   where
     check_tys tys = hasNoDups fvs
-                    && sizeTypes tys == length fvs
+                    && sizeTypes tys == fromIntegral (length fvs)
                     && all (`elemVarSet` tv_set) fvs
     fvs = fvType pred
 
@@ -1258,59 +1258,11 @@ smallerAppMsg = ptext (sLit "Application is no smaller than the instance head")
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Auxiliary functions}
+        The "Paterson size" of a type
 *                                                                      *
 ************************************************************************
 -}
 
--- Free variables of a type, retaining repetitions, and expanding synonyms
-fvType :: Type -> [TyVar]
-fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
-fvType (TyVarTy tv)        = [tv]
-fvType (TyConApp _ tys)    = fvTypes tys
-fvType (LitTy {})          = []
-fvType (FunTy arg res)     = fvType arg ++ fvType res
-fvType (AppTy fun arg)     = fvType fun ++ fvType arg
-fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
-
-fvTypes :: [Type] -> [TyVar]
-fvTypes tys                = concat (map fvType tys)
-
-sizeType :: Type -> Int
--- Size of a type: the number of variables and constructors
-sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
-sizeType (TyVarTy {})      = 1
-sizeType (TyConApp _ tys)  = sizeTypes tys + 1
-sizeType (LitTy {})        = 1
-sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
-sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
-sizeType (ForAllTy _ ty)   = sizeType ty
-
-sizeTypes :: [Type] -> Int
--- IA0_NOTE: Avoid kinds.
-sizeTypes xs = sum (map sizeType tys)
-  where tys = filter (not . isKind) xs
-
--- Size of a predicate
---
--- We are considering whether class constraints terminate.
--- Equality constraints and constraints for the implicit
--- parameter class always termiante so it is safe to say "size 0".
--- (Implicit parameter constraints always terminate because
--- there are no instances for them---they are only solved by
--- "local instances" in expressions).
--- See Trac #4200.
-sizePred :: PredType -> Int
-sizePred ty = goClass ty
-  where
-    goClass p | isIPPred p = 0
-              | otherwise  = go (classifyPredType p)
-
-    go (ClassPred _ tys') = sizeTypes tys'
-    go (EqPred {})        = 0
-    go (TuplePred ts)     = sum (map goClass ts)
-    go (IrredPred ty)     = sizeType ty
-
 {-
 Note [Paterson conditions on PredTypes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1339,3 +1291,86 @@ NB: we don't want to detect PredTypes in sizeType (and then call
 sizePred on them), or we might get an infinite loop if that PredType
 is irreducible. See Trac #5581.
 -}
+
+data TypeSize = TS Int | TSBig   -- TSBig behaves like positive infinity
+                                 -- Used when we encounter a type function
+
+instance Num TypeSize where
+  fromInteger n = TS (fromInteger n)
+  TS a + TS b = TS (a+b)
+  _    + _    = TSBig
+  negate = panic "TypeSize:negate"
+  abs    = panic "TypeSize:abs"
+  signum = panic "TypeSize:signum"
+  (*)    = panic "TypeSize:*"
+  (-)    = panic "TypeSize:-"
+
+instance Eq TypeSize where
+  TS a  == TS b  = a==b
+  TSBig == TSBig = True
+  _     == _     = False
+
+instance Ord TypeSize where
+  TS a  `compare` TS b  = a `compare` b
+  TS _  `compare` TSBig = LT
+  TSBig `compare` TS _  = GT
+  TSBig `compare` TSBig = EQ
+
+sizeType :: Type -> TypeSize
+-- Size of a type: the number of variables and constructors
+sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
+sizeType (TyVarTy {})      = 1
+sizeType (TyConApp tc tys)
+  | isTypeFamilyTyCon tc   = TSBig  -- Type-family applications can
+                                    -- expand to any arbitrary size
+  | otherwise              = sizeTypes tys + 1
+sizeType (LitTy {})        = 1
+sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
+sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
+sizeType (ForAllTy _ ty)   = sizeType ty
+
+sizeTypes :: [Type] -> TypeSize
+-- IA0_NOTE: Avoid kinds.
+sizeTypes xs = sum (map sizeType tys)
+  where tys = filter (not . isKind) xs
+
+-- Note [Size of a predicate]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- We are considering whether class constraints terminate.
+-- Equality constraints and constraints for the implicit
+-- parameter class always termiante so it is safe to say "size 0".
+-- (Implicit parameter constraints always terminate because
+-- there are no instances for them---they are only solved by
+-- "local instances" in expressions).
+-- See Trac #4200.
+sizePred :: PredType -> TypeSize
+sizePred p = go (classifyPredType p)
+  where
+    go (ClassPred cls tys')
+      | isIPClass cls     = 0  -- See Note [Size of a predicate]
+      | otherwise         = sizeTypes tys'
+    go (EqPred {})        = 0  -- See Note [Size of a predicate]
+    go (TuplePred ts)     = sum (map sizePred ts)
+    go (IrredPred ty)     = sizeType ty
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Auxiliary functions}
+*                                                                      *
+************************************************************************
+-}
+
+-- Free variables of a type, retaining repetitions, and expanding synonyms
+fvType :: Type -> [TyVar]
+fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
+fvType (TyVarTy tv)        = [tv]
+fvType (TyConApp _ tys)    = fvTypes tys
+fvType (LitTy {})          = []
+fvType (FunTy arg res)     = fvType arg ++ fvType res
+fvType (AppTy fun arg)     = fvType fun ++ fvType arg
+fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
+
+fvTypes :: [Type] -> [TyVar]
+fvTypes tys                = concat (map fvType tys)
+
index ba49ba3..c5d8953 100644 (file)
@@ -76,9 +76,6 @@ data ClsInst
                 -- (modulo alpha conversion)
 
              , is_dfun :: DFunId -- See Note [Haddock assumptions]
-                    -- See Note [Silent superclass arguments] in TcInstDcls
-                    -- for how to map the DFun's type back to the source
-                    -- language instance decl
 
              , is_flag :: OverlapFlag   -- See detailed comments with
                                         -- the decl of BasicTypes.OverlapFlag
@@ -187,14 +184,7 @@ pprInstance ispec
 pprInstanceHdr :: ClsInst -> SDoc
 -- Prints the ClsInst as an instance declaration
 pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
-  = getPprStyle $ \ sty ->
-    let dfun_ty = idType dfun
-        (tvs, theta, res_ty) = tcSplitSigmaTy dfun_ty
-        theta_to_print = drop (dfunNSilent dfun) theta
-          -- See Note [Silent superclass arguments] in TcInstDcls
-        ty_to_print | debugStyle sty = dfun_ty
-                    | otherwise      = mkSigmaTy tvs theta_to_print res_ty
-    in ptext (sLit "instance") <+> ppr flag <+> pprSigmaType ty_to_print
+  = ptext (sLit "instance") <+> ppr flag <+> pprSigmaType (idType dfun)
 
 pprInstances :: [ClsInst] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
index 9d8e422..11c42d7 100644 (file)
@@ -1,8 +1,8 @@
-
-drvfail002.hs:19:23:
-    No instance for (X T c)
-      arising from the first field of ‘S’ (type ‘T’)
-    Possible fix:
-      use a standalone 'deriving instance' declaration,
-        so you can specify the instance context yourself
-    When deriving the instance for (Show S)
+\r
+drvfail002.hs:19:23:\r
+    No instance for (X T c0)\r
+      arising from the first field of ‘S’ (type ‘T’)\r
+    Possible fix:\r
+      use a standalone 'deriving instance' declaration,\r
+        so you can specify the instance context yourself\r
+    When deriving the instance for (Show S)\r
index 329756a..58ff8f8 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE TypeFamilies, FlexibleContexts #-}
-{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
+{-# LANGUAGE EmptyDataDecls, FlexibleInstances, UndecidableInstances #-}
 
 module InstContextNorm
 where
index 98b99ab..050479b 100644 (file)
@@ -1,5 +1,8 @@
 {-# LANGUAGE TypeFamilies, FlexibleContexts #-}
 
+-- This used to fail because of the silent-superclass
+-- mechanism, but now it succeeds as it should
+
 module T7862 where
 
 type family Scalar t
@@ -11,7 +14,7 @@ type instance Scalar (Tower s a) = a
 class (Num (Scalar t), Num t) => Mode t where
     (<+>) :: t -> t -> t
 
-instance (Num a) => Mode (Tower s a) where
+instance Num a => Mode (Tower s a) where
     Tower as <+> _ = undefined
       where
         _ = (Tower as) <+> (Tower as)
index c2583d8..3521aea 100644 (file)
@@ -1,17 +1,7 @@
 
-T7862.hs:17:24:
-    Overlapping instances for Num (Tower s0 a)
-      arising from a use of ‘<+>’
-    Matching givens (or their superclasses):
-      (Num (Tower s a))
-        bound by the instance declaration at T7862.hs:14:10-36
-    Matching instances:
-      instance Num a => Num (Tower s a) -- Defined at T7862.hs:19:10
-    (The choice depends on the instantiation of ‘a, s0’)
-    In the expression: (Tower as) <+> (Tower as)
-    In a pattern binding: _ = (Tower as) <+> (Tower as)
-    In an equation for ‘<+>’:
-        (Tower as) <+> _
-          = undefined
-          where
-              _ = (Tower as) <+> (Tower as)
+T7862.hs:22:10: Warning:
+    No explicit implementation for
+      ‘+’, ‘*’, ‘abs’, ‘signum’, ‘fromInteger’, and (either ‘negate’
+                                                            or
+                                                            ‘-’)
+    In the instance declaration for ‘Num (Tower s a)’
index a52e621..5f65a7a 100644 (file)
@@ -130,7 +130,7 @@ test('T9433', normal, compile_fail, [''])
 test('BadSock', normal, compile_fail, [''])
 test('T9580', normal, multimod_compile_fail, ['T9580', ''])
 test('T9662', normal, compile_fail, [''])
-test('T7862', normal, compile_fail, [''])
+test('T7862', normal, compile, [''])
 test('T9896', normal, compile_fail, [''])
 test('T6088', normal, compile_fail, [''])
 
index ce48c11..fab62c0 100644 (file)
@@ -239,7 +239,7 @@ test('T3064',
             # expected value: 14 (x86/Linux 28-06-2012):
             # 2013-11-13:     18 (x86/Windows, 64bit machine)
             # 2014-01-22:     23 (x86/Linux)
-           (wordsize(64), 38, 20)]),
+           (wordsize(64), 27, 20)]),
             # (amd64/Linux):            18
             # (amd64/Linux) 2012-02-07: 26
             # (amd64/Linux) 2013-02-12: 23; increased range to 10%
@@ -250,6 +250,7 @@ test('T3064',
             # (amd64/Linux) 2013-09-11: 37; better arity analysis (weird)
             # (amd64/Linux) (09/09/2014): 42, AMP changes (larger interfaces, more loading)
             # (amd64/Linux) 2014-10-13: 38: Stricter seqDmdType
+            # (amd64/Linux) 2014-12-22: 27: death to silent superclasses
 
       compiler_stats_num_field('bytes allocated',
           [(wordsize(32), 188697088, 10),
@@ -259,7 +260,7 @@ test('T3064',
             # 2014-01-22: 162457940 (x86/Linux)
             # 2014-12-01: 162457940 (Windows)
 
-           (wordsize(64), 350418600, 5)]),
+           (wordsize(64), 243670824, 5)]),
             # (amd64/Linux) (28/06/2011):  73259544
             # (amd64/Linux) (07/02/2013): 224798696
             # (amd64/Linux) (02/08/2013): 236404384, increase from roles
@@ -274,6 +275,8 @@ test('T3064',
             # (amd64/Linux) (14/09/2014): 385145080, BPP changes (more NoImplicitPrelude in base)
             # (amd64/Linux) (10/12/2014): 363103840, improvements in constraint solver
             # (Mac)         (18/12/2014): 350418600, improvements to flattener
+            # (amd64/Linux) (22/12/2014): 243670824, Ha! Death to superclass constraints, makes
+            #                                        much less code for Monad instances
 
 ###################################
 # deactivated for now, as this metric became too volatile recently
index d7ac756..db81be5 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module Simpl020_A where
 
 class GUIValue a
@@ -16,7 +17,7 @@ class HasSize w => HasGeometry w where
 
 class GUIObject w => Window w where
 
-instance Window w => HasSize w where
+instance (GUIObject w, Window w) => HasSize w where
   width w = geometry w
 
 instance Window w => HasGeometry w where
index 6dcc1bb..23ada00 100644 (file)
@@ -1,40 +1,77 @@
-Rule fired: Class op pure
-Rule fired: Class op <*>
-Rule fired: Class op <*>
-Rule fired: SPEC map2
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <*>
-Rule fired: Class op fmap
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op fmap
-Rule fired: Class op fmap
-Rule fired: SPEC $cfmap @ 'Z
-Rule fired: SPEC $c<$ @ 'Z
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: Class op fmap
-Rule fired: Class op fmap
-Rule fired: SPEC $c<$ @ 'Z
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: Class op fmap
-Rule fired: Class op fmap
+Rule fired: Class op pure\r
+Rule fired: Class op <*>\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC map2\r
+Rule fired: Class op fmap\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: Class op fmap\r
+Rule fired: Class op fmap\r
+Rule fired: SPEC $cfmap @ 'Z\r
+Rule fired: SPEC $c<$ @ 'Z\r
+Rule fired: SPEC $fFunctorShape @ 'Z\r
+Rule fired: Class op fmap\r
+Rule fired: Class op fmap\r
+Rule fired: SPEC $c<$ @ 'Z\r
+Rule fired: SPEC $fFunctorShape @ 'Z\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: SPEC $fFunctorShape @ 'Z\r
+Rule fired: SPEC $cp0Applicative @ 'Z\r
+Rule fired: SPEC $cpure @ 'Z\r
+Rule fired: SPEC $c<*> @ 'Z\r
+Rule fired: SPEC $c*> @ 'Z\r
+Rule fired: SPEC $c<* @ 'Z\r
+Rule fired: SPEC $fApplicativeShape @ 'Z\r
+Rule fired: SPEC $fApplicativeShape @ 'Z\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC $c<* @ 'Z\r
+Rule fired: SPEC $c*> @ 'Z\r
+Rule fired: SPEC $fApplicativeShape @ 'Z\r
+Rule fired: SPEC $fApplicativeShape @ 'Z\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op fmap\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC $fApplicativeShape @ 'Z\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: Class op $p1Applicative\r
+Rule fired: Class op <$\r
+Rule fired: Class op <*>\r
+Rule fired: SPEC $fFunctorShape @ 'Z\r
+Rule fired: Class op fmap\r
+Rule fired: Class op fmap\r
index bbdadbf..2ce58ec 100644 (file)
@@ -22,7 +22,7 @@ test('simpl019', normal, compile, [''])
 test('simpl020',
      extra_clean(['Simpl020_A.hi', 'Simpl020_A.o']),
      multimod_compile,
-     ['simpl020', '-v0 -XFlexibleInstances -XUndecidableInstances'])
+     ['simpl020', '-v0'])
 
 test('simpl-T1370', normal, compile, [''])
 test('T2520', normal, compile, [''])
index 22b40f8..fbf8da1 100644 (file)
@@ -1,5 +1,5 @@
-
-Simpl020_A.hs:25:10: Warning:
-    No explicit implementation for
-      ‘toGUIObject’ and ‘cset’
-    In the instance declaration for ‘GUIObject ()’
+\r
+Simpl020_A.hs:26:10: Warning:\r
+    No explicit implementation for\r
+      ‘toGUIObject’ and ‘cset’\r
+    In the instance declaration for ‘GUIObject ()’\r
diff --git a/testsuite/tests/typecheck/should_fail/SilentParametersOverlapping.stderr b/testsuite/tests/typecheck/should_fail/SilentParametersOverlapping.stderr
deleted file mode 100644 (file)
index 62d1c78..0000000
+++ /dev/null
@@ -1,13 +0,0 @@
-
-SilentParametersOverlapping.hs:15:9:
-    Overlapping instances for C [(t0, t1)] arising from a use of ‘c’
-    Matching givens (or their superclasses):
-      (C [(a, b)])
-        bound by the instance declaration
-        at SilentParametersOverlapping.hs:14:37-45
-    Matching instances:
-      instance C [a] -- Defined at SilentParametersOverlapping.hs:11:10
-    (The choice depends on the instantiation of ‘t0, t1’)
-    In the expression: c [(undefined, undefined)]
-    In an equation for ‘b’: b x = c [(undefined, undefined)]
-    In the instance declaration for ‘B [(a, b)]’
index e3278d8..31a841d 100644 (file)
@@ -32,3 +32,5 @@ foo x = x >= x
 -- and if we have Ord a (which we do) we should be done.
 -- A very good reason for not having silent parameters!
 -- But, alas, we need them!
+--
+-- Dec 14: now we don't have them any more, the test passes!
index 3fc46f9..c436ab0 100644 (file)
@@ -1,11 +1,5 @@
-
-T5051.hs:11:11:
-    Overlapping instances for Eq [a] arising from a use of ‘>=’
-    Matching instances:
-      instance Eq a => Eq [a] -- Defined in ‘GHC.Classes’
-      instance [overlapping] Eq [T] -- Defined at T5051.hs:8:30
-    (The choice depends on the instantiation of ‘a’
-     To pick the first instance above, use IncoherentInstances
-     when compiling the other instance declarations)
-    In the expression: x >= x
-    In an equation for ‘foo’: foo x = x >= x
+\r
+T5051.hs:8:30: Warning:\r
+    No explicit implementation for\r
+      either ‘==’ or ‘/=’\r
+    In the instance declaration for ‘Eq [T]’\r
index e4151c1..b5bf71d 100644 (file)
@@ -1,17 +1,27 @@
-
-T5691.hs:14:9:
-    Couldn't match type ‘p’ with ‘PrintRuleInterp’
-    Expected type: p a
-      Actual type: PrintRuleInterp a
-    When checking that the pattern signature: p a
-      fits the type of its context: PrintRuleInterp a
-    In the pattern: f :: p a
-    In an equation for ‘test’: test (f :: p a) = MkPRI $ printRule_ f
-
-T5691.hs:15:24:
-    Couldn't match type ‘p’ with ‘PrintRuleInterp’
-    Expected type: PrintRuleInterp a
-      Actual type: p a
-    Relevant bindings include f :: p a (bound at T5691.hs:14:9)
-    In the first argument of ‘printRule_’, namely ‘f’
-    In the second argument of ‘($)’, namely ‘printRule_ f’
+\r
+T5691.hs:14:9:\r
+    Couldn't match type ‘p’ with ‘PrintRuleInterp’\r
+    Expected type: p a\r
+      Actual type: PrintRuleInterp a\r
+    When checking that the pattern signature: p a\r
+      fits the type of its context: PrintRuleInterp a\r
+    In the pattern: f :: p a\r
+    In an equation for ‘test’: test (f :: p a) = MkPRI $ printRule_ f\r
+\r
+T5691.hs:15:24:\r
+    Couldn't match type ‘p’ with ‘PrintRuleInterp’\r
+    Expected type: PrintRuleInterp a\r
+      Actual type: p a\r
+    Relevant bindings include f :: p a (bound at T5691.hs:14:9)\r
+    In the first argument of ‘printRule_’, namely ‘f’\r
+    In the second argument of ‘($)’, namely ‘printRule_ f’\r
+\r
+T5691.hs:24:10:\r
+    No instance for (Alternative RecDecParser)\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘MonadPlus RecDecParser’\r
+\r
+T5691.hs:24:10:\r
+    No instance for (Monad RecDecParser)\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘MonadPlus RecDecParser’\r
index 1f19e67..c0fa67b 100644 (file)
@@ -27,3 +27,22 @@ instance Foo Float where
 
 testProg :: Float
 testProg = testDup (FamFloat 3.0)
+
+{- Reasoning:
+
+dfDuperFam :: Foo a -> Duper (Fam a)
+dfDuperFam d = Duper (sc (sc d)) (...testDup...)
+
+dfFooFloat :: Foo Float
+dfFooFloat = Foo (dfDuperFloat dx) ...
+
+dx :: Foo Float
+dx = dfFooFloat
+
+
+[W] d1 :: Duper (Fam Float)
+
+    -- Use Duper instnance
+    d1 = dfDuperFam d2
+[W] d2 :: Foo Float
+-}
\ No newline at end of file
index 0d10738..78e1626 100644 (file)
@@ -1,5 +1,5 @@
-
-T6161.hs:29:12:
-    No instance for (Super (Fam Float)) arising from a use of ‘testDup’
-    In the expression: testDup (FamFloat 3.0)
-    In an equation for ‘testProg’: testProg = testDup (FamFloat 3.0)
+\r
+T6161.hs:19:10:\r
+    No instance for (Super (Fam a))\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘Duper (Fam a)’\r
index 4e79b01..8e39968 100644 (file)
@@ -1,25 +1,30 @@
-
-T8603.hs:29:17:
-    Couldn't match kind ‘* -> *’ with ‘*’
-    When matching types
-      t1 :: (* -> *) -> * -> *
-      (->) :: * -> * -> *
-    Expected type: [Integer] -> StateT s RV t0
-      Actual type: t1 ((->) [a0]) (StateT s RV t0)
-    The function ‘lift’ is applied to two arguments,
-    but its type ‘([a0] -> StateT s RV t0)
-                  -> t1 ((->) [a0]) (StateT s RV t0)’
-    has only one
-    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]
-    In the expression:
-      do { prize <- lift uniform [1, 2, ....];
-           return False }
-
-T8603.hs:29:22:
-    Couldn't match type ‘RV a0’ with ‘StateT s RV t0’
-    Expected type: [a0] -> StateT s RV t0
-      Actual type: [a0] -> RV a0
-    Relevant bindings include
-      testRVState1 :: RVState s Bool (bound at T8603.hs:28:1)
-    In the first argument of ‘lift’, namely ‘uniform’
-    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]
+\r
+T8603.hs:13:10:\r
+    No instance for (Applicative RV)\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘Monad RV’\r
+\r
+T8603.hs:29:17:\r
+    Couldn't match kind ‘* -> *’ with ‘*’\r
+    When matching types\r
+      t1 :: (* -> *) -> * -> *\r
+      (->) :: * -> * -> *\r
+    Expected type: [Integer] -> StateT s RV t0\r
+      Actual type: t1 ((->) [a0]) (StateT s RV t0)\r
+    The function ‘lift’ is applied to two arguments,\r
+    but its type ‘([a0] -> StateT s RV t0)\r
+                  -> t1 ((->) [a0]) (StateT s RV t0)’\r
+    has only one\r
+    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]\r
+    In the expression:\r
+      do { prize <- lift uniform [1, 2, ....];\r
+           return False }\r
+\r
+T8603.hs:29:22:\r
+    Couldn't match type ‘RV a0’ with ‘StateT s RV t0’\r
+    Expected type: [a0] -> StateT s RV t0\r
+      Actual type: [a0] -> RV a0\r
+    Relevant bindings include\r
+      testRVState1 :: RVState s Bool (bound at T8603.hs:28:1)\r
+    In the first argument of ‘lift’, namely ‘uniform’\r
+    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]\r
index 27dbef9..60c7097 100644 (file)
@@ -247,10 +247,10 @@ test('tcfail220', normal, multimod_compile_fail, ['tcfail220.hsig', '-sig-of bas
 test('tcfail221', normal, multimod_compile_fail, ['tcfail221.hsig', '-sig-of base:Prelude'])
 test('tcfail222', normal, multimod_compile_fail, ['tcfail222.hsig', '-sig-of base:Data.STRef'])
 
-test('SilentParametersOverlapping', normal, compile_fail, [''])
+test('SilentParametersOverlapping', normal, compile, [''])
 test('FailDueToGivenOverlapping', normal, compile_fail, [''])
 test('LongWayOverlapping', normal, compile_fail, [''])
-test('T5051', normal, compile_fail, [''])
+test('T5051', normal, compile, [''])
 test('T5236',normal,compile_fail,[''])
 test('T5246',normal,compile_fail,[''])
 test('T5300',normal,compile_fail,[''])
index 87befa8..ce7613a 100644 (file)
@@ -1,7 +1,5 @@
-
-tcfail017.hs:10:10:
-    Could not deduce (C [a])
-      arising from the superclasses of an instance declaration
-    from the context (B a)
-      bound by the instance declaration at tcfail017.hs:10:10-23
-    In the instance declaration for ‘B [a]’
+\r
+tcfail017.hs:10:10:\r
+    No instance for (C [a])\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘B [a]’\r
index 70b38be..2e3b7f1 100644 (file)
@@ -1,5 +1,10 @@
-
-tcfail019.hs:18:10:
-    No instance for (C [a])
-      arising from the superclasses of an instance declaration
-    In the instance declaration for ‘D [a]’
+\r
+tcfail019.hs:18:10:\r
+    No instance for (B [a])\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘D [a]’\r
+\r
+tcfail019.hs:18:10:\r
+    No instance for (C [a])\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘D [a]’\r
index 4600f20..c55d1b5 100644 (file)
@@ -1,7 +1,5 @@
-
-tcfail020.hs:10:10:
-    Could not deduce (A [a])
-      arising from the superclasses of an instance declaration
-    from the context (A a)
-      bound by the instance declaration at tcfail020.hs:10:10-23
-    In the instance declaration for ‘B [a]’
+\r
+tcfail020.hs:10:10:\r
+    No instance for (A [a])\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘B [a]’\r
index 584d189..12e0ea6 100644 (file)
@@ -1,9 +1,24 @@
-
-tcfail042.hs:15:10:
-    Could not deduce (Num a)
-      arising from the superclasses of an instance declaration
-    from the context (Eq a, Show a)
-      bound by the instance declaration at tcfail042.hs:15:10-34
-    Possible fix:
-      add (Num a) to the context of the instance declaration
-    In the instance declaration for ‘Bar [a]’
+\r
+tcfail042.hs:15:10:\r
+    Could not deduce (Num a)\r
+      arising from the superclasses of an instance declaration\r
+    from the context (Eq a, Show a)\r
+      bound by the instance declaration at tcfail042.hs:15:10-34\r
+    Possible fix:\r
+      add (Num a) to the context of the instance declaration\r
+    In the instance declaration for ‘Bar [a]’\r
+\r
+tcfail042.hs:17:18:\r
+    Could not deduce (Num a) arising from a use of ‘foo’\r
+    from the context (Eq a, Show a)\r
+      bound by the instance declaration at tcfail042.hs:15:10-34\r
+    Possible fix:\r
+      add (Num a) to the context of the instance declaration\r
+    In the expression: foo xs\r
+    In an equation for ‘bar’:\r
+        bar (x : xs)\r
+          = foo xs\r
+          where\r
+              u = x == x\r
+              v = show x\r
+    In the instance declaration for ‘Bar [a]’\r
index 8d8d1a6..235a781 100644 (file)
@@ -1,5 +1,10 @@
-
-tcfail106.hs:14:10:
-    No instance for (S Int)
-      arising from the superclasses of an instance declaration
-    In the instance declaration for ‘D Int’
+\r
+tcfail106.hs:11:10:\r
+    No instance for (S Int)\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘C Int’\r
+\r
+tcfail106.hs:14:10:\r
+    No instance for (S Int)\r
+      arising from the superclasses of an instance declaration\r
+    In the instance declaration for ‘D Int’\r
index 45acead..56b9e6b 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 45acead293f9fc18e984d2e83d137809359d506d
+Subproject commit 56b9e6bcef33612b40d3f93f170397eff77411eb