Lint types in newFamInst

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
  <no location info>: 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

1 files changed, 14 insertions, 2 deletions

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)