Fix #11405.

This adds a new variant of AbsBinds that is used solely for bindings
with a type signature. This allows for a simpler desugaring that
does not produce the bogus output that tripped up Core Lint in
ticket #11405. Should make other desugarings simpler, too.

12 files changed, 147 insertions, 18 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b0543ed88e..6dc7383d8b 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -294,6 +294,29 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                       , isAnyInlinePragma (idInlinePragma pid) ] }
 
+addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind
+                                        , abs_sig_export = poly_id }))
+  | L _ FunBind { fun_id = L _ mono_id } <- val_bind
+  = do withEnv (add_export  mono_id) $ do
+       withEnv (add_inlines mono_id) $ do
+       val_bind' <- addTickLHsBind val_bind
+       return $ L pos $ bind { abs_sig_bind = val_bind' }
+
+  | otherwise
+  = pprPanic "addTickLHsBind" (ppr bind)
+ where
+  -- see AbsBinds comments
+  add_export mono_id env
+    | idName poly_id `elemNameSet` exports env
+    = env { exports = exports env `extendNameSet` idName mono_id }
+    | otherwise
+    = env
+
+  add_inlines mono_id env
+    | isAnyInlinePragma (idInlinePragma poly_id)
+    = env { inlines = inlines env `extendVarSet` mono_id }
+    | otherwise
+    = env
 
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   let name = getOccString id
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index a79e9fa7e7..84f67e9f7c 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -154,8 +154,8 @@ dsHsBind dflags
 
         -- A common case: one exported variable, only non-strict binds
         -- Non-recursive bindings come through this way
-        -- So do self-recursive bindings, and recursive bindings
-        -- that have been chopped up with type signatures
+        -- So do self-recursive bindings
+        -- Bindings with complete signatures are AbsBindsSigs, below
 dsHsBind dflags
          (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = [export]
@@ -287,6 +287,44 @@ dsHsBind dflags
                      ,abe_inst_wrap = WpHole
                      ,abe_prags = SpecPrags []})
 
