Revamp Backpack/hs-boot handling of type class signatures.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 5 Jan 2017 21:52:12 +0000 (13:52 -0800)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Wed, 11 Jan 2017 14:54:00 +0000 (06:54 -0800)
Summary:
A basket of fixes and improvements:

- The permissible things that one can write in a type
  class definition in an hsig file has been reduced
  to encompass the following things:

    - Methods
    - Default method signatures (but NOT implementation)
    - MINIMAL pragma

  It is no longer necessary nor encouraged to specify
  that a method has a default if it is mentioned in
  a MINIMAL pragma; the MINIMAL pragma is assumed to
  provide the base truth as to what methods need to
  be implemented when writing instances of a type
  class.

- Handling of default method signatures in hsig was
  previously buggy, as these identifiers were not exported,
  so we now treat them similarly to DFuns.

- Default methods are merged, where methods with defaults
  override those without.

- MINIMAL pragmas are merged by ORing together pragmas.

- Matching has been relaxed: a method with a default can
  be used to fill a signature which did not declare the
  method as having a default, and a more relaxed MINIMAL
  pragma can be used (we check if the signature pragma
  implies the final implementation pragma, on the way
  fixing a bug with BooleanFormula.implies, see #13073)

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, bgamari, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2925

GHC Trac Issues: #13041

20 files changed:
compiler/backpack/RnModIface.hs
compiler/basicTypes/OccName.hs
compiler/iface/TcIface.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcRnDriver.hs
compiler/utils/BooleanFormula.hs
testsuite/tests/backpack/should_compile/all.T
testsuite/tests/backpack/should_compile/bkp15.bkp
testsuite/tests/backpack/should_compile/bkp15.stderr
testsuite/tests/backpack/should_compile/bkp46.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp46.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp47.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp47.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/all.T
testsuite/tests/backpack/should_fail/bkpfail39.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail40.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail40.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail41.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail41.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/rnfail055.stderr

index 0a95849..ea3eb54 100644 (file)
@@ -304,10 +304,11 @@ rnIfaceGlobal n = do
                     ]
                 Just n' -> return n'
 
                     ]
                 Just n' -> return n'
 
--- | Rename a DFun name. Here is where we ensure that DFuns have the correct
--- module as described in Note [Bogus DFun renamings].
-rnIfaceDFun :: Name -> ShIfM Name
-rnIfaceDFun name = do
+-- | Rename an implicit name, e.g., a DFun or default method.
+-- Here is where we ensure that DFuns have the correct module as described in
+-- Note [Bogus DFun renamings].
+rnIfaceImplicit :: Name -> ShIfM Name
+rnIfaceImplicit name = do
     hmap <- getHoleSubst
     dflags <- getDynFlags
     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
     hmap <- getHoleSubst
     dflags <- getDynFlags
     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
@@ -385,7 +386,7 @@ rnIfaceClsInst cls_inst = do
     --    mentions DFuns since they are implicitly exported. See
     --    Note [Signature merging DFuns])  The important thing is that it's
     --    consistent everywhere.
     --    mentions DFuns since they are implicitly exported. See
     --    Note [Signature merging DFuns])  The important thing is that it's
     --    consistent everywhere.
