aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/DocName.hs13
-rw-r--r--src/Haddock/Exception.hs1
-rw-r--r--src/Haddock/GHC/Utils.hs11
-rw-r--r--src/Haddock/InterfaceFile.hs106
-rw-r--r--src/Haddock/Types.hs3
-rw-r--r--src/Haddock/Utils.hs3
6 files changed, 65 insertions, 72 deletions
diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs
index 66170d8c..7977046c 100644
--- a/src/Haddock/DocName.hs
+++ b/src/Haddock/DocName.hs
@@ -11,13 +11,9 @@
module Haddock.DocName where
-import Haddock.GHC.Utils
-
import GHC
-import OccName
import Name
import Binary
-import Outputable
data DocName = Documented Name Module | Undocumented Name
@@ -33,10 +29,10 @@ docNameOrig (Undocumented name) = name
instance Binary DocName where
- put_ bh (Documented name mod) = do
+ put_ bh (Documented name modu) = do
putByte bh 0
put_ bh name
- put_ bh mod
+ put_ bh modu
put_ bh (Undocumented name) = do
putByte bh 1
put_ bh name
@@ -46,8 +42,9 @@ instance Binary DocName where
case h of
0 -> do
name <- get bh
- mod <- get bh
- return (Documented name mod)
+ modu <- get bh
+ return (Documented name modu)
1 -> do
name <- get bh
return (Undocumented name)
+ _ -> error "get DocName: Bad h"
diff --git a/src/Haddock/Exception.hs b/src/Haddock/Exception.hs
index b537127c..eabc722e 100644
--- a/src/Haddock/Exception.hs
+++ b/src/Haddock/Exception.hs
@@ -25,6 +25,7 @@ instance Show HaddockException where
show (HaddockException str) = str
+throwE :: String -> a
#if __GLASGOW_HASKELL__ >= 609
instance Exception HaddockException
throwE str = throw (HaddockException str)
diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs
index f0423303..549482ef 100644
--- a/src/Haddock/GHC/Utils.hs
+++ b/src/Haddock/GHC/Utils.hs
@@ -12,15 +12,10 @@
module Haddock.GHC.Utils where
-#if __GLASGOW_HASKELL__ >= 609
-import Distribution.Text
-#endif
-
import Data.Char
import Data.Version
import qualified Data.Map as Map
-import GHC
import HsSyn
import SrcLoc
import Outputable
@@ -42,18 +37,20 @@ moduleString = moduleNameString . moduleName
-- return the name of the package, with version info
+modulePackageString :: Module -> String
modulePackageString = packageIdString . modulePackageId
-- return the (name,version) of the package
-modulePackageInfo mod = case unpackPackageId pkg of
+modulePackageInfo :: Module -> (String, [Char])
+modulePackageInfo modu = case unpackPackageId pkg of
Nothing -> (packageIdString pkg, "")
#if __GLASGOW_HASKELL__ >= 609
Just x -> (display $ pkgName x, showVersion (pkgVersion x))
#else
Just x -> (pkgName x, showVersion (pkgVersion x))
#endif
- where pkg = modulePackageId mod
+ where pkg = modulePackageId modu
mkModuleNoPackage :: String -> Module
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 5ebf652c..6d96ffa5 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
--
-- Haddock - A Haskell Documentation Tool
--
@@ -14,7 +15,6 @@ module Haddock.InterfaceFile (
import Haddock.DocName ()
import Haddock.Types
-import Haddock.Exception
import Data.List
import Data.Word
@@ -32,10 +32,8 @@ import UniqSupply
import UniqFM
import IfaceEnv
import Module
-import Packages
import HscTypes
import FastMutInt
-import InstEnv
import HsDoc
import FastString
import Unique
@@ -75,17 +73,17 @@ initBinMemSize = 1024*1024
writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
writeInterfaceFile filename iface = do
- bh <- openBinMem initBinMemSize
- put_ bh binaryInterfaceMagic
- put_ bh binaryInterfaceVersion
+ bh0 <- openBinMem initBinMemSize
+ put_ bh0 binaryInterfaceMagic
+ put_ bh0 binaryInterfaceVersion
-- remember where the dictionary pointer will go
- dict_p_p <- tellBin bh
- put_ bh dict_p_p
+ dict_p_p <- tellBin bh0
+ put_ bh0 dict_p_p
-- remember where the symbol table pointer will go
- symtab_p_p <- tellBin bh
- put_ bh symtab_p_p
+ symtab_p_p <- tellBin bh0
+ put_ bh0 symtab_p_p
-- Make some intial state
#if __GLASGOW_HASKELL__ >= 609
@@ -107,7 +105,7 @@ writeInterfaceFile filename iface = do
#endif
-- put the main thing
- bh <- return $ setUserData bh ud
+ bh <- return $ setUserData bh0 ud
put_ bh iface
-- write the symtab pointer at the fornt of the file
@@ -117,13 +115,13 @@ writeInterfaceFile filename iface = do
-- write the symbol table itself
#if __GLASGOW_HASKELL__ >= 609
- symtab_next <- readFastMutInt symtab_next
- symtab_map <- readIORef symtab_map
+ symtab_next' <- readFastMutInt symtab_next
+ symtab_map' <- readIORef symtab_map
#else
- symtab_next <- readFastMutInt (ud_symtab_next ud)
- symtab_map <- readIORef (ud_symtab_map ud)
+ symtab_next' <- readFastMutInt (ud_symtab_next ud)
+ symtab_map' <- readIORef (ud_symtab_map ud)
#endif
- putSymbolTable bh symtab_next symtab_map
+ putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBin bh
@@ -150,10 +148,10 @@ writeInterfaceFile filename iface = do
-- registers all read names in the name cache of the session.
readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile)
readInterfaceFile mbSession filename = do
- bh <- readBinMem filename
+ bh0 <- readBinMem filename
- magic <- get bh
- version <- get bh
+ magic <- get bh0
+ version <- get bh0
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
@@ -163,15 +161,15 @@ readInterfaceFile mbSession filename = do
| otherwise -> do
-- get the dictionary
- dict_p <- get bh
- data_p <- tellBin bh
- seekBin bh dict_p
- dict <- getDictionary bh
- seekBin bh data_p
+ dict_p <- get bh0
+ data_p <- tellBin bh0
+ seekBin bh0 dict_p
+ dict <- getDictionary bh0
+ seekBin bh0 data_p
- -- initialise the user-data field of bh
+ -- initialise the user-data field of bh0
ud <- newReadState dict
- bh <- return (setUserData bh ud)
+ bh1 <- return (setUserData bh0 ud)
-- get the name cache from ghc if we have a ghc session,
-- otherwise create a new one
@@ -186,11 +184,11 @@ readInterfaceFile mbSession filename = do
return (initNameCache u [], Nothing)
-- get the symbol table
- symtab_p <- get bh
- data_p <- tellBin bh
- seekBin bh symtab_p
- (nc', symtab) <- getSymbolTable bh theNC
- seekBin bh data_p
+ symtab_p <- get bh1
+ data_p' <- tellBin bh1
+ seekBin bh1 symtab_p
+ (nc', symtab) <- getSymbolTable bh1 theNC
+ seekBin bh1 data_p'
-- write back the new name cache if we have a ghc session
case mbRef of
@@ -198,11 +196,11 @@ readInterfaceFile mbSession filename = do
Nothing -> return ()
-- set the symbol table
- let ud = getUserData bh
- bh <- return $! setUserData bh ud{ud_symtab = symtab}
+ let ud' = getUserData bh1
+ bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab}
-- load the actual data
- iface <- get bh
+ iface <- get bh2
return (Right iface)
@@ -240,14 +238,14 @@ putFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} bh f
= do
out <- readIORef out_r
- let uniq = getUnique f
- case lookupUFM out uniq of
+ let unique = getUnique f
+ case lookupUFM out unique of
Just (j, _) -> put_ bh j
Nothing -> do
j <- readFastMutInt j_r
put_ bh j
writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM out uniq (j, f)
+ writeIORef out_r $! addToUFM out unique (j, f)
data BinDictionary = BinDictionary {
@@ -282,28 +280,28 @@ fromOnDiskName
-> NameCache
-> OnDiskName
-> (NameCache, Name)
-fromOnDiskName arr nc (pid, mod_name, occ) =
+fromOnDiskName _ nc (pid, mod_name, occ) =
let
- mod = mkModule pid mod_name
+ modu = mkModule pid mod_name
cache = nsNames nc
in
- case lookupOrigNameCache cache mod occ of
+ case lookupOrigNameCache cache modu occ of
Just name -> (nc, name)
Nothing ->
let
us = nsUniqs nc
- uniq = uniqFromSupply us
- name = mkExternalName uniq mod occ noSrcSpan
- new_cache = extendNameCache cache mod occ name
+ u = uniqFromSupply us
+ name = mkExternalName u modu occ noSrcSpan
+ new_cache = extendNameCache cache modu occ name
in
case splitUniqSupply us of { (us',_) ->
( nc{ nsUniqs = us', nsNames = new_cache }, name )
}
serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
-serialiseName bh name symtab = do
- let mod = nameModule name
- put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+serialiseName bh name _ = do
+ let modu = nameModule name
+ put_ bh (modulePackageId modu, moduleName modu, nameOccName name)
-------------------------------------------------------------------------------
@@ -323,20 +321,20 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
- put_ bh (InstalledInterface mod info docMap exps visExps) = do
- put_ bh mod
+ put_ bh (InstalledInterface modu info docMap exps visExps) = do
+ put_ bh modu
put_ bh info
put_ bh (Map.toList docMap)
put_ bh exps
put_ bh visExps
get bh = do
- mod <- get bh
+ modu <- get bh
info <- get bh
docMap <- get bh
exps <- get bh
visExps <- get bh
- return (InstalledInterface mod info (Map.fromList docMap) exps visExps)
+ return (InstalledInterface modu info (Map.fromList docMap) exps visExps)
instance Binary DocOption where
@@ -403,8 +401,11 @@ instance (Binary id) => Binary (HsDoc id) where
put_ bh (DocURL am) = do
putByte bh 12
put_ bh am
- put_ bh (DocAName an) = do
+ put_ bh (DocPic x) = do
putByte bh 13
+ put_ bh x
+ put_ bh (DocAName an) = do
+ putByte bh 14
put_ bh an
get bh = do
h <- getByte bh
@@ -449,6 +450,9 @@ instance (Binary id) => Binary (HsDoc id) where
am <- get bh
return (DocURL am)
13 -> do
+ x <- get bh
+ return (DocPic x)
+ 14 -> do
an <- get bh
return (DocAName an)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 49150b64..49ed8c32 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -11,15 +11,12 @@
module Haddock.Types where
-import Haddock.GHC.Utils
import Haddock.DocName
import Data.Map (Map)
import qualified Data.Map as Map
import GHC hiding (NoLink)
-import Outputable
-import OccName
import Name
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index b776272a..1e8cc009 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -6,9 +6,6 @@
--
-{-# LANGUAGE PatternSignatures #-}
-
-
module Haddock.Utils (
-- * Misc utilities
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 08:54:58 +0000