Commit 7e77c4b2 authored by Edward Z. Yang's avatar Edward Z. Yang

Support constraint synonym implementations of abstract classes.

Summary:

Test Plan: validate

Reviewers: goldfire, simonpj, austin, bgamari

Subscribers: thomie

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

GHC Trac Issues: #12679
parent 518f2895
......@@ -202,6 +202,7 @@ typecheckIface iface
-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon _ } = True
isAbstractIfaceDecl IfaceClass{ ifCtxt = [], ifSigs = [], ifATs = [] } = True
isAbstractIfaceDecl _ = False
-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If
......
......@@ -943,7 +943,10 @@ checkBootTyCon is_boot tc1 tc2
check (eqListBy eqFD clas_fds1 clas_fds2)
(text "The functional dependencies do not match") `andThenCheck`
checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
-- Above tests for an "abstract" class
-- Above tests for an "abstract" class.
-- This is duplicated in 'isAbstractIfaceDecl'
-- and also below near
-- Note [Constraint synonym implements abstract class]
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`
......@@ -992,6 +995,47 @@ checkBootTyCon is_boot tc1 tc2
-- we need to drop the first role of K when comparing!
check (roles1 == drop (length args) (tyConRoles tc2')) roles_msg
-- Note [Constraint synonym implements abstract class]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- This clause allows an abstract class to be implemented with a constraint
-- synonym. For instance, consider a signature requiring an abstract class,
--
-- signature ASig where
-- class K a
--
-- Since K has no methods (i.e. is abstract), the module implementing this
-- signature may want to implement it using a constraint synonym of another
-- class,
--
-- module AnImpl where
-- class SomeClass a where ...
-- type K a = SomeClass a
--
-- This was originally requested in #12679. For now, we only allow this
-- in hsig files (@not is_boot@).
| not is_boot
, Just c1 <- tyConClass_maybe tc1
, let (_, _clas_fds1, sc_theta1, _, ats1, op_stuff1)
= classExtraBigSig c1
-- Is it abstract?
, null sc_theta1 && null op_stuff1 && null ats1
, Just (tvs, ty) <- synTyConDefn_maybe tc2
= -- The synonym may or may not be eta-expanded, so we need to
-- massage it into the correct form before checking if roles
-- match.
if length tvs == length roles1
then check (roles1 == roles2) roles_msg
else case tcSplitTyConApp_maybe ty of
Just (tc2', args) ->
check (roles1 == drop (length args) (tyConRoles tc2') ++ roles2)
roles_msg
Nothing -> Just roles_msg
-- TODO: We really should check if the fundeps are satisfied, but
-- there is not an obvious way to do this for a constraint synonym.
-- So for now, let it all through (it won't cause segfaults, anyway).
-- Tracked at #12704.
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
= ASSERT(tc1 == tc2)
......
......@@ -31,3 +31,5 @@ test('bkp35', expect_broken(0), backpack_compile, [''])
test('bkp36', normal, backpack_compile, [''])
test('bkp37', normal, backpack_compile, [''])
test('bkp38', normal, backpack_compile, [''])
test('bkp39', normal, backpack_compile, [''])
test('bkp40', normal, backpack_compile, [''])
{-# LANGUAGE ConstraintKinds #-}
unit p where
signature A where
import Prelude hiding ((==))
class K a
class K2 a
(==) :: K a => a -> a -> Bool
module M where
import Prelude hiding ((==))
import A
f a b c = a == b && b == c
unit q where
module A(K, K2, (==)) where
type K a = Eq a
type K2 = Eq
unit r where
dependency p[A=q:A]
[1 of 3] Processing p
[1 of 2] Compiling A[sig] ( p/A.hsig, nothing )
[2 of 2] Compiling M ( p/M.hs, nothing )
[2 of 3] Processing q
Instantiating q
[1 of 1] Compiling A ( q/A.hs, bkp39.out/q/A.o )
[3 of 3] Processing r
Instantiating r
[1 of 1] Including p[A=q:A]
Instantiating p[A=q:A]
[1 of 2] Compiling A[sig] ( p/A.hsig, bkp39.out/p/p-HVmFlcYSefiK5n1aDP1v7x/A.o )
[2 of 2] Compiling M ( p/M.hs, bkp39.out/p/p-HVmFlcYSefiK5n1aDP1v7x/M.o )
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RoleAnnotations #-}
unit user where
signature Map where
type role Map nominal representational
data Map k a
class Key k
instance Key String
empty :: Map k a
lookup :: Key k => k -> Map k a -> Maybe a
insert :: Key k => k -> a -> Map k a -> Map k a
module User where
import Prelude hiding (lookup)
import Map
x = lookup "foo" (insert "foo" True empty)
unit ordmap where
module Map(module Data.Map, Key) where
import Data.Map
type Key = Ord
unit eqmap where
module Map where
import Prelude hiding (lookup)
import qualified Prelude
type role Map nominal representational
newtype Map k a = Assoc [(k, a)]
type Key = Eq
-- Ugh, need the type signatures, otherwise the quantifiers
-- are put in the wrong order. See #12441
empty :: Map k a
empty = Assoc []
lookup :: Eq k => k -> Map k a -> Maybe a
lookup k (Assoc xs) = Prelude.lookup k xs
-- Need to insert redundant constraint to make it work...
insert :: Eq k => k -> a -> Map k a -> Map k a
insert k v (Assoc xs) = Assoc ((k,v):xs)
unit main where
dependency user[Map=ordmap:Map] (User as User.Ord)
dependency user[Map=eqmap:Map] (User as User.Eq)
[1 of 4] Processing user
[1 of 2] Compiling Map[sig] ( user/Map.hsig, nothing )
[2 of 2] Compiling User ( user/User.hs, nothing )
[2 of 4] Processing ordmap
Instantiating ordmap
[1 of 1] Compiling Map ( ordmap/Map.hs, bkp40.out/ordmap/Map.o )
[3 of 4] Processing eqmap
Instantiating eqmap
[1 of 1] Compiling Map ( eqmap/Map.hs, bkp40.out/eqmap/Map.o )
[4 of 4] Processing main
Instantiating main
[1 of 2] Including user[Map=ordmap:Map]
Instantiating user[Map=ordmap:Map]
[1 of 2] Compiling Map[sig] ( user/Map.hsig, bkp40.out/user/user-GzloW2NeDdA2M0V8qzN4g2/Map.o )
[2 of 2] Compiling User ( user/User.hs, bkp40.out/user/user-GzloW2NeDdA2M0V8qzN4g2/User.o )
[2 of 2] Including user[Map=eqmap:Map]
Instantiating user[Map=eqmap:Map]
[1 of 2] Compiling Map[sig] ( user/Map.hsig, bkp40.out/user/user-9YyTxEeqz3GG5thfDXwuAf/Map.o )
[2 of 2] Compiling User ( user/User.hs, bkp40.out/user/user-9YyTxEeqz3GG5thfDXwuAf/User.o )
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