Support constraint synonym implementations of abstract classes.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Fri, 14 Oct 2016 04:34:17 +0000 (21:34 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 20 Oct 2016 19:45:34 +0000 (12:45 -0700)
Summary:

Test Plan: validate

Reviewers: goldfire, simonpj, austin, bgamari

Subscribers: thomie

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

GHC Trac Issues: #12679

compiler/iface/TcIface.hs
compiler/typecheck/TcRnDriver.hs
testsuite/tests/backpack/should_compile/all.T
testsuite/tests/backpack/should_compile/bkp39.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp39.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp40.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp40.stderr [new file with mode: 0644]

index ee51b5d..bb04883 100644 (file)
@@ -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
index b1f2518..f73c0af 100644 (file)
@@ -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)
index c9ba076..7238b63 100644 (file)
@@ -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, [''])
diff --git a/testsuite/tests/backpack/should_compile/bkp39.bkp b/testsuite/tests/backpack/should_compile/bkp39.bkp
new file mode 100644 (file)
index 0000000..45f680e
--- /dev/null
@@ -0,0 +1,17 @@
+{-# 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]
diff --git a/testsuite/tests/backpack/should_compile/bkp39.stderr b/testsuite/tests/backpack/should_compile/bkp39.stderr
new file mode 100644 (file)
index 0000000..924785c
--- /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 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 )
diff --git a/testsuite/tests/backpack/should_compile/bkp40.bkp b/testsuite/tests/backpack/should_compile/bkp40.bkp
new file mode 100644 (file)
index 0000000..3f97456
--- /dev/null
@@ -0,0 +1,41 @@
+{-# 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)
+
diff --git a/testsuite/tests/backpack/should_compile/bkp40.stderr b/testsuite/tests/backpack/should_compile/bkp40.stderr
new file mode 100644 (file)
index 0000000..00176aa
--- /dev/null
@@ -0,0 +1,19 @@
+[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 )