+-- this is a combination of AbsBinds and FunBind
+dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
+                             , abs_sig_export  = global
+                             , abs_sig_prags   = prags
+                             , abs_sig_ev_bind = ev_bind
+                             , abs_sig_bind    = bind })
+  | L bind_loc FunBind { fun_matches = matches
+                       , fun_co_fn   = co_fn
+                       , fun_tick    = tick } <- bind
+  = putSrcSpanDs bind_loc $
+    addDictsDs (toTcTypeBag (listToBag dicts)) $
+    do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches
+       ; let body' = mkOptTickBox tick body
+       ; fun_rhs <- dsHsWrapper co_fn $
+                    mkLams args body'
+       ; let force_vars
+               | xopt LangExt.Strict dflags
+               , matchGroupArity matches == 0 -- no need to force lambdas
+               = [global]
+               | otherwise
+               = []
+
+       ; ds_binds <- dsTcEvBinds ev_bind
+       ; let rhs = mkLams tyvars $
+                   mkLams dicts $
+                   mkCoreLets ds_binds $
+                   fun_rhs
+
+       ; (spec_binds, rules) <- dsSpecs rhs prags
+       ; let global' = addIdSpecialisations global rules
+             main_bind = makeCorePair dflags global' (isDefaultMethod prags)
+                                      (dictArity dicts) rhs
+
+       ; return (force_vars, main_bind : fromOL spec_binds) }
+
+  | otherwise
+  = pprPanic "dsHsBind: AbsBindsSig" (ppr bind)
+
 dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
 
 
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 999b945c0f..357d2fd38f 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -143,6 +143,15 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
+dsUnliftedBind (AbsBindsSig { abs_tvs         = []
+                            , abs_ev_vars     = []
+                            , abs_sig_export  = poly
+                            , abs_sig_ev_bind = ev_bind
+                            , abs_sig_bind    = L _ bind }) body
+  = do { ds_binds <- dsTcEvBinds ev_bind
+       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
+       ; return (mkCoreLets ds_binds body') }
+
 dsUnliftedBind (FunBind { fun_id = L _ fun
                         , fun_matches = matches
                         , fun_co_fn = co_fn
@@ -172,6 +181,8 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 unliftedMatchOnly :: HsBind Id -> Bool
 unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
   = anyBag (unliftedMatchOnly . unLoc) lbinds
+unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
+  = unliftedMatchOnly bind
 unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
   =  isUnLiftedType rhs_ty
   || isUnliftedLPat lpat
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f0f5f1b44d..eadd243a11 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1403,6 +1403,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
+rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
 rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
 -----------------------------------------------------------------------------
 -- Since everything in a Bind is mutually recursive we need rename all
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index bc339873fe..b4a84d4e17 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -205,6 +205,20 @@ data HsBindLR idL idR
         abs_binds    :: LHsBinds idL
     }
 
+  | AbsBindsSig {  -- Simpler form of AbsBinds, used with a type sig
+                   -- in tcPolyCheck. Produces simpler desugaring and
+                   -- is necessary to avoid #11405, comment:3.
+        abs_tvs     :: [TyVar],
+        abs_ev_vars :: [EvVar],
+
+        abs_sig_export :: idL,  -- like abe_poly
+        abs_sig_prags  :: TcSpecPrags,
+
+        abs_sig_ev_bind :: TcEvBinds,  -- no list needed here
+        abs_sig_bind    :: LHsBind idL -- always only one, and it's always a
+                                       -- FunBind
+    }
+
   | PatSynBind (PatSynBind idL idR)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
         --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
@@ -550,7 +564,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
                        , abs_ev_binds = ev_binds })
   = sdocWithDynFlags $ \ dflags ->
-    if gopt Opt_PrintTypechekerElaboration dflags then
+    if gopt Opt_PrintTypecheckerElaboration dflags then
       -- Show extra information (bug number: #10662)
       hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
                                     <+> brackets (interpp'SP dictvars))
@@ -563,6 +577,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
       , ptext (sLit "Evidence:") <+> ppr ev_binds ]
     else
       pprLHsBinds val_binds
+ppr_monobind (AbsBindsSig { abs_tvs         = tyvars
+                          , abs_ev_vars     = dictvars
+                          , abs_sig_ev_bind = ev_bind
+                          , abs_sig_bind    = bind })
+  = sdocWithDynFlags $ \ dflags ->
+    if gopt Opt_PrintTypecheckerElaboration dflags then
+      hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
+                               <+> brackets (interpp'SP dictvars))
+         2 $ braces $ vcat
+      [ text "Bind:"     <+> ppr bind
+      , text "Evidence:" <+> ppr ev_bind ]
+    else
+      ppr bind
 
 instance (OutputableBndr id) => Outputable (ABExport id) where
   ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index f0a657202b..43f3de6be3 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -773,6 +773,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
         -- I don't think we want the binders from the abe_binds
         -- The only time we collect binders from a typechecked
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
     if omitPatSyn then acc else ps : acc
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 8f490634d4..2a27bdaca9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -390,7 +390,7 @@ data GeneralFlag
    | Opt_PrintUnicodeSyntax
    | Opt_PrintExpandedSynonyms
    | Opt_PrintPotentialInstances
-   | Opt_PrintTypechekerElaboration
+   | Opt_PrintTypecheckerElaboration
 
    -- optimisation opts
    | Opt_CallArity
@@ -3047,7 +3047,7 @@ fFlags = [
   flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,
   flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,
   flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,
-  flagSpec "print-typechecker-elaboration"    Opt_PrintTypechekerElaboration,
+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,
   flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,
   flagSpec "prof-count-entries"               Opt_ProfCountEntries,
   flagSpec "regs-graph"                       Opt_RegsGraph,
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 12dec4c8ae..905d9c71f0 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -593,7 +593,7 @@ tcPolyCheck rec_tc prag_fn
                  -- there is was one.  This will appear in messages like
                  -- "type variable x is bound by .. at <loc>"
              name = idName poly_id
-       ; (ev_binds, (binds', [mono_info]))
+       ; (ev_binds, (binds', _))
             <- setSrcSpan loc $
                checkConstraints skol_info skol_tvs ev_vars $
                tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]
@@ -601,15 +601,17 @@ tcPolyCheck rec_tc prag_fn
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
        ; poly_id    <- addInlinePrags poly_id prag_sigs
 
-       ; let export = ABE { abe_wrap      = idHsWrapper
-                          , abe_inst_wrap = idHsWrapper
-                          , abe_poly      = poly_id
-                          , abe_mono      = mbi_mono_id mono_info
-                          , abe_prags     = SpecPrags spec_prags }
-             abs_bind = L loc $ AbsBinds
+       ; let bind' = case bagToList binds' of
+                       [b] -> b
+                       _   -> pprPanic "tcPolyCheck" (ppr binds')
+             abs_bind = L loc $ AbsBindsSig
                         { abs_tvs = skol_tvs
-                        , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
-                        , abs_exports = [export], abs_binds = binds' }
+                        , abs_ev_vars = ev_vars
+                        , abs_sig_export = poly_id
+                        , abs_sig_prags = SpecPrags spec_prags
+                        , abs_sig_ev_bind = ev_binds
+                        , abs_sig_bind    = bind' }
+
        ; return (unitBag abs_bind, [poly_id]) }
 
 tcPolyCheck _rec_tc _prag_fn sig _bind
@@ -1916,7 +1918,7 @@ data GeneralisationPlan
 
   | CheckGen (LHsBind Name) TcIdSigInfo
                         -- One binding with a signature
-                        -- Explicit generalisation; there is an AbsBinds
+                        -- Explicit generalisation; there is an AbsBindsSig
 
 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
@@ -2006,6 +2008,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
                                                            && no_sig (unLoc v)
     restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
     restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
+    restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
 
     restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
     restricted_match _                                                 = False
@@ -2065,6 +2068,8 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
 
     is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
                      = null tvs && null evs
+    is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
+                     = null tvs && null evs
     is_monomorphic _ = True
 
     check :: Bool -> MsgDoc -> TcM ()
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index a2bbdf8564..d8703a07e5 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -443,6 +443,26 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abe_mono = zonkIdOcc env mono_id
                         , abe_prags = new_prags })
 
+zonk_bind env (AbsBindsSig { abs_tvs         = tyvars
+                           , abs_ev_vars     = evs
+                           , abs_sig_export  = poly
+                           , abs_sig_prags   = prags
+                           , abs_sig_ev_bind = ev_bind
+                           , abs_sig_bind    = bind })
+  = ASSERT( all isImmutableTyVar tyvars )
+    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars
+       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
+       ; new_val_bind        <- zonk_lbind env2 bind
+       ; new_poly_id         <- zonkIdBndr env2 poly
+       ; new_prags           <- zonkSpecPrags env2 prags
+       ; return (AbsBindsSig { abs_tvs         = new_tyvars
+                             , abs_ev_vars     = new_evs
+                             , abs_sig_export  = new_poly_id
+                             , abs_sig_prags   = new_prags
+                             , abs_sig_ev_bind = new_ev_bind
+                             , abs_sig_bind    = new_val_bind  }) }
+
 zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                     , psb_args = details
                                     , psb_def = lpat
diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index c11f9ca52b..450907275b 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/testsuite/tests/dependent/should_compile/all.T
@@ -12,5 +12,5 @@ test('TypeLevelVec',normal,compile, [''])
 test('T9632', normal, compile, [''])
 test('dynamic-paper', normal, compile, [''])
 test('T11311', normal, compile, [''])
-test('T11405', expect_broken(11405), compile, [''])
+test('T11405', normal, compile, [''])
 
diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs
index 58a4f9b7d5..fc0a71ade3 100644
--- a/testsuite/tests/ghc-api/T6145.hs
+++ b/testsuite/tests/ghc-api/T6145.hs
@@ -31,9 +31,11 @@ main = do
                         return $ not $ isEmptyBag fs
         removeFile "Test.hs"
         print ok
-    where 
+    where
       isDataCon (L _ (AbsBinds { abs_binds = bs }))
         = not (isEmptyBag (filterBag isDataCon bs))
+      isDataCon (L _ (AbsBindsSig { abs_sig_bind = b }))
+        = isDataCon b
       isDataCon (L l (f@FunBind {}))
         | (MG (L _ (m:_)) _ _ _) <- fun_matches f,
           (L _ (c@ConPatOut{}):_)<-hsLMatchPats m,
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 551c68b838..1969216956 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -279,7 +279,8 @@ boundThings modname lbinding =
     FunBind { fun_id = id } -> [thing id]
     PatBind { pat_lhs = lhs } -> patThings lhs []
     VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
-    AbsBinds { } -> [] -- nothing interesting in a type abstraction
+    AbsBinds { }    -> [] -- nothing interesting in a type abstraction
+    AbsBindsSig { } -> []
     PatSynBind PSB{ psb_id = id } -> [thing id]
   where thing = foundOfLName modname
         patThings lpat tl =