Set tct_closed to TopLevel for closed bindings.

Summary:
Till now tct_closed determined whether the type of a binding is closed.
With this patch tct_closed indicates whether the binding is closed.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: mboes, thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D2016

GHC Trac Issues: #11698

8 files changed, 119 insertions, 59 deletions

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 496765859d..1a587199cc 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -378,22 +378,41 @@ tcBindGroups _ _ _ [] thing_inside
         ; return ([], thing) }
 
 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
-  = do  { (group', (groups', thing))
-                <- tc_group top_lvl sig_fn prag_fn group $
+  = do  { -- See Note [Closed binder groups]
+          closed <- isClosedBndrGroup $ snd group
+        ; (group', (groups', thing))
+                <- tc_group top_lvl sig_fn prag_fn group closed $
                    tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
         ; return (group' ++ groups', thing) }
 
+-- Note [Closed binder groups]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+--  A mutually recursive group is "closed" if all of the free variables of
+--  the bindings are closed. For example
+--
+-- >  h = \x -> let f = ...g...
+-- >                g = ....f...x...
+-- >             in ...
+--
+-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
+-- closed.
+--
+-- So we need to compute closed-ness on each strongly connected components,
+-- before we sub-divide it based on what type signatures it has.
+--
+
 ------------------------
 tc_group :: forall thing.
             TopLevelFlag -> TcSigFun -> TcPragEnv
-         -> (RecFlag, LHsBinds Name) -> TcM thing
+         -> (RecFlag, LHsBinds Name) -> TopLevelFlag -> TcM thing
          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
 -- Typecheck one strongly-connected component of the original program.
 -- We get a list of groups back, because there may
 -- be specialisations etc as well
 
-tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
         -- A single non-recursive binding
         -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly
@@ -401,10 +420,11 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
                  [bind] -> bind
                  []     -> panic "tc_group: empty list of binds"
                  _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
