Restore identifiers missing from hi file (haskell/ghcide#741)

This

* fixes a part of https://github.com/digital-asset/ghcide/issues/614
  by introducing a workaround for ghc droping some bindings that we still
  need.

* Adds a regression test for this fix

* Adds a known broken test for the remaining part of the issue

ghcide/src/Development/IDE/Core/Compile.hs

@@ -130,13 +130,14 @@ typecheckModule (IdeDefer defer) hsc pm = do
             dflags = ms_hspp_opts modSummary
 
         modSummary' <- initPlugins modSummary
-        (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
+        (warnings, tcm1) <- withWarnings "typecheck" $ \tweak ->
             GHC.typecheckModule $ enableTopLevelWarnings
                                 $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
+        tcm2 <- liftIO $ fixDetailsForTH tcm1
         let errorPipeline = unDefer . hideDiag dflags
             diags = map errorPipeline warnings
-        tcm2 <- mkTcModuleResult tcm (any fst diags)
-        return (map snd diags, tcm2)
+        tcm3 <- mkTcModuleResult tcm2 (any fst diags)
+        return (map snd diags, tcm3)
     where
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 

ghcide/src/Development/IDE/GHC/Compat.hs

@@ -54,6 +54,7 @@ module Development.IDE.GHC.Compat(
     getLoc,
     upNameCache,
     disableWarningsAsErrors,
+    fixDetailsForTH,
 
     module GHC,
     initializePlugins,
@@ -110,6 +111,16 @@ import Avail
 import Data.List (foldl')
 import ErrUtils (ErrorMessages)
 import FastString (FastString)
+import ConLike   (ConLike (PatSynCon))
+#if MIN_GHC_API_VERSION(8,8,0)
+import InstEnv   (updateClsInstDFun)
+import PatSyn    (PatSyn, updatePatSynIds)
+#else
+import InstEnv   (tidyClsInstDFun)
+import PatSyn    (PatSyn, tidyPatSynIds)
+#endif
+
+import TcRnTypes
 
 #if MIN_GHC_API_VERSION(8,6,0)
 import Development.IDE.GHC.HieAst (mkHieFile)
@@ -128,19 +139,20 @@ import System.FilePath ((-<.>))
 
 #endif
 
-#if !MIN_GHC_API_VERSION(8,8,0)
+#if MIN_GHC_API_VERSION(8,8,0)
+import GhcPlugins (Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, ppr, pprPanic, isWiredInName, elemNameSet, idName, filterOut)
+# else
 import qualified EnumSet
 
 #if MIN_GHC_API_VERSION(8,6,0)
-import GhcPlugins (srcErrorMessages)
+import GhcPlugins (srcErrorMessages, Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, isWiredInName, elemNameSet, idName, filterOut)
 import Data.List (isSuffixOf)
 #else
 import System.IO.Error
 import IfaceEnv
 import Binary
 import Data.ByteString (ByteString)
-import GhcPlugins (Hsc, srcErrorMessages)
-import TcRnTypes
+import GhcPlugins (Hsc, srcErrorMessages, Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, isWiredInName, elemNameSet, idName, filterOut)
 import MkIface
 #endif
 
@@ -495,3 +507,77 @@ applyPluginsParsedResultAction _env _dflags _ms _hpm_annotations parsed =
     return parsed
 #endif
 
+-- | This function recalculates the fields md_types and md_insts in the ModDetails.
+-- It duplicates logic from GHC mkBootModDetailsTc to keep more ids,
+-- because ghc drops ids in tcg_keep, which matters because TH identifiers
+-- might be in there.  See the original function for more comments.
+fixDetailsForTH :: TypecheckedModule -> IO TypecheckedModule
+fixDetailsForTH tcm = do
+   keep_ids <- readIORef keep_ids_ptr
+   let
+    keep_it id | isWiredInName id_name           = False
+                 -- See Note [Drop wired-in things]
+               | isExportedId id                 = True
+               | id_name `elemNameSet` exp_names = True
+               | id_name `elemNameSet` keep_ids  = True -- This is the line added in comparison to the original function.
+               | otherwise                       = False
+               where
+                 id_name = idName id
+    final_ids = [ globaliseAndTidyBootId id
+                | id <- typeEnvIds type_env
+                , keep_it id ]
+    final_tcs  = filterOut (isWiredInName . getName) tcs
+    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts
+    insts'     = mkFinalClsInsts type_env1 insts
+    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns
+    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1
+    fixedDetails = details {
+                         md_types         = type_env'
+                       , md_insts         = insts'
+                       }
+   pure $ tcm { tm_internals_ = (tc_gbl_env, fixedDetails) }
+ where
+    (tc_gbl_env, details) = tm_internals_ tcm
+    TcGblEnv{ tcg_exports          = exports,
+              tcg_type_env         = type_env,
+              tcg_tcs              = tcs,
+              tcg_patsyns          = pat_syns,
+              tcg_insts            = insts,
+              tcg_fam_insts        = fam_insts,
+              tcg_keep             = keep_ids_ptr
+            } = tc_gbl_env
+    exp_names = availsToNameSet exports
+
+-- Functions from here are only pasted from ghc TidyPgm.hs
+
+mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
+mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]
+#if MIN_GHC_API_VERSION(8,8,0)
+mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
+mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))
+
+lookupFinalId :: TypeEnv -> Id -> Id
+lookupFinalId type_env id
+  = case lookupTypeEnv type_env (idName id) of
+      Just (AnId id') -> id'
+      _ -> pprPanic "lookup_final_id" (ppr id)
+#else
+mkFinalClsInsts _env = map (tidyClsInstDFun globaliseAndTidyBootId)
+mkFinalPatSyns _env = map (tidyPatSynIds globaliseAndTidyBootId)
+#endif
+
+
+extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
+extendTypeEnvWithPatSyns tidy_patsyns type_env
+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
+
+globaliseAndTidyBootId :: Id -> Id
+-- For a LocalId with an External Name,
+-- makes it into a GlobalId
+--     * unchanged Name (might be Internal or External)
+--     * unchanged details
+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
+--     * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
+globaliseAndTidyBootId id
+  = globaliseId id `setIdType`      tidyTopType (idType id)
+                   `setIdUnfolding` BootUnfolding

ghcide/test/data/THNewName/A.hs

@@ -0,0 +1,6 @@
+module A (template) where
+
+import Language.Haskell.TH
+
+template :: DecsQ
+template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A"

ghcide/test/data/THNewName/B.hs

@@ -0,0 +1,5 @@
+module B(A(A)) where
+
+import A
+
+template

ghcide/test/data/THNewName/C.hs

@@ -0,0 +1,4 @@
+module C where
+import B
+
+a = A

ghcide/test/data/THNewName/hie.yaml

@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}}