-    dfun <- rnIfaceDFun (ifDFun cls_inst)
+    dfun <- rnIfaceImplicit (ifDFun cls_inst)
     return cls_inst { ifInstCls = n
                     , ifInstTys = tys
                     , ifDFun = dfun
     return cls_inst { ifInstCls = n
                     , ifInstTys = tys
                     , ifDFun = dfun
@@ -408,8 +409,10 @@ rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
 rnIfaceDecl :: Rename IfaceDecl
 rnIfaceDecl d@IfaceId{} = do
             name <- case ifIdDetails d of
 rnIfaceDecl :: Rename IfaceDecl
 rnIfaceDecl d@IfaceId{} = do
             name <- case ifIdDetails d of
-                      IfDFunId -> rnIfaceDFun (ifName d)
-                      _        -> rnIfaceGlobal (ifName d)
+                      IfDFunId -> rnIfaceImplicit (ifName d)
+                      _ | isDefaultMethodOcc (occName (ifName d))
+                        -> rnIfaceImplicit (ifName d)
+                        | otherwise -> rnIfaceGlobal (ifName d)
             ty <- rnIfaceType (ifType d)
             details <- rnIfaceIdDetails (ifIdDetails d)
             info <- rnIfaceIdInfo (ifIdInfo d)
             ty <- rnIfaceType (ifType d)
             details <- rnIfaceIdDetails (ifIdDetails d)
             info <- rnIfaceIdInfo (ifIdInfo d)
index 182166e..0de9801 100644 (file)
@@ -57,7 +57,7 @@ module OccName (
         isDerivedOccName,
         mkDataConWrapperOcc, mkWorkerOcc,
         mkMatcherOcc, mkBuilderOcc,
         isDerivedOccName,
         mkDataConWrapperOcc, mkWorkerOcc,
         mkMatcherOcc, mkBuilderOcc,
-        mkDefaultMethodOcc,
+        mkDefaultMethodOcc, isDefaultMethodOcc,
         mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkClassDataConOcc, mkDictOcc, mkIPOcc,
         mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkClassDataConOcc, mkDictOcc, mkIPOcc,
@@ -595,6 +595,12 @@ isDerivedOccName occ =
      c:':':_ | isAlphaNum c -> True   -- E.g.  N:blah   newtype coercions
      _other                 -> False
 
      c:':':_ | isAlphaNum c -> True   -- E.g.  N:blah   newtype coercions
      _other                 -> False
 
+isDefaultMethodOcc :: OccName -> Bool
+isDefaultMethodOcc occ =
+   case occNameString occ of
+     '$':'d':'m':_ -> True
+     _ -> False
+
 mkDataConWrapperOcc, mkWorkerOcc,
         mkMatcherOcc, mkBuilderOcc,
         mkDefaultMethodOcc,
 mkDataConWrapperOcc, mkWorkerOcc,
         mkMatcherOcc, mkBuilderOcc,
         mkDefaultMethodOcc,
index 123b02f..d5cc860 100644 (file)
@@ -71,6 +71,7 @@ import FastString
 import BasicTypes hiding ( SuccessFlag(..) )
 import ListSetOps
 import GHC.Fingerprint
 import BasicTypes hiding ( SuccessFlag(..) )
 import ListSetOps
 import GHC.Fingerprint
+import qualified BooleanFormula as BF
 
 import Data.List
 import Control.Monad
 
 import Data.List
 import Control.Monad
@@ -212,10 +213,23 @@ mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
 mergeIfaceDecl d1 d2
     | isAbstractIfaceDecl d1 = d2
     | isAbstractIfaceDecl d2 = d1
 mergeIfaceDecl d1 d2
     | isAbstractIfaceDecl d1 = d2
     | isAbstractIfaceDecl d2 = d1
+    | IfaceClass{ ifSigs = ops1, ifMinDef = bf1 } <- d1
+    , IfaceClass{ ifSigs = ops2, ifMinDef = bf2 } <- d2
+    = let ops = nameEnvElts $
+                  plusNameEnv_C mergeIfaceClassOp
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
+      in d1 { ifSigs = ops
+            , ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
+            }
     -- It doesn't matter; we'll check for consistency later when
     -- we merge, see 'mergeSignatures'
     | otherwise              = d1
 
     -- It doesn't matter; we'll check for consistency later when
     -- we merge, see 'mergeSignatures'
     | otherwise              = d1
 
+mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
+mergeIfaceClassOp _ op2 = op2
+
 -- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
 mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
 mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
 -- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
 mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
 mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
index c5a4c3a..716aed3 100644 (file)
@@ -29,6 +29,7 @@ import TcMType
 import Type     ( getClassPredTys_maybe, piResultTys )
 import TcType
 import TcRnMonad
 import Type     ( getClassPredTys_maybe, piResultTys )
 import TcType
 import TcRnMonad
+import DriverPhases (HscSource(..))
 import BuildTyCl( TcMethInfo )
 import Class
 import Coercion ( pprCoAxiom )
 import BuildTyCl( TcMethInfo )
 import Class
 import Coercion ( pprCoAxiom )
@@ -95,6 +96,10 @@ Death to "ExpandingDicts".
 ************************************************************************
 -}
 
 ************************************************************************
 -}
 
+illegalHsigDefaultMethod :: Name -> SDoc
+illegalHsigDefaultMethod n =
+    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
+
 tcClassSigs :: Name                -- Name of the class
             -> [LSig Name]
             -> LHsBinds Name
 tcClassSigs :: Name                -- Name of the class
             -> [LSig Name]
             -> LHsBinds Name
@@ -113,9 +118,19 @@ tcClassSigs clas sigs def_methods
                    | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
                    -- Value binding for non class-method (ie no TypeSig)
 
                    | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
                    -- Value binding for non class-method (ie no TypeSig)
 
-       ; sequence_ [ failWithTc (badGenericMethod clas n)
-                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
-                   -- Generic signature without value binding
+       ; tcg_env <- getGblEnv
+       ; if tcg_src tcg_env == HsigFile
+            then
+               -- Error if we have value bindings
+               -- (Generic signatures without value bindings indicate
+               -- that a default of this form is expected to be
+               -- provided.)
+               when (not (null def_methods)) $
+                failWithTc (illegalHsigDefaultMethod clas)
+            else
+               -- Error for each generic signature without value binding
+               sequence_ [ failWithTc (badGenericMethod clas n)
+                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
 
        ; traceTc "tcClassSigs 2" (ppr clas)
        ; return op_info }
 
        ; traceTc "tcClassSigs 2" (ppr clas)
        ; return op_info }
@@ -289,8 +304,12 @@ tcClassMinimalDef _clas sigs op_info
         -- That is, the given mindef should at least ensure that the
         -- class ops without default methods are required, since we
         -- have no way to fill them in otherwise
         -- That is, the given mindef should at least ensure that the
         -- class ops without default methods are required, since we
         -- have no way to fill them in otherwise
-        whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
-                   (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
+        tcg_env <- getGblEnv
+        -- However, only do this test when it's not an hsig file,
+        -- since you can't write a default implementation.
+        when (tcg_src tcg_env /= HsigFile) $
+            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
+                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
         return mindef
   where
     -- By default require all methods without a default implementation
         return mindef
   where
     -- By default require all methods without a default implementation
index a1b559c..4c44eec 100644 (file)
@@ -66,6 +66,7 @@ import TcExpr
 import TcRnMonad
 import TcRnExports
 import TcEvidence
 import TcRnMonad
 import TcRnExports
 import TcEvidence
+import qualified BooleanFormula as BF
 import PprTyThing( pprTyThing )
 import MkIface( tyThingToIfaceDecl )
 import Coercion( pprCoAxiom )
 import PprTyThing( pprTyThing )
 import MkIface( tyThingToIfaceDecl )
 import Coercion( pprCoAxiom )
@@ -905,9 +906,13 @@ checkBootTyCon is_boot tc1 tc2
            check (eqTypeX env op_ty1 op_ty2)
                  (text "The types of" <+> pname1 <+>
                   text "are different") `andThenCheck`
            check (eqTypeX env op_ty1 op_ty2)
                  (text "The types of" <+> pname1 <+>
                   text "are different") `andThenCheck`
-           check (eqMaybeBy eqDM def_meth1 def_meth2)
-                 (text "The default methods associated with" <+> pname1 <+>
-                  text "are different")
+           if is_boot
+               then check (eqMaybeBy eqDM def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are different")
+               else check (subDM op_ty1 def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are not compatible")
          where
           name1 = idName id1
           name2 = idName id2
          where
           name1 = idName id1
           name2 = idName id2
@@ -927,6 +932,26 @@ checkBootTyCon is_boot tc1 tc2
        eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
        eqDM _ _ = False
 
        eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
        eqDM _ _ = False
 
+       -- NB: first argument is from hsig, second is from real impl.
+       -- Order of pattern matching matters.
+       subDM _ Nothing _ = True
+       subDM _ _ Nothing = False
+       -- If the hsig wrote:
+       --
+       --   f :: a -> a
+       --   default f :: a -> a
+       --
+       -- this should be validly implementable using an old-fashioned
+       -- vanilla default method.
+       subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))
+        = eqTypeX env t1 t2
+       -- This case can occur when merging signatures
+       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
+       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+
        -- Ignore the location of the defaults
        eqATDef Nothing             Nothing             = True
        eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
        -- Ignore the location of the defaults
        eqATDef Nothing             Nothing             = True
        eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
@@ -948,7 +973,9 @@ checkBootTyCon is_boot tc1 tc2
     check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
           (text "The class constraints do not match") `andThenCheck`
     checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
     check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
           (text "The class constraints do not match") `andThenCheck`
     checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
-    checkListBy eqAT ats1 ats2 (text "associated types")
+    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`
+    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
+        (text "The MINIMAL pragmas are not compatible")
 
   | Just syn_rhs1 <- synTyConRhs_maybe tc1
   , Just syn_rhs2 <- synTyConRhs_maybe tc2
 
   | Just syn_rhs1 <- synTyConRhs_maybe tc1
   , Just syn_rhs2 <- synTyConRhs_maybe tc2
index 1509321..43a71f0 100644 (file)
@@ -23,6 +23,8 @@ import MonadUtils
 import Outputable
 import Binary
 import SrcLoc
 import Outputable
 import Binary
 import SrcLoc
+import Unique
+import UniqSet
 
 ----------------------------------------------------------------------
 -- Boolean formula type and smart constructors
 
 ----------------------------------------------------------------------
 -- Boolean formula type and smart constructors
@@ -157,11 +159,36 @@ And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs
 Or  xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs
 Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y
 
 Or  xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs
 Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y
 
-implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool
-x `implies` Var y  = x `impliesAtom` y
-x `implies` And ys = all (implies x . unLoc) ys
-x `implies` Or ys  = any (implies x . unLoc) ys
-x `implies` Parens y  = x `implies` (unLoc y)
+implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool
+implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
+  where
+    go :: Uniquable a => Clause a -> Clause a -> Bool
+    go l@Clause{ clauseExprs = hyp:hyps } r =
+        case hyp of
+            Var x | memberClauseAtoms x r -> True
+                  | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r
+            Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps }     r
+            And hyps'  -> go l { clauseExprs = map unLoc hyps' ++ hyps } r
+            Or hyps'   -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps'
+    go l r@Clause{ clauseExprs = con:cons } =
+        case con of
+            Var x | memberClauseAtoms x l -> True
+                  | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons }
+            Parens con' -> go l r { clauseExprs = unLoc con':cons }
+            And cons'   -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons'
+            Or cons'    -> go l r { clauseExprs = map unLoc cons' ++ cons }
+    go _ _ = False
+
+-- A small sequent calculus proof engine.
+data Clause a = Clause {
+        clauseAtoms :: UniqSet a,
+        clauseExprs :: [BooleanFormula a]
+    }
+extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a
+extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x }
+
+memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool
+memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c
 
 ----------------------------------------------------------------------
 -- Pretty printing
 
 ----------------------------------------------------------------------
 -- Pretty printing
index f38e364..3525a85 100644 (file)
@@ -37,3 +37,5 @@ test('bkp42', normal, backpack_compile, [''])
 test('bkp43', normal, backpack_compile, [''])
 test('bkp44', normal, backpack_compile, [''])
 test('bkp45', normal, backpack_compile, [''])
 test('bkp43', normal, backpack_compile, [''])
 test('bkp44', normal, backpack_compile, [''])
 test('bkp45', normal, backpack_compile, [''])
+test('bkp46', normal, backpack_compile, [''])
+test('bkp47', normal, backpack_compile, [''])
index 94678af..c661eaf 100644 (file)
@@ -15,13 +15,9 @@ unit p where
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
-            -- TODO: Putting default definitions in the signature file
-            -- causes references to DFuns, which we choke on. These should
-            -- be disallowed.
-            -- xa = (==)
+            default xa :: a -> a -> Bool
             y :: a -> a -> Ordering
             y :: a -> a -> Ordering
-            -- default y :: Ord a => a -> a -> Ordering
-            -- y = compare
+            default y :: Ord a => a -> a -> Ordering
             {-# MINIMAL xa | y #-}
         -- type instance Elem Int = Bool
         -- pattern Blub n = ("foo", n)
             {-# MINIMAL xa | y #-}
         -- type instance Elem Int = Bool
         -- pattern Blub n = ("foo", n)
@@ -40,10 +36,9 @@ unit q where
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
-            -- xa = (==)
+            default xa :: a -> a -> Bool
             y :: a -> a -> Ordering
             y :: a -> a -> Ordering
-            -- default y :: Ord a => a -> a -> Ordering
-            -- y = compare
+            default y :: Ord a => a -> a -> Ordering
             {-# MINIMAL xa | y #-}
         -- type instance Elem Int = Bool
         -- pattern Blub n = ("foo", n)
             {-# MINIMAL xa | y #-}
         -- type instance Elem Int = Bool
         -- pattern Blub n = ("foo", n)
@@ -76,10 +71,10 @@ unit h-impl where
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
         class Eq a => Bloop a b | a -> b where
             data GMap a (v :: * -> *) :: *
             xa :: a -> a -> Bool
-            -- xa = (==)
+            xa = (==)
             y :: a -> a -> Ordering
             y :: a -> a -> Ordering
-            -- default y :: Ord a => a -> a -> Ordering
-            -- y = compare
+            default y :: Ord a => a -> a -> Ordering
+            y = compare
             {-# MINIMAL xa | y #-}
 unit s where
     dependency r[H=h-impl:H]
             {-# MINIMAL xa | y #-}
 unit s where
     dependency r[H=h-impl:H]
index 041b7fe..904ab2d 100644 (file)
@@ -3,32 +3,14 @@ bkp15.bkp:1:26: warning:
     -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
 [1 of 5] Processing p
   [1 of 1] Compiling H[sig]           ( p/H.hsig, nothing )
     -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
 [1 of 5] Processing p
   [1 of 1] Compiling H[sig]           ( p/H.hsig, nothing )
-
-bkp15.bkp:15:9: warning:
-    • The MINIMAL pragma does not require:
-        ‘xa’ and ‘y’
-      but there is no default implementation.
-    • In the class declaration for ‘Bloop’
 [2 of 5] Processing q
   [1 of 1] Compiling H[sig]           ( q/H.hsig, nothing )
 [2 of 5] Processing q
   [1 of 1] Compiling H[sig]           ( q/H.hsig, nothing )
-
-bkp15.bkp:40:9: warning:
-    • The MINIMAL pragma does not require:
-        ‘xa’ and ‘y’
-      but there is no default implementation.
-    • In the class declaration for ‘Bloop’
 [3 of 5] Processing r
   [1 of 2] Compiling H[sig]           ( r/H.hsig, nothing )
   [2 of 2] Compiling M                ( r/M.hs, nothing )
 [4 of 5] Processing h-impl
   Instantiating h-impl
   [1 of 1] Compiling H                ( h-impl/H.hs, bkp15.out/h-impl/H.o )
 [3 of 5] Processing r
   [1 of 2] Compiling H[sig]           ( r/H.hsig, nothing )
   [2 of 2] Compiling M                ( r/M.hs, nothing )
 [4 of 5] Processing h-impl
   Instantiating h-impl
   [1 of 1] Compiling H                ( h-impl/H.hs, bkp15.out/h-impl/H.o )
-
-bkp15.bkp:76:9: warning:
-    • The MINIMAL pragma does not require:
-        ‘xa’ and ‘y’
-      but there is no default implementation.
-    • In the class declaration for ‘Bloop’
 [5 of 5] Processing s
   Instantiating s
   [1 of 1] Including r[H=h-impl:H]
 [5 of 5] Processing s
   Instantiating s
   [1 of 1] Including r[H=h-impl:H]
diff --git a/testsuite/tests/backpack/should_compile/bkp46.bkp b/testsuite/tests/backpack/should_compile/bkp46.bkp
new file mode 100644 (file)
index 0000000..6d054fe
--- /dev/null
@@ -0,0 +1,32 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# OPTIONS_GHC -O #-}
+unit p where
+    signature A where
+        class C a where
+            f :: a -> a
+        class D a where
+            g :: a
+            default g :: a
+        class E a where
+            h :: a -> String
+            default h :: Show a => a -> String
+    module B where
+        class X a where
+            i :: String -> a
+            default i :: Read a => String -> a
+            i = read
+        instance X Int where
+unit i where
+    module A where
+        class C a where
+            f :: a -> a
+            f x = x
+        class D a where
+            g :: a
+            g = undefined
+        class E a where
+            h :: a -> String
+            default h :: Show a => a -> String
+            h = show
+unit m where
+    dependency p[A=i:A]
diff --git a/testsuite/tests/backpack/should_compile/bkp46.stderr b/testsuite/tests/backpack/should_compile/bkp46.stderr
new file mode 100644 (file)
index 0000000..220eb96
--- /dev/null
@@ -0,0 +1,12 @@
+[1 of 3] Processing p
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling B                ( p/B.hs, nothing )
+[2 of 3] Processing i
+  Instantiating i
+  [1 of 1] Compiling A                ( i/A.hs, bkp46.out/i/A.o )
+[3 of 3] Processing m
+  Instantiating m
+  [1 of 1] Including p[A=i:A]
+    Instantiating p[A=i:A]
+    [1 of 2] Compiling A[sig]           ( p/A.hsig, bkp46.out/p/p-CtJxD03mJqIIVJzOga8l4X/A.o )
+    [2 of 2] Compiling B                ( p/B.hs, bkp46.out/p/p-CtJxD03mJqIIVJzOga8l4X/B.o )
diff --git a/testsuite/tests/backpack/should_compile/bkp47.bkp b/testsuite/tests/backpack/should_compile/bkp47.bkp
new file mode 100644 (file)
index 0000000..76653f0
--- /dev/null
@@ -0,0 +1,20 @@
+{-# LANGUAGE DefaultSignatures #-}
+unit p where
+    signature A where
+        class C a where
+            f :: a -> a
+            g :: a -> a
+            {-# MINIMAL f #-}
+unit q where
+    signature A where
+        class C a where
+            f :: a -> a
+            g :: a -> a
+            {-# MINIMAL g #-}
+unit r where
+    dependency p[A=<A>]
+    dependency q[A=<A>]
+    module B where
+        import A
+        instance C Int where
+            -- Warns!
diff --git a/testsuite/tests/backpack/should_compile/bkp47.stderr b/testsuite/tests/backpack/should_compile/bkp47.stderr
new file mode 100644 (file)
index 0000000..0cc25d5
--- /dev/null
@@ -0,0 +1,12 @@
+[1 of 3] Processing p
+  [1 of 1] Compiling A[sig]           ( p/A.hsig, nothing )
+[2 of 3] Processing q
+  [1 of 1] Compiling A[sig]           ( q/A.hsig, nothing )
+[3 of 3] Processing r
+  [1 of 2] Compiling A[sig]           ( r/A.hsig, nothing )
+  [2 of 2] Compiling B                ( r/B.hs, nothing )
+
+bkp47.bkp:19:18: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        either ‘f’ or ‘g’
+    • In the instance declaration for ‘C Int’
index 937d0c8..c24fa25 100644 (file)
@@ -34,3 +34,6 @@ test('bkpfail35', normal, backpack_compile_fail, [''])
 test('bkpfail36', normal, backpack_compile_fail, [''])
 test('bkpfail37', normal, backpack_compile_fail, [''])
 test('bkpfail38', normal, backpack_compile_fail, [''])
 test('bkpfail36', normal, backpack_compile_fail, [''])
 test('bkpfail37', normal, backpack_compile_fail, [''])
 test('bkpfail38', normal, backpack_compile_fail, [''])
+test('bkpfail39', expect_broken(13068), backpack_compile_fail, [''])
+test('bkpfail40', normal, backpack_compile_fail, [''])
+test('bkpfail41', normal, backpack_compile_fail, [''])
diff --git a/testsuite/tests/backpack/should_fail/bkpfail39.bkp b/testsuite/tests/backpack/should_fail/bkpfail39.bkp
new file mode 100644 (file)
index 0000000..8676193
--- /dev/null
@@ -0,0 +1,6 @@
+unit p where
+    signature A where
+        class C a
+    module B where
+        import A
+        instance C Int where
diff --git a/testsuite/tests/backpack/should_fail/bkpfail40.bkp b/testsuite/tests/backpack/should_fail/bkpfail40.bkp
new file mode 100644 (file)
index 0000000..f06de4d
--- /dev/null
@@ -0,0 +1,5 @@
+unit p where
+    signature A where
+        class C a where
+            f :: a -> a
+            f x = x
diff --git a/testsuite/tests/backpack/should_fail/bkpfail40.stderr b/testsuite/tests/backpack/should_fail/bkpfail40.stderr
new file mode 100644 (file)
index 0000000..a2f36df
--- /dev/null
@@ -0,0 +1,6 @@
+[1 of 1] Processing p
+  [1 of 1] Compiling A[sig]           ( p/A.hsig, nothing )
+
+bkpfail40.bkp:3:9: error:
+    • Illegal default method(s) in class definition of C in hsig file
+    • In the class declaration for ‘C’
diff --git a/testsuite/tests/backpack/should_fail/bkpfail41.bkp b/testsuite/tests/backpack/should_fail/bkpfail41.bkp
new file mode 100644 (file)
index 0000000..a8e7f59
--- /dev/null
@@ -0,0 +1,13 @@
+{-# LANGUAGE DefaultSignatures #-}
+unit p where
+    signature A where
+        class C a where
+            f :: a -> a
+            default f :: a -> a
+    signature B where
+unit i where
+    module A where
+        class C a where
+            f :: a -> a
+unit r where
+    dependency p[A=i:A,B=<B>]
diff --git a/testsuite/tests/backpack/should_fail/bkpfail41.stderr b/testsuite/tests/backpack/should_fail/bkpfail41.stderr
new file mode 100644 (file)
index 0000000..9a1b421
--- /dev/null
@@ -0,0 +1,22 @@
+[1 of 3] Processing p
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling B[sig]           ( p/B.hsig, nothing )
+[2 of 3] Processing i
+  Instantiating i
+  [1 of 1] Compiling A                ( i/A.hs, bkpfail41.out/i/A.o )
+[3 of 3] Processing r
+  [1 of 1] Compiling B[sig]           ( r/B.hsig, nothing )
+
+bkpfail41.bkp:10:9: error:
+    • Class ‘C’ has conflicting definitions in the module
+      and its hsig file
+      Main module: class C a where
+                     f :: a -> a
+                     {-# MINIMAL f #-}
+      Hsig file:  class C a where
+                    f :: a -> a
+                    default f :: a -> a
+      The methods do not match:
+        The default methods associated with ‘f’ are not compatible
+      The MINIMAL pragmas are not compatible
+    • while checking that i:A implements signature A in p[A=i:A,B=<B>]
index e7e6a3a..7fc5d80 100644 (file)
@@ -93,6 +93,7 @@ RnFail055.hs-boot:28:1: error:
                    m2 :: a -> b
                    {-# MINIMAL m2 #-}
     The methods do not match: There are different numbers of methods
                    m2 :: a -> b
                    {-# MINIMAL m2 #-}
     The methods do not match: There are different numbers of methods
+    The MINIMAL pragmas are not compatible
 
 RnFail055.hs-boot:29:1: error:
     Class ‘C3’ has conflicting definitions in the module
 
 RnFail055.hs-boot:29:1: error:
     Class ‘C3’ has conflicting definitions in the module