-       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
+                                     thing_inside
        ; return ( [(NonRecursive, bind')], thing) }
 
-tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
   =     -- To maximise polymorphism, we do a new
         -- strongly-connected-component analysis, this time omitting
         -- any references to variables with type signatures.
@@ -425,15 +445,16 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
 
     go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
     go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
-                        ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
-                                             go sccs
+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
+                                                            (go sccs)
                         ; return (binds1 `unionBags` binds2, thing) }
     go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
 
     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
 
-    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
+    tc_sub_group rec_tc binds =
+      tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
 
 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
 recursivePatSynErr binds
@@ -447,9 +468,11 @@ recursivePatSynErr binds
 
 tc_single :: forall thing.
             TopLevelFlag -> TcSigFun -> TcPragEnv
-          -> LHsBind Name -> TcM thing
+          -> LHsBind Name -> TopLevelFlag -> TcM thing
           -> TcM (LHsBinds TcId, thing)
-tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
+tc_single _top_lvl sig_fn _prag_fn
+          (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
+          _ thing_inside
   = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
        ; thing <- setGblEnv tcg_env thing_inside
        ; return (aux_binds, thing)
@@ -461,11 +484,12 @@ tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name }
         Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
         Just                 _  -> panic "tc_single"
 
-tc_single top_lvl sig_fn prag_fn lbind thing_inside
+tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
   = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
                                       NonRecursive NonRecursive
+                                      closed
                                       [lbind]
-       ; thing <- tcExtendLetEnv top_lvl ids thing_inside
+       ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
        ; return (binds1, thing) }
 
 ------------------------
@@ -493,6 +517,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
             -> RecFlag         -- Whether the group is really recursive
             -> RecFlag         -- Whether it's recursive after breaking
                                -- dependencies based on type signatures
+            -> TopLevelFlag    -- Whether the group is closed
             -> [LHsBind Name]  -- None are PatSynBind
             -> TcM (LHsBinds TcId, [TcId])
 
@@ -507,7 +532,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
 -- Knows nothing about the scope of the bindings
 -- None of the bindings are pattern synonyms
 
-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
   = setSrcSpan loc                              $
     recoverM (recoveryCode binder_names sig_fn) $ do
         -- Set up main recover; take advantage of any type sigs
@@ -515,9 +540,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
     { traceTc "------------------------------------------------" Outputable.empty
     ; traceTc "Bindings for {" (ppr binder_names)
     ; dflags   <- getDynFlags
-    ; type_env <- getLclTypeEnv
-    ; let plan = decideGeneralisationPlan dflags type_env
-                         binder_names bind_list sig_fn
+    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
     ; traceTc "Generalisation plan" (ppr plan)
     ; result@(tc_binds, poly_ids) <- case plan of
          NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
@@ -1881,15 +1904,14 @@ instance Outputable GeneralisationPlan where
   ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
 
 decideGeneralisationPlan
-   :: DynFlags -> TcTypeEnv -> [Name]
-   -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
-decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
+   :: DynFlags -> [LHsBind Name] -> TopLevelFlag -> TcSigFun
+   -> GeneralisationPlan
+decideGeneralisationPlan dflags lbinds closed sig_fn
   | unlifted_pat_binds                    = NoGen
   | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig
   | mono_local_binds                      = NoGen
   | otherwise                             = InferGen mono_restriction
   where
-    bndr_set = mkNameSet bndr_names
     binds = map unLoc lbinds
 
     sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan
@@ -1915,32 +1937,8 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
     mono_restriction  = xopt LangExt.MonomorphismRestriction dflags
                      && any restricted binds
 
-    is_closed_ns :: NameSet -> Bool -> Bool
-    is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
-        -- ns are the Names referred to from the RHS of this bind
-
-    is_closed_id :: Name -> Bool
-    -- See Note [Bindings with closed types] in TcRnTypes
-    is_closed_id name
-      | name `elemNameSet` bndr_set
-      = True              -- Ignore binders in this groups, of course
-      | Just thing <- lookupNameEnv type_env name
-      = case thing of
-          ATcId { tct_closed = cl } -> isTopLevel cl  -- This is the key line
-          ATyVar {}                 -> False          -- In-scope type variables
-          AGlobal {}                -> True           --    are not closed!
-          _                         -> pprPanic "is_closed_id" (ppr name)
-      | otherwise
-      = WARN( isInternalName name, ppr name ) True
-        -- The free-var set for a top level binding mentions
-        -- imported things too, so that we can report unused imports
-        -- These won't be in the local type env.
-        -- Ditto class method etc from the current module
-
     mono_local_binds = xopt LangExt.MonoLocalBinds dflags
-                    && not closed_flag
-
-    closed_flag = foldr (is_closed_ns . bind_fvs) True binds
+                    && not (isTopLevel closed)
 
     no_sig n = noCompleteSig (sig_fn n)
 
@@ -1967,6 +1965,38 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
         -- No args => like a pattern binding
         -- Some args => a function binding
 
+isClosedBndrGroup :: Bag (LHsBind Name) -> TcM TopLevelFlag
+isClosedBndrGroup binds = do
+    type_env <- getLclTypeEnv
+    if foldrBag (is_closed_ns type_env . fvs . unLoc) True binds
+      then return TopLevel
+      else return NotTopLevel
+  where
+    fvs :: HsBind Name  -> NameSet
+    fvs (FunBind { bind_fvs = vs }) = vs
+    fvs (PatBind { bind_fvs = vs }) = vs
+    fvs _                           = emptyNameSet
+
+    is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
+    is_closed_ns type_env ns b = foldNameSet ((&&) . is_closed_id type_env) b ns
+        -- ns are the Names referred to from the RHS of this bind
+
+    is_closed_id :: TcTypeEnv -> Name -> Bool
+    -- See Note [Bindings with closed types] in TcRnTypes
+    is_closed_id type_env name
+      | Just thing <- lookupNameEnv type_env name
+      = case thing of
+          ATcId { tct_closed = cl } -> isTopLevel cl  -- This is the key line
+          ATyVar {}                 -> False          -- In-scope type variables
+          AGlobal {}                -> True           --    are not closed!
+          _                         -> pprPanic "is_closed_id" (ppr name)
+      | otherwise
+      = True
+        -- The free-var set for a top level binding mentions
+        -- imported things too, so that we can report unused imports
+        -- These won't be in the local type env.
+        -- Ditto class method etc from the current module
+
 -------------------
 checkStrictBinds :: TopLevelFlag -> RecFlag
                  -> [LHsBind Name]
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index f86156b1b1..b2a31b1edb 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -28,7 +28,7 @@ module TcEnv(
         tcExtendLetEnv, tcExtendLetEnvIds,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
         tcExtendIdBndrs, tcExtendLocalTypeEnv,
-        isClosedLetBndr,
+        isTypeClosedLetBndr,
 
         tcLookup, tcLookupLocated, tcLookupLocalIds,
         tcLookupId, tcLookupTyVar,
@@ -409,29 +409,40 @@ getScopedTyVarBinds
   = do  { lcl_env <- getLclEnv
         ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] }
 
-isClosedLetBndr :: Id -> TopLevelFlag
+isTypeClosedLetBndr :: Id -> TopLevelFlag
 -- See Note [Bindings with closed types] in TcRnTypes
 -- Note that we decided if a let-bound variable is closed by
 -- looking at its type, which is slightly more liberal, and a whole
 -- lot easier to implement, than looking at its free variables
-isClosedLetBndr id
+isTypeClosedLetBndr id
   | isEmptyVarSet (tyCoVarsOfType (idType id)) = TopLevel
   | otherwise                                  = NotTopLevel
 
-tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
+tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a
 -- Used for both top-level value bindings and and nested let/where-bindings
 -- Adds to the TcIdBinderStack too
-tcExtendLetEnv top_lvl ids thing_inside
+tcExtendLetEnv top_lvl closed_group ids thing_inside
   = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
-    tcExtendLetEnvIds top_lvl [(idName id, id) | id <- ids] thing_inside
+    tcExtendLetEnvIds' top_lvl closed_group [(idName id, id) | id <- ids]
+                       thing_inside
 
 tcExtendLetEnvIds :: TopLevelFlag -> [(Name,TcId)] -> TcM a -> TcM a
 -- Used for both top-level value bindings and and nested let/where-bindings
 -- Does not extend the TcIdBinderStack
-tcExtendLetEnvIds top_lvl pairs thing_inside
-  = tc_extend_local_env top_lvl [ (name, ATcId { tct_id = id
-                                               , tct_closed = isClosedLetBndr id })
-                                | (name,id) <- pairs ] $
+tcExtendLetEnvIds top_lvl
+  = tcExtendLetEnvIds' top_lvl TopLevel
+
+tcExtendLetEnvIds' :: TopLevelFlag -> TopLevelFlag -> [(Name,TcId)] -> TcM a
+                   -> TcM a
+-- Used for both top-level value bindings and and nested let/where-bindings
+-- Does not extend the TcIdBinderStack
+tcExtendLetEnvIds' top_lvl closed_group pairs thing_inside
+  = tc_extend_local_env top_lvl
+      [ (name, ATcId { tct_id = id
+                     , tct_closed = case closed_group of
+                         TopLevel -> isTypeClosedLetBndr id
+                         _        -> closed_group           })
+                     | (name,id) <- pairs ] $
     thing_inside
 
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index de27b94e9f..1e34fc683c 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -757,7 +757,7 @@ tcInstDecls2 tycl_decls inst_decls
         ; let dm_ids = collectHsBindsBinders dm_binds
               -- Add the default method Ids (again)
               -- See Note [Default methods and instances]
-        ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
+        ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $
                           mapM tcInstDecl2 inst_decls
 
           -- Done
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 952e4ebfca..00f1960818 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1629,7 +1629,7 @@ runTcInteractive hsc_env thing_inside
     -- See Note [Initialising the type environment for GHCi]
     is_closed thing
       | AnId id <- thing
-      , NotTopLevel <- isClosedLetBndr id
+      , NotTopLevel <- isTypeClosedLetBndr id
       = Left (idName id, ATcId { tct_id = id, tct_closed = NotTopLevel })
       | otherwise
       = Right thing
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 8d8ce4ec6c..056848ab4c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -962,10 +962,14 @@ environment that makes things tricky for OutsideIn generalisation.
 Definition:
    A variable is "closed", and has tct_closed set to TopLevel,
 iff
-   a) all its free variables are imported, or are let-bound with closed types
+   a) all its free variables are imported, or are let-bound and closed
    b) generalisation is not restricted by the monomorphism restriction
 
 Invariant: a closed variable has no free type variables in its type.
