From 257c13d86db0a9ed540287127fd1c79abacf857e Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 19 Apr 2018 20:47:48 -0400 Subject: Lint types in newFamInst MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We weren't linting the types used in `newFamInst`, which might have been why #15012 went undiscovered for so long. Let's fix that. One has to be surprisingly careful with expanding type synonyms in `lintType`, since in the offending program (simplified): ```lang=haskell type FakeOut a = Int type family TF a type instance TF Int = FakeOut a ``` If one expands type synonyms, then `FakeOut a` will expand to `Int`, which masks the issue (that `a` is unbound). I added an extra Lint flag to configure whether type synonyms should be expanded or not in Lint, and disabled this when calling `lintTypes` from `newFamInst`. As evidence that this works, I ran it on the offending program from #15012, and voilà: ``` $ ghc3/inplace/bin/ghc-stage2 Bug.hs -dcore-lint [1 of 1] Compiling Foo ( Bug.hs, Bug.o ) ghc-stage2: panic! (the 'impossible' happened) (GHC version 8.5.20180417 for x86_64-unknown-linux): Core Lint error : warning: In the type ‘... (Rec0 (FakeOut b_a1Qt))))’ @ b_a1Qt is out of scope ``` Test Plan: make test TEST=T15057 Reviewers: simonpj, goldfire, bgamari Reviewed By: bgamari Subscribers: thomie, carter GHC Trac Issues: #15057 Differential Revision: https://phabricator.haskell.org/D4611 --- compiler/typecheck/FamInst.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'compiler/typecheck/FamInst.hs') diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 956a412baf..4fe1430762 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -19,6 +19,7 @@ import HscTypes import FamInstEnv import InstEnv( roughMatchTcs ) import Coercion +import CoreLint import TcEvidence import LoadIface import TcRnMonad @@ -160,13 +161,24 @@ newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) do { (subst, tvs') <- freshenTyVarBndrs tvs ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; dflags <- getDynFlags + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + tcv_set' = mkVarSet (tvs' ++ cvs') + ; when (gopt Opt_DoCoreLinting dflags) $ + -- Check that the types involved in this instance are well formed. + -- Do /not/ expand type synonyms, for the reasons discussed in + -- Note [Linting type synonym applications]. + case lintTypes dflags False tcv_set' (rhs':lhs') of + Nothing -> pure () + Just fail_msg -> pprPanic "Core Lint error" fail_msg ; return (FamInst { fi_fam = tyConName fam_tc , fi_flavor = flavor , fi_tcs = roughMatchTcs lhs , fi_tvs = tvs' , fi_cvs = cvs' - , fi_tys = substTys subst lhs - , fi_rhs = substTy subst rhs + , fi_tys = lhs' + , fi_rhs = rhs' , fi_axiom = axiom }) } where lhs_kind = typeKind (mkTyConApp fam_tc lhs) -- cgit v1.2.1