Type synonym support.

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

compiler/iface/MkIface.hs

@@ -452,6 +452,11 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
           | otherwise
           = ASSERT2( isExternalName name, ppr name )
             let hash | nameModule name /= semantic_mod =  global_hash_fn name
+                     -- Get it from the REAL interface!!
+                     -- This will trigger when we compile an hsig file
+                     -- and we know a backing impl for it.
+                     | semantic_mod /= this_mod
+                     , not (isHoleModule semantic_mod) = global_hash_fn name
                      | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint"
                                        (ppr name))) -- (undefined,fingerprint0))

compiler/typecheck/TcRnDriver.hs

@@ -1219,6 +1219,15 @@ mergeSigTyCon is_boot tc1 tc2
     check (injInfo1 == injInfo2) empty `andThenCheck`
     pure tc2
 
+  -- Only for hsig (since we can't do this soundly for hs-boot
+  -- without assuming a lot from the type system)
+  | not is_boot && isAbstractTyCon tc1 && isTypeSynonymTyCon tc2
+  = check (roles1 == roles2) roles_msg `andThenCheck`
+    pure tc2
+  | not is_boot && isAbstractTyCon tc2 && isTypeSynonymTyCon tc1
+  = check (roles1 == roles2) roles_msg `andThenCheck`
+    pure tc1
+
   | isAlgTyCon tc1 && isAlgTyCon tc2
   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
   = ASSERT(tc1 == tc2)

compiler/typecheck/TcTyClsDecls.hs

@@ -54,6 +54,8 @@ import Name
 import NameSet
 import NameEnv
 import RnEnv
+import RdrName
+import LoadIface
 import Outputable
 import Maybes
 import Unify
@@ -917,7 +919,10 @@ tcDataDefn rec_info     -- Knot-tied; don't look at this eagerly
 
        ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons
 
-       ; tycon <- fixM $ \ tycon -> do
+       ; mb_impl_rdr_env <- fmap tcg_impl_rdr_env getGblEnv
+       ; check_is_abstract_synonym is_boot mb_impl_rdr_env $ do
+
+       { tycon <- fixM $ \ tycon -> do
              { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
              ; data_cons <- tcConDecls new_or_data tycon
                                        (final_tvs, final_bndrs, res_ty) cons
@@ -930,8 +935,48 @@ tcDataDefn rec_info     -- Knot-tied; don't look at this eagerly
                                   (VanillaAlgTyCon tc_rep_nm)
                                   (rti_is_rec rec_info tc_name)
                                   gadt_syntax) }
-       ; return tycon }
+       ; return tycon }}
   where
+    -- Let's say that we're compiling an hsig file to check if
+    -- it matches against an implementation, and it has:
+    --
+    --  signature H
+    --      data A
+    --      f :: A
+    --
+    -- and the implementation is:
+    --
+    --  module H
+    --      type A = Bool
+    --      f :: Bool
+    --
+    -- The original name of A is H:A; so the A in the hsig must
+    -- be ascribed the same original name (it does not matter if
+    -- it's a reexport; in that case, we just use a different
+    -- original name.)  But we must go a step further: to discover
+    -- that f :: A matches f :: Bool, we must in fact know that
+    -- A is in fact a type synonym for Bool.  So IF we see
+    -- an abstract type, AND the underlying implementation is
+    -- a synonym, directly replace it with the synonym.
+    --
+    -- (Be careful about this case!
+    --
+    -- module H
+    --      data B = B
+    --      type A = B
+    --      f :: b )
+    check_is_abstract_synonym is_boot mb_impl_rdr_env m
+      | null cons, is_boot
+      , Just gr <- mb_impl_rdr_env
+      , [GRE{ gre_name = n }] <- lookupGlobalRdrEnv gr (occName tc_name)
+      = do r <- tcLookupImported_maybe n
+           case r of
+            Maybes.Succeeded (ATyCon tc)
+                | isTypeSynonymTyCon tc -> return tc
+            Maybes.Succeeded _ -> m
+            Maybes.Failed err -> failWith err
+      | otherwise
+      = m
     mk_tc_rhs is_boot tycon data_cons
       | null data_cons, is_boot         -- In a hs-boot file, empty cons means
       = return totallyAbstractTyConRhs  -- "don't know"; hence totally Abstract

testsuite/tests/backpack/should_compile/all.T

@@ -21,3 +21,5 @@ test('bkp22', normal, backpack_compile_fail, ['-ddump-shape'])
 test('bkp23', normal, backpack_compile, ['-ddump-shape'])
 test('bkp24', normal, backpack_compile, ['-ddump-shape'])
 test('bkp25', normal, backpack_compile, ['-ddump-shape'])
+test('bkp26', normal, backpack_compile, ['-ddump-shape'])
+test('bkp27', normal, backpack_compile, ['-ddump-shape'])

testsuite/tests/backpack/should_compile/bkp14.bkp

@@ -2,12 +2,22 @@ unit p where
     signature H where
         data T
         f :: T
+    signature Y where
+        data Y
+    module M where
+        import H
+        x = f
 unit impl where
     module F where
         data T = T
