[Git][ghc/ghc][master] Skip type family defaults with hs-boot and hsig files
Marge Bot
gitlab at gitlab.haskell.org
Sun Oct 18 02:01:46 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
59d7c9f4 by John Ericson at 2020-10-17T22:01:38-04:00
Skip type family defaults with hs-boot and hsig files
Works around #17190, possible resolution for #17224. New design is is
according to accepted [GHC Propoal 320].
Instances in signatures currently unconditionally opt into associated
family defaults if no explicit instance is given. This is bad for two
reasons:
1. It constrains possible instantiations to use the default, rather
than possibly define the associated family differently.
2. It breaks compilation as type families are unsupported in
signatures.
This PR simply turns off the filling in of defaults in those cases.
Additionally, it squelches a missing definition warning for hs-boot too
that was only squelched for hsig before.
The downsides are:
1. There is no way to opt into the default, other than copying its
definition.
2. If we fixed type classes in signatures, and wanted instances to
have to explicitly *out of* rather than into the default, that would
now be a breaking change.
The change that is most unambiguously goood is harmonizing the warning
squelching between hs-boot or hsig. Maybe they should have the warning
(opt out of default) maybe they shouldn't (opt in to default), but
surely it should be the same for both.
Add hs-boot version of a backpack test regarding class-specified
defaults in instances that appear in an hs-boot file.
The metrics increase is very slight and makes no sense --- at least no
one has figured anything out after this languishing for a while, so I'm
just going to accept it.
Metric Increase:
T10421a
[GHC proposal 320]: https://github.com/ghc-proposals/ghc-proposals/pull/320
- - - - -
17 changed files:
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- testsuite/tests/backpack/should_compile/all.T
- + testsuite/tests/backpack/should_compile/bkp57.bkp
- + testsuite/tests/backpack/should_compile/bkp57.stderr
- + testsuite/tests/backpack/should_compile/bkp58.bkp
- + testsuite/tests/backpack/should_compile/bkp58.stderr
- + testsuite/tests/backpack/should_compile/bkp59.bkp
- + testsuite/tests/backpack/should_compile/bkp59.stderr
- + testsuite/tests/backpack/should_compile/bkp60.bkp
- + testsuite/tests/backpack/should_compile/bkp60.stderr
- + testsuite/tests/typecheck/should_compile/ClassDefaultInHsBoot.hs
- + testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA1.hs
- + testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA2.hs
- + testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA2.hs-boot
- + testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA3.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -550,8 +550,10 @@ warnMissingAT name
= do { warn <- woptM Opt_WarnMissingMethods
; traceTc "warn" (ppr name <+> ppr warn)
; hsc_src <- fmap tcg_src getGblEnv
- -- Warn only if -Wmissing-methods AND not a signature
- ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
+ -- hs-boot and signatures never need to provide complete "definitions"
+ -- of any sort, as they aren't really defining anything, but just
+ -- constraining items which are defined elsewhere.
+ ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)
(text "No explicit" <+> text "associated type"
<+> text "or default declaration for"
<+> quotes (ppr name)) }
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -512,9 +512,18 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
-- Check for missing associated types and build them
-- from their defaults (if available)
+ ; is_boot <- tcIsHsBootOrSig
+ ; let atItems = classATItems clas
; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
- (classATItems clas)
-
+ (if is_boot then [] else atItems)
+ -- Don't default type family instances, but rather omit, in hsig/hs-boot.
+ -- Since hsig/hs-boot files are essentially large binders we want omission
+ -- of the definition to result in no restriction, rather than for example
+ -- attempting to "pattern match" with the invisible defaults and generate
+ -- equalities. Without further handling, this would just result in a panic
+ -- anyway.
+ -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for
+ -- additional discussion.
; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
@@ -539,8 +548,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
all_insts = tyfam_insts ++ datafam_insts
-- In hs-boot files there should be no bindings
- ; is_boot <- tcIsHsBootOrSig
; let no_binds = isEmptyLHsBinds binds && null uprags
+ ; is_boot <- tcIsHsBootOrSig
; failIfTc (is_boot && not no_binds) badBootDeclErr
; return ( [inst_info], all_insts, deriv_infos ) }
=====================================
testsuite/tests/backpack/should_compile/all.T
=====================================
@@ -48,6 +48,10 @@ test('bkp53', normal, backpack_compile, [''])
test('bkp54', normal, backpack_compile, [''])
test('bkp55', normal, backpack_compile, [''])
test('bkp56', normal, backpack_compile, [''])
+test('bkp57', normal, backpack_compile, [''])
+test('bkp58', normal, backpack_compile, [''])
+test('bkp59', normal, backpack_compile, [''])
+test('bkp60', normal, backpack_compile, [''])
test('T13140', normal, backpack_compile, [''])
test('T13149', expect_broken(13149), backpack_compile, [''])
=====================================
testsuite/tests/backpack/should_compile/bkp57.bkp
=====================================
@@ -0,0 +1,37 @@
+-- no default method, backpack
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+ module Class where
+ class Show (T x) => C x where
+ type T x
+ def :: T x
+ --type T x = ()
+unit consumer-abs where
+ dependency common
+ signature Instance where
+ import Class
+ data I = I Int
+ instance C I where
+ --type T I = ()
+ module Downstream where
+ import Class
+ import Instance
+ asdf :: C I => String
+ asdf = show $ def @I
+unit consumer-impl where
+ dependency common
+ module Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ type T I = ()
+ def = ()
+unit tie where
+ dependency consumer-impl
+ dependency consumer-abs[Instance=consumer-impl:Impl]
+ module Tie where
+ import Downstream
+ main = print asdf
=====================================
testsuite/tests/backpack/should_compile/bkp57.stderr
=====================================
@@ -0,0 +1,19 @@
+[1 of 4] Processing common
+ Instantiating common
+ [1 of 1] Compiling Class ( common/Class.hs, bkp57.out/common/Class.o )
+[2 of 4] Processing consumer-abs
+ [1 of 2] Compiling Instance[sig] ( consumer-abs/Instance.hsig, nothing )
+ [2 of 2] Compiling Downstream ( consumer-abs/Downstream.hs, nothing )
+[3 of 4] Processing consumer-impl
+ Instantiating consumer-impl
+ [1 of 1] Including common
+ [1 of 1] Compiling Impl ( consumer-impl/Impl.hs, bkp57.out/consumer-impl/Impl.o )
+[4 of 4] Processing tie
+ Instantiating tie
+ [1 of 2] Including consumer-impl
+ [2 of 2] Including consumer-abs[Instance=consumer-impl:Impl]
+ Instantiating consumer-abs[Instance=consumer-impl:Impl]
+ [1 of 1] Including common
+ [1 of 2] Compiling Instance[sig] ( consumer-abs/Instance.hsig, bkp57.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Instance.o )
+ [2 of 2] Compiling Downstream ( consumer-abs/Downstream.hs, bkp57.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Downstream.o )
+ [1 of 1] Compiling Tie ( tie/Tie.hs, bkp57.out/tie/Tie.o )
=====================================
testsuite/tests/backpack/should_compile/bkp58.bkp
=====================================
@@ -0,0 +1,35 @@
+-- no default method, hs-boot
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+ module Class where
+ class Show (T x) => C x where
+ type T x
+ --type T x = ()
+ def :: T x
+unit consumer-impl where
+ dependency common
+ module {-# SOURCE #-} Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ --type T I = ()
+ module Downstream where
+ import Class
+ import {-# SOURCE #-} Impl
+ asdf :: C I => String
+ asdf = show $ def @I
+ module Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ type T I = ()
+ def = ()
+unit tie where
+ dependency consumer-impl
+ module Tie where
+ import Downstream
+ import Impl
+ main = print asdf
=====================================
testsuite/tests/backpack/should_compile/bkp58.stderr
=====================================
@@ -0,0 +1,13 @@
+[1 of 3] Processing common
+ Instantiating common
+ [1 of 1] Compiling Class ( common/Class.hs, bkp58.out/common/Class.o )
+[2 of 3] Processing consumer-impl
+ Instantiating consumer-impl
+ [1 of 1] Including common
+ [1 of 3] Compiling Impl[boot] ( consumer-impl/Impl.hs-boot, bkp58.out/consumer-impl/Impl.o-boot )
+ [2 of 3] Compiling Downstream ( consumer-impl/Downstream.hs, bkp58.out/consumer-impl/Downstream.o )
+ [3 of 3] Compiling Impl ( consumer-impl/Impl.hs, bkp58.out/consumer-impl/Impl.o )
+[3 of 3] Processing tie
+ Instantiating tie
+ [1 of 1] Including consumer-impl
+ [1 of 1] Compiling Tie ( tie/Tie.hs, bkp58.out/tie/Tie.o )
=====================================
testsuite/tests/backpack/should_compile/bkp59.bkp
=====================================
@@ -0,0 +1,38 @@
+-- default method, backpack
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+ module Class where
+ class Show (T x) => C x where
+ type T x
+ type T x = ()
+ def :: T x
+ class D x where
+unit consumer-abs where
+ dependency common
+ signature Instance where
+ import Class
+ data I = I Int
+ instance C I where
+ --type T I = ()
+ module Downstream where
+ import Class
+ import Instance
+ asdf :: C I => String
+ asdf = show $ def @I
+unit consumer-impl where
+ dependency common
+ module Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ type T I = ()
+ def = ()
+unit tie where
+ dependency consumer-impl
+ dependency consumer-abs[Instance=consumer-impl:Impl]
+ module Tie where
+ import Downstream
+ main = print asdf
=====================================
testsuite/tests/backpack/should_compile/bkp59.stderr
=====================================
@@ -0,0 +1,19 @@
+[1 of 4] Processing common
+ Instantiating common
+ [1 of 1] Compiling Class ( common/Class.hs, bkp59.out/common/Class.o )
+[2 of 4] Processing consumer-abs
+ [1 of 2] Compiling Instance[sig] ( consumer-abs/Instance.hsig, nothing )
+ [2 of 2] Compiling Downstream ( consumer-abs/Downstream.hs, nothing )
+[3 of 4] Processing consumer-impl
+ Instantiating consumer-impl
+ [1 of 1] Including common
+ [1 of 1] Compiling Impl ( consumer-impl/Impl.hs, bkp59.out/consumer-impl/Impl.o )
+[4 of 4] Processing tie
+ Instantiating tie
+ [1 of 2] Including consumer-impl
+ [2 of 2] Including consumer-abs[Instance=consumer-impl:Impl]
+ Instantiating consumer-abs[Instance=consumer-impl:Impl]
+ [1 of 1] Including common
+ [1 of 2] Compiling Instance[sig] ( consumer-abs/Instance.hsig, bkp59.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Instance.o )
+ [2 of 2] Compiling Downstream ( consumer-abs/Downstream.hs, bkp59.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Downstream.o )
+ [1 of 1] Compiling Tie ( tie/Tie.hs, bkp59.out/tie/Tie.o )
=====================================
testsuite/tests/backpack/should_compile/bkp60.bkp
=====================================
@@ -0,0 +1,35 @@
+-- default method, hs-boot
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+ module Class where
+ class Show (T x) => C x where
+ type T x
+ type T x = ()
+ def :: T x
+unit consumer-impl where
+ dependency common
+ module {-# SOURCE #-} Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ --type T I = ()
+ module Downstream where
+ import Class
+ import {-# SOURCE #-} Impl
+ asdf :: C I => String
+ asdf = show $ def @I
+ module Impl where
+ import Class
+ data I = I Int
+ instance C I where
+ type T I = ()
+ def = ()
+unit tie where
+ dependency consumer-impl
+ module Tie where
+ import Downstream
+ import Impl
+ main = print asdf
=====================================
testsuite/tests/backpack/should_compile/bkp60.stderr
=====================================
@@ -0,0 +1,13 @@
+[1 of 3] Processing common
+ Instantiating common
+ [1 of 1] Compiling Class ( common/Class.hs, bkp60.out/common/Class.o )
+[2 of 3] Processing consumer-impl
+ Instantiating consumer-impl
+ [1 of 1] Including common
+ [1 of 3] Compiling Impl[boot] ( consumer-impl/Impl.hs-boot, bkp60.out/consumer-impl/Impl.o-boot )
+ [2 of 3] Compiling Downstream ( consumer-impl/Downstream.hs, bkp60.out/consumer-impl/Downstream.o )
+ [3 of 3] Compiling Impl ( consumer-impl/Impl.hs, bkp60.out/consumer-impl/Impl.o )
+[3 of 3] Processing tie
+ Instantiating tie
+ [1 of 1] Including consumer-impl
+ [1 of 1] Compiling Tie ( tie/Tie.hs, bkp60.out/tie/Tie.o )
=====================================
testsuite/tests/typecheck/should_compile/ClassDefaultInHsBoot.hs
=====================================
@@ -0,0 +1,4 @@
+import ClassDefaultInHsBootA3
+import ClassDefaultInHsBootA2
+
+main = print asdf
=====================================
testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA1.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- Analogous to module Class from tests/backpack/should_compile/bkp58.bkp
+module ClassDefaultInHsBootA1 where
+
+class Show (T x) => C x where
+ type T x
+ type T x = Int
+ def :: T x
=====================================
testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA2.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
+module ClassDefaultInHsBootA2 where
+
+import ClassDefaultInHsBootA1
+
+data I = I Int
+
+instance C I where
+ type T I = ()
+ def = ()
=====================================
testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA2.hs-boot
=====================================
@@ -0,0 +1,6 @@
+module ClassDefaultInHsBootA2 where
+
+import ClassDefaultInHsBootA1
+
+data I = I Int
+instance C I
=====================================
testsuite/tests/typecheck/should_compile/ClassDefaultInHsBootA3.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+module ClassDefaultInHsBootA3 where
+
+import ClassDefaultInHsBootA1
+import ClassDefaultInHsBootA2
+
+asdf :: String
+asdf = show $ def @I
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -724,4 +724,5 @@ test('T18323', normal, compile, [''])
test('T18585', normal, compile, [''])
test('T18831', normal, compile, [''])
test('T15942', normal, compile, [''])
+test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59d7c9f45b034809516703b57c84e3dac1834578
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59d7c9f45b034809516703b57c84e3dac1834578
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201017/1a5200a3/attachment-0001.html>
More information about the ghc-commits
mailing list