aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Html.hs4
-rw-r--r--src/Haddock/GHC.hs16
-rw-r--r--src/Haddock/Interface.hs47
-rw-r--r--src/Haddock/InterfaceFile.hs23
-rw-r--r--src/Haddock/Utils.hs11
-rw-r--r--src/Main.hs19
6 files changed, 100 insertions, 20 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 7d44d452..8b72c1ac 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -36,7 +36,11 @@ import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
+#if __GLASGOW_HASKELL__ >= 609
import GHC hiding ( NoLink, moduleInfo )
+#else
+import GHC hiding ( NoLink )
+#endif
import Name
import Module
import PackageConfig
diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs
index ff1c58e4..c53c3a83 100644
--- a/src/Haddock/GHC.hs
+++ b/src/Haddock/GHC.hs
@@ -30,16 +30,21 @@ import SrcLoc
-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking.
+#if __GLASGOW_HASKELL__ >= 609
startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
startGhc libDir flags ghcActs = do
-- TODO: handle warnings?
-#if __GLASGOW_HASKELL__ >= 609
(restFlags, _) <- parseStaticFlags (map noLoc flags)
+ runGhc (Just libDir) $ do
+ dynflags <- getSessionDynFlags
#else
+startGhc :: String -> [String] -> IO (Session, DynFlags)
+startGhc libDir flags = do
restFlags <- parseStaticFlags flags
+ session <- newSession (Just libDir)
+ dynflags <- getSessionDynFlags session
+ do
#endif
- runGhc (Just libDir) $ do
- dynflags <- getSessionDynFlags
let dynflags' = dopt_set dynflags Opt_Haddock
let dynflags'' = dynflags' {
hscTarget = HscAsm,
@@ -47,8 +52,13 @@ startGhc libDir flags ghcActs = do
ghcLink = NoLink
}
dynflags''' <- parseGhcFlags dynflags'' restFlags flags
+#if __GLASGOW_HASKELL__ >= 609
setSessionDynFlags dynflags'''
ghcActs dynflags'''
+#else
+ setSessionDynFlags session dynflags'''
+ return (session, dynflags''')
+#endif
-- | Expose the list of packages to GHC. Then initialize GHC's package state
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index eb9aca69..73c08018 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -23,6 +23,7 @@ import Haddock.Options
import Haddock.GHC.Utils
import Haddock.GHC.Typecheck
import Haddock.Exception
+import Haddock.Utils
import qualified Data.Map as Map
import Data.Map (Map)
@@ -35,17 +36,21 @@ import HscTypes ( msHsFilePath )
import Digraph
import BasicTypes
import SrcLoc
-import MonadUtils ( liftIO )
-- | Turn a topologically sorted list of module names/filenames into interfaces. Also
-- return the home link environment created in the process, and any error messages.
+#if __GLASGOW_HASKELL__ >= 609
createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
createInterfaces modules externalLinks flags = do
-
-- part 1, create interfaces
interfaces <- createInterfaces' modules flags
-
+#else
+createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
+createInterfaces session modules externalLinks flags = do
+ -- part 1, create interfaces
+ interfaces <- createInterfaces' session modules flags
+#endif
-- part 2, build link environment
let homeLinks = buildHomeLinks interfaces
links = homeLinks `Map.union` externalLinks
@@ -63,6 +68,7 @@ createInterfaces modules externalLinks flags = do
return (interfaces'', homeLinks)
+#if __GLASGOW_HASKELL__ >= 609
createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
createInterfaces' modules flags = do
targets <- mapM (\f -> guessTarget f Nothing) modules
@@ -71,6 +77,23 @@ createInterfaces' modules flags = do
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
interface <- processModule modsum flags modMap
+#else
+createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
+createInterfaces' session modules flags = do
+ targets <- mapM (\f -> guessTarget f Nothing) modules
+ setTargets session targets
+ mbGraph <- depanal session [] False
+ modgraph <- case mbGraph of
+ Just graph -> return graph
+ Nothing -> throwE "Failed to create dependecy graph"
+ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
+ (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
+ interface <- processModule session modsum flags modMap
+#endif
+ return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
+ ) ([], Map.empty) orderedMods
+ return (reverse ifaces)
+
{- liftIO $ do
putStrLn . ppModInfo $ ifaceInfo interface
putStrLn . show $ fmap pretty (ifaceDoc interface)
@@ -84,9 +107,6 @@ createInterfaces' modules flags = do
mapM (putStrLn . pretty) (ifaceInstances interface)
mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b) (Map.toList $ ifaceSubMap interface)
mapM (putStrLn . pretty) (ifaceInstances interface)-}
- return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
- ) ([], Map.empty) orderedMods
- return (reverse ifaces)
{-
@@ -106,6 +126,7 @@ ppExportItem (ExportModule mod) = pretty mod
ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d
-}
+#if __GLASGOW_HASKELL__ >= 609
processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface
processModule modsum flags modMap =
@@ -128,8 +149,20 @@ processModule modsum flags modMap =
let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
liftIO $ mapM_ putStrLn msg
return interface
+#else
+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
+processModule session modsum flags modMap = do
+ let filename = msHsFilePath modsum
+ mbMod <- checkAndLoadModule session modsum False
+ ghcMod <- case mbMod of
+ Just (CheckedModule a (Just b) (Just c) (Just d) _)
+ -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
+ _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
+ let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+ mapM_ putStrLn msg
+ return interface
+#endif
-
-- | Build a mapping which for each original name, points to the "best"
-- place to link to in the documentation. For the definition of
-- "best", we use "the module nearest the bottom of the dependency
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 226d3acc..9ad22431 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -15,6 +15,7 @@ module Haddock.InterfaceFile (
import Haddock.DocName ()
import Haddock.Types
+import Haddock.Utils
import Data.List
import Data.Word
@@ -37,7 +38,6 @@ import FastMutInt
import HsDoc
import FastString
import Unique
-import MonadUtils ( MonadIO(..) )
data InterfaceFile = InterfaceFile {
@@ -57,16 +57,7 @@ binaryInterfaceMagic = 0xD0Cface
-- Instead of adding one, we add three to all version numbers
-- when one of our own (stored) datatypes is changed.
binaryInterfaceVersion :: Word16
-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2
binaryInterfaceVersion = 2
-#endif
-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3
-binaryInterfaceVersion = 3
-#endif
-#if __GLASGOW_HASKELL__ >= 609
-binaryInterfaceVersion = 4
-#endif
-
initBinMemSize :: Int
initBinMemSize = 1024*1024
@@ -145,6 +136,8 @@ writeInterfaceFile filename iface = do
type NameCacheAccessor m = (m NameCache, NameCache -> m ())
+
+#if __GLASGOW_HASKELL__ >= 609
nameCacheFromGhc :: NameCacheAccessor Ghc
nameCacheFromGhc = ( read_from_session , write_to_session )
where
@@ -154,6 +147,16 @@ nameCacheFromGhc = ( read_from_session , write_to_session )
write_to_session nc' = do
ref <- withSession (return . hsc_NC)
liftIO $ writeIORef ref nc'
+#else
+nameCacheFromGhc :: Session -> NameCacheAccessor IO
+nameCacheFromGhc session = ( read_from_session , write_to_session )
+ where
+ read_from_session = readIORef . hsc_NC =<< sessionHscEnv session
+ write_to_session nc' = do
+ ref <- liftM hsc_NC $ sessionHscEnv session
+ writeIORef ref nc'
+#endif
+
freshNameCache :: NameCacheAccessor IO
freshNameCache = ( create_fresh_nc , \_ -> return () )
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 5743cbe1..8fe64b30 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -36,6 +36,9 @@ module Haddock.Utils (
-- * Binary extras
-- FormatVersion, mkFormatVersion
+
+ -- * MTL stuff
+ MonadIO(..)
) where
import Haddock.Types
@@ -64,6 +67,14 @@ import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( hPutStr, stderr )
import System.IO.Unsafe ( unsafePerformIO )
+#if __GLASGOW_HASKELL__ >= 609
+import MonadUtils ( MonadIO(..) )
+#else
+class Monad m => MonadIO m where
+ liftIO :: IO a -> m a
+instance MonadIO IO where liftIO = id
+#endif
+
-- -----------------------------------------------------------------------------
-- Some Utilities
diff --git a/src/Main.hs b/src/Main.hs
index dce204d1..d2b99f11 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -161,6 +161,7 @@ main = handleTopExceptions $ do
return libdir -- from GHC.Paths
#endif
+#if __GLASGOW_HASKELL__ >= 609
-- initialize GHC
startGhc libDir (ghcFlags flags) $ \dynflags -> do
@@ -179,7 +180,25 @@ main = handleTopExceptions $ do
-- last but not least, dump the interface file
dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+#else
+ -- initialize GHC
+ (session, dynflags) <- startGhc libDir (ghcFlags flags)
+
+ -- get packages supplied with --read-interface
+ packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
+ -- combine the link envs of the external packages into one
+ let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
+
+ -- create the interfaces -- this is the core part of Haddock
+ (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags
+
+ -- render the interfaces
+ renderStep packages interfaces
+
+ -- last but not least, dump the interface file
+ dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+#endif
else do
-- get packages supplied with --read-interface
packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 07:42:21 +0000