+            deriving (Show)
         f = T
     module H(T, f) where
         import F
 unit q where
     include impl
     include p
+    module X where
+        import M
+        import H
+        main = print (x :: T)

testsuite/tests/backpack/should_compile/bkp14.stderr

@@ -1,18 +1,17 @@
 [1 of 3] Processing p
-unit p(hole:H)
-  [1 of 1] Compiling H[sig]           ( p/H.hsig, nothing )
+unit p(hole:H, hole:Y)
+  [1 of 3] Compiling H[sig]           ( p/H.hsig, nothing )
+  [2 of 3] Compiling Y[sig]           ( p/Y.hsig, nothing )
+  [3 of 3] Compiling M                ( p/M.hs, nothing )
 [2 of 3] Processing impl
   Instantiating impl
 unit impl
   [1 of 2] Compiling F                ( impl/F.hs, bkp14-out/impl/F.o )
   [2 of 2] Compiling H                ( impl/H.hs, bkp14-out/impl/H.o )
 [3 of 3] Processing q
-  Instantiating q
-unit q
+unit q(hole:Y)
 - include impl [(H, impl:H), (F, impl:F)]
-- include p(impl:H) []
-  [1 of 2] Including impl
-  [2 of 2] Including p
-    Instantiating p(impl:H)
-unit p(impl:H)
-    [1 of 1] Compiling H[sig]           ( p/H.hsig, bkp14-out/p/p-GULbd8Xpcj4IpAVv37waMI/H.o )
+- include p(impl:H, hole:Y) [(M, p(impl:H, hole:Y):M)]
+  Checking impl
+  [1 of 2] Compiling Y[sig]           ( q/Y.hsig, nothing )
+  [2 of 2] Compiling X                ( q/X.hs, nothing )

testsuite/tests/backpack/should_compile/bkp26.bkp

@@ -0,0 +1,24 @@
+{-# LANGUAGE NoSignatureMerging #-}
+
+unit p where
+    signature A where
+        data A
+        neg :: A -> A
+    module P where
+        import A
+        f :: A -> A
+        f = neg . neg
+
+unit r where
+    module A where
+        type A = Bool
+        neg :: A -> A
+        neg = not
+
+unit q where
+    include p
+    include r
+    module M where
+        import P
+        g :: Bool
+        g = f True

testsuite/tests/backpack/should_compile/bkp26.stderr

@@ -0,0 +1,20 @@
+[1 of 3] Processing p
+unit p(hole:A)
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling P                ( p/P.hs, nothing )
+[2 of 3] Processing r
+  Instantiating r
+unit r
+  [1 of 1] Compiling A                ( r/A.hs, bkp26-out/r/A.o )
+[3 of 3] Processing q
+  Instantiating q
+unit q
+- include r [(A, r:A)]
+- include p(r:A) [(P, p(r:A):P)]
+  [1 of 2] Including r
+  [2 of 2] Including p
+    Instantiating p(r:A)
+unit p(r:A)
+    [1 of 2] Compiling A[sig]           ( p/A.hsig, bkp26-out/p/p-8YQRY0unRYZCev5HBjXieS/A.o )
+    [2 of 2] Compiling P                ( p/P.hs, bkp26-out/p/p-8YQRY0unRYZCev5HBjXieS/P.o )
+  [1 of 1] Compiling M                ( q/M.hs, bkp26-out/q/M.o )

testsuite/tests/backpack/should_compile/bkp27.bkp

@@ -0,0 +1,27 @@
+{-# LANGUAGE NoSignatureMerging #-}
+
+unit p where
+    signature A where
+        data A
+        neg :: A -> A
+    module P where
+        import A
+        f :: A -> A
+        f = neg . neg
+
+unit r where
+    module A where
+        data B = X | Y
+        type A = B
+        neg :: B -> B
+        neg X = Y
+        neg Y = X
+
+unit q where
+    include p
+    include r
+    module M where
+        import P
+        import A
+        g :: B
+        g = f X

testsuite/tests/backpack/should_compile/bkp27.stderr

@@ -0,0 +1,20 @@
+[1 of 3] Processing p
+unit p(hole:A)
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling P                ( p/P.hs, nothing )
+[2 of 3] Processing r
+  Instantiating r
+unit r
+  [1 of 1] Compiling A                ( r/A.hs, bkp27-out/r/A.o )
+[3 of 3] Processing q
+  Instantiating q
+unit q
+- include r [(A, r:A)]
+- include p(r:A) [(P, p(r:A):P)]
+  [1 of 2] Including r
+  [2 of 2] Including p
+    Instantiating p(r:A)
+unit p(r:A)
+    [1 of 2] Compiling A[sig]           ( p/A.hsig, bkp27-out/p/p-8YQRY0unRYZCev5HBjXieS/A.o )
+    [2 of 2] Compiling P                ( p/P.hs, bkp27-out/p/p-8YQRY0unRYZCev5HBjXieS/P.o )
+  [1 of 1] Compiling M                ( q/M.hs, bkp27-out/q/M.o )