+Why? Assume (induction hypothesis) that closed variables have closed
+types, and that we have a new binding f = e, satisfying (a) and (b).
+Then since monomorphism restriction does not apply, and there are no
+free type variables, we can fully generalise, so its type will be closed.
 
 Under OutsideIn we are free to generalise a closed let-binding.
 This is an extension compared to the JFP paper on OutsideIn, which
diff --git a/testsuite/tests/typecheck/should_fail/T11698.hs b/testsuite/tests/typecheck/should_fail/T11698.hs
new file mode 100644
index 0000000000..114df043c4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11698.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE MonoLocalBinds #-}
+module T11698 where
+
+f x = (k 'v', k True)
+  where
+    h = const True x
+    k z = const h (k z) -- k type should not be generalized because h is closed.
diff --git a/testsuite/tests/typecheck/should_fail/T11698.stderr b/testsuite/tests/typecheck/should_fail/T11698.stderr
new file mode 100644
index 0000000000..4f2cf8e717
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11698.stderr
@@ -0,0 +1,7 @@
+
+T11698.hs:4:17: error:
+    • Couldn't match expected type ‘Char’ with actual type ‘Bool’
+    • In the first argument of ‘k’, namely ‘True’
+      In the expression: k True
+      In the expression: (k 'v', k True)
+
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 867ea38e84..c1c7818a46 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -412,3 +412,4 @@ test('T11313', normal, compile_fail, [''])
 test('T11723', normal, compile_fail, [''])
 test('T11724', normal, compile_fail, [''])
 test('BadUnboxedTuple', normal, compile_fail, [''])
+test('T11698', normal, compile_fail, [''])