Commit 5def07fa authored by Edward Z. Yang's avatar Edward Z. Yang

Revamp Backpack/hs-boot handling of type class signatures.

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: default avatarEdward 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
parent e41c61fa
......@@ -304,10 +304,11 @@ rnIfaceGlobal n = do
]
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
......@@ -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.
dfun <- rnIfaceDFun (ifDFun cls_inst)
dfun <- rnIfaceImplicit (ifDFun cls_inst)
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
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)
......
......@@ -57,7 +57,7 @@ module OccName (
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc,
mkDefaultMethodOcc, isDefaultMethodOcc,
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
isDefaultMethodOcc :: OccName -> Bool
isDefaultMethodOcc occ =
case occNameString occ of
'$':'d':'m':_ -> True
_ -> False
mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc,
......
......@@ -71,6 +71,7 @@ import FastString
import BasicTypes hiding ( SuccessFlag(..) )
import ListSetOps
import GHC.Fingerprint
import qualified BooleanFormula as BF
import Data.List
import Control.Monad
......@@ -212,10 +213,23 @@ mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
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
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
......
......@@ -29,6 +29,7 @@ import TcMType
import Type ( getClassPredTys_maybe, piResultTys )
import TcType
import TcRnMonad
import DriverPhases (HscSource(..))
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
......@@ -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)
; 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 }
......@@ -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
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
......
......@@ -66,6 +66,7 @@ import TcExpr
import TcRnMonad
import TcRnExports
import TcEvidence
import qualified BooleanFormula as BF
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 (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
......@@ -927,6 +932,26 @@ checkBootTyCon is_boot tc1 tc2
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
......@@ -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`
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
......
......@@ -23,6 +23,8 @@ import MonadUtils
import Outputable
import Binary
import SrcLoc
import Unique
import UniqSet
----------------------------------------------------------------------
-- 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
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
......
......@@ -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('bkp46', normal, backpack_compile, [''])
test('bkp47', normal, backpack_compile, [''])
......@@ -15,13 +15,9 @@ unit p where
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
-- 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)
......@@ -40,10 +36,9 @@ unit q where
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
-- 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)
......@@ -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
-- xa = (==)
xa = (==)
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]
......@@ -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 )
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 )
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 )
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]
......
{-# 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]
[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 )
{-# 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!
[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’
......@@ -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('bkpfail39', expect_broken(13068), backpack_compile_fail, [''])
test('bkpfail40', normal, backpack_compile_fail, [''])
test('bkpfail41', normal, backpack_compile_fail, [''])
unit p where
signature A where
class C a
module B where
import A
instance C Int where
unit p where
signature A where
class C a where
f :: a -> a
f x = x
[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’
{-# 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>]
[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>]
......@@ -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
The MINIMAL pragmas are not compatible
RnFail055.hs-boot:29:1: error:
Class ‘C3’ has conflicting definitions in the module
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment