[Git][ghc/ghc][wip/haddock-object-files] haddock: Handle non-hs files, so that haddock can generate documentation for modules with

[Zubin (@wz1000)]

Zubin pushed to branch wip/haddock-object-files at Glasgow Haskell Compiler / GHC


Commits:
04236fbd by Zubin Duggal at 2024-07-09T17:30:26+05:30
haddock: Handle non-hs files, so that haddock can generate documentation for modules with
foreign imports and template haskell.

Fixes #24964

- - - - -


7 changed files:

- testsuite/tests/haddock/haddock_testsuite/Makefile
- testsuite/tests/haddock/haddock_testsuite/all.T
- + testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/A.hs
- + testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/B.hs
- + testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/F.hs
- + testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/arith.c
- utils/haddock/haddock-api/src/Haddock/Interface.hs


Changes:

=====================================
testsuite/tests/haddock/haddock_testsuite/Makefile
=====================================
@@ -72,3 +72,7 @@ hypsrcTest:
 		$(ACCEPT) \
 		--ghc-path='$(TEST_HC)' \
 		--haddock-path='$(HADDOCK)' \
+
+.PHONY: haddockForeignTest
+haddockForeignTest:
+	'$(HADDOCK)' A.hs B.hs F.hs arith.c


=====================================
testsuite/tests/haddock/haddock_testsuite/all.T
=====================================
@@ -19,3 +19,8 @@ test('haddockHypsrcTest',
      [ignore_stdout, ignore_stderr, req_haddock],
      makefile_test,
      ['hypsrcTest ' + accept])
+
+test('haddockForeignTest',
+     [ignore_stdout, ignore_stderr, req_haddock, extra_files(['./haddock-th-foreign-repro/A.hs', './haddock-th-foreign-repro/B.hs', './haddock-th-foreign-repro/F.hs', './haddock-th-foreign-repro/arith.c'])],
+     makefile_test,
+     ['haddockForeignTest'])


=====================================
testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/A.hs
=====================================
@@ -0,0 +1,8 @@
+module A where
+
+import Language.Haskell.TH
+import F
+
+
+foo :: Exp
+foo = LitE (StringL "foo")


=====================================
testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/B.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module B where
+
+import A
+
+$([d| bar = $(return foo) |])


=====================================
testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/F.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module F where
+
+foreign import ccall "some_c_function" c_some_c_function :: IO ()


=====================================
testsuite/tests/haddock/haddock_testsuite/haddock-th-foreign-repro/arith.c
=====================================
@@ -0,0 +1 @@
+void some_c_function(void) {}


=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE TupleSections     #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface
@@ -58,6 +59,8 @@ import GHC.Core.InstEnv
 import qualified GHC.Driver.DynFlags as DynFlags
 import qualified GHC.Utils.Outputable as Outputable
 import GHC.Driver.Session hiding (verbosity)
+import GHC.Driver.Phases
+import GHC.Driver.Pipeline (compileFile)
 import GHC.HsToCore.Docs (getMainDeclBinder)
 import GHC.Iface.Load (loadSysInterface)
 import GHC.IfaceToCore (tcIfaceInst, tcIfaceFamInst)
@@ -73,6 +76,7 @@ import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot)
 import GHC.Unit.Module.ModSummary (isBootSummary)
 import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text)
 import GHC.Utils.Error (withTiming)
+import GHC.Utils.Monad (mapMaybeM)
 
 #if defined(mingw32_HOST_OS)
 import System.IO
@@ -165,7 +169,15 @@ createIfaces
     -> Ghc [Interface]
     -- ^ Resulting interfaces
 createIfaces verbosity modules flags instIfaceMap = do
-  targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules
+  let (hs_srcs, non_hs_srcs) = List.partition isHaskellishTarget $ map (,Nothing) modules
+  hsc_env <- getSession
+  o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)
+             non_hs_srcs
+  dflags <- getSessionDynFlags
+  let dflags' = dflags { ldInputs = map (FileOption "") o_files
+                                    ++ ldInputs dflags }
+  _ <- setSessionDynFlags dflags'
+  targets <- mapM (\(filePath, _) -> guessTarget filePath Nothing Nothing) hs_srcs
   setTargets targets
   (_errs, modGraph) <- depanalE [] False
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04236fbdb3b78b3e03f862427b7b145b7642a928

-- 
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04236fbdb3b78b3e03f862427b7b145b7642a928
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240709/195dd8b9/attachment-0001.html>