ghcide/test/exe/Main.hs

@@ -2426,6 +2426,38 @@ thTests =
         _ <- createDoc "B.hs" "haskell" sourceB
         return ()
     , thReloadingTest `xfail` "expect broken (#672)"
+    -- Regression test for https://github.com/digital-asset/ghcide/issues/614
+    , testSessionWait "findsTHIdentifiers" $ do
+        let sourceA =
+              T.unlines
+                [ "{-# LANGUAGE TemplateHaskell #-}"
+                , "module A (a) where"
+                , "a = [| glorifiedID |]"
+                , "glorifiedID :: a -> a"
+                , "glorifiedID = id" ]
+        let sourceB =
+              T.unlines
+                [ "{-# OPTIONS_GHC -Wall #-}"
+                , "{-# LANGUAGE TemplateHaskell #-}"
+                , "module B where"
+                , "import A"
+                , "main = $a (putStrLn \"success!\")"]
+        _ <- createDoc "A.hs" "haskell" sourceA
+        _ <- createDoc "B.hs" "haskell" sourceB
+        expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]
+#if MIN_GHC_API_VERSION(8,6,0)
+    , flip xfail "expect broken (#614)" $ testCase "findsTHnewNameConstructor" $ withoutStackEnv $ runWithExtraFiles "THNewName" $ \dir -> do
+
+    -- This test defines a TH value with the meaning "data A = A" in A.hs
+    -- Loads and export the template in B.hs
+    -- And checks wether the constructor A can be loaded in C.hs
+    -- This test does not fail when either A and B get manually loaded before C.hs
+    -- or when we remove the seemingly unnecessary TH pragma from C.hs
+
+    let cPath = dir </> "C.hs"
+    _ <- openDoc cPath "haskell"
+    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]
+#endif
     ]
 
 -- | test that TH is reevaluated on typecheck