From 4d59c74b2381eb8e2b9c1d31111a921ed95ebd23 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 21 Apr 2016 11:53:53 -0700 Subject: [PATCH] Type synonym support. Signed-off-by: Edward Z. Yang --- compiler/iface/MkIface.hs | 5 ++ compiler/typecheck/TcRnDriver.hs | 9 ++++ compiler/typecheck/TcTyClsDecls.hs | 49 ++++++++++++++++++- testsuite/tests/backpack/should_compile/all.T | 2 + .../tests/backpack/should_compile/bkp14.bkp | 10 ++++ .../backpack/should_compile/bkp14.stderr | 19 ++++--- .../tests/backpack/should_compile/bkp26.bkp | 24 +++++++++ .../backpack/should_compile/bkp26.stderr | 20 ++++++++ .../tests/backpack/should_compile/bkp27.bkp | 27 ++++++++++ .../backpack/should_compile/bkp27.stderr | 20 ++++++++ 10 files changed, 173 insertions(+), 12 deletions(-) create mode 100644 testsuite/tests/backpack/should_compile/bkp26.bkp create mode 100644 testsuite/tests/backpack/should_compile/bkp26.stderr create mode 100644 testsuite/tests/backpack/should_compile/bkp27.bkp create mode 100644 testsuite/tests/backpack/should_compile/bkp27.stderr diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index cc92ad79550a..9573614f2b67 100644 --- a/compiler/iface/MkIface.hs +++ b/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)) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 24cdaa4d4440..59f03806f409 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/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) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 6fff74e4b74a..eb76dc1c8ded 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/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 diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T index 66156a11111e..c675aa62bc88 100644 --- a/testsuite/tests/backpack/should_compile/all.T +++ b/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']) diff --git a/testsuite/tests/backpack/should_compile/bkp14.bkp b/testsuite/tests/backpack/should_compile/bkp14.bkp index 1200922dc066..1b80159b5043 100644 --- a/testsuite/tests/backpack/should_compile/bkp14.bkp +++ b/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) diff --git a/testsuite/tests/backpack/should_compile/bkp14.stderr b/testsuite/tests/backpack/should_compile/bkp14.stderr index 1a9bc00c7c72..fe1d9cb8b9fb 100644 --- a/testsuite/tests/backpack/should_compile/bkp14.stderr +++ b/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 ) diff --git a/testsuite/tests/backpack/should_compile/bkp26.bkp b/testsuite/tests/backpack/should_compile/bkp26.bkp new file mode 100644 index 000000000000..0151c4d7bdfd --- /dev/null +++ b/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 diff --git a/testsuite/tests/backpack/should_compile/bkp26.stderr b/testsuite/tests/backpack/should_compile/bkp26.stderr new file mode 100644 index 000000000000..fbfb123d0fba --- /dev/null +++ b/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 ) diff --git a/testsuite/tests/backpack/should_compile/bkp27.bkp b/testsuite/tests/backpack/should_compile/bkp27.bkp new file mode 100644 index 000000000000..f174882ee01f --- /dev/null +++ b/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 diff --git a/testsuite/tests/backpack/should_compile/bkp27.stderr b/testsuite/tests/backpack/should_compile/bkp27.stderr new file mode 100644 index 000000000000..74fb30367a8d --- /dev/null +++ b/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 )