aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Utils.hs43
1 files changed, 38 insertions, 5 deletions
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 9e7aeb2a..9a712d70 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -38,9 +38,6 @@ module Haddock.Utils (
-- * List utilities
replace,
- -- * Binary extras
--- FormatVersion, mkFormatVersion
-
-- * MTL stuff
MonadIO(..),
@@ -49,6 +46,7 @@ module Haddock.Utils (
out
) where
+
import Haddock.Types
import Haddock.GhcUtils
@@ -99,11 +97,12 @@ out progVerbosity msgVerbosity msg
-- Some Utilities
--- | extract a module's short description.
+-- | Extract a module's short description.
toDescription :: Interface -> Maybe (Doc Name)
toDescription = hmi_description . ifaceInfo
--- | extract a module's short description.
+
+-- | Extract a module's short description.
toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)
toInstalledDescription = hmi_description . instInfo
@@ -111,6 +110,7 @@ toInstalledDescription = hmi_description . instInfo
-- ---------------------------------------------------------------------------
-- Making abstract declarations
+
restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)
restrictTo names (L loc decl) = L loc $ case decl of
TyClD d | isDataDecl d && tcdND d == DataType ->
@@ -124,6 +124,7 @@ restrictTo names (L loc decl) = L loc $ case decl of
TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
+
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
@@ -145,6 +146,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
keep _ | otherwise = Nothing
+
restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
restrictDecls names decls = filter keep decls
where keep d = fromJust (sigName d) `elem` names
@@ -158,6 +160,7 @@ restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]
-- -----------------------------------------------------------------------------
-- Filename mangling functions stolen from s main/DriverUtil.lhs.
+
moduleHtmlFile :: Module -> FilePath
moduleHtmlFile mdl =
case Map.lookup mdl html_xrefs of
@@ -167,33 +170,40 @@ moduleHtmlFile mdl =
mdl' = map (\c -> if c == '.' then '-' else c)
(moduleNameString (moduleName mdl))
+
nameHtmlRef :: Module -> OccName -> String
nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n)
+
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
+
-- | The name of the module index file to be displayed inside a frame.
-- Modules are display in full, but without indentation. Clicking opens in
-- the main window.
frameIndexHtmlFile :: String
frameIndexHtmlFile = "index-frames.html"
+
moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
moduleIndexFrameName = "modules"
mainFrameName = "main"
synopsisFrameName = "synopsis"
+
subIndexHtmlFile :: Char -> String
subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
where b | isAlpha a = [a]
| otherwise = show (ord a)
+
anchorNameStr :: OccName -> String
anchorNameStr name | isValOcc name = "v:" ++ occNameString name
| otherwise = "t:" ++ occNameString name
+
pathJoin :: [FilePath] -> FilePath
pathJoin = foldr join []
where join :: FilePath -> FilePath -> FilePath
@@ -203,9 +213,11 @@ pathJoin = foldr join []
| isPathSeparator (last path1) = path1++path2
| otherwise = path1++pathSeparator:path2
+
-- -----------------------------------------------------------------------------
-- Files we need to copy from our $libdir
+
cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String
cssFile = "haddock.css"
iconFile = "haskell_icon.gif"
@@ -214,38 +226,48 @@ plusFile = "plus.gif"
minusFile = "minus.gif"
framesFile = "frames.html"
+
-----------------------------------------------------------------------------
-- misc.
+
getProgramName :: IO String
getProgramName = liftM (`withoutSuffix` ".bin") getProgName
where str `withoutSuffix` suff
| suff `isSuffixOf` str = take (length str - length suff) str
| otherwise = str
+
bye :: String -> IO a
bye s = putStr s >> exitWith ExitSuccess
+
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
dieMsg :: String -> IO a
dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
+
noDieMsg :: String -> IO ()
noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
mapSnd _ [] = []
mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
+
mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
mapMaybeM _ Nothing = return Nothing
mapMaybeM f (Just a) = liftM Just (f a)
+
escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved
+
-- Following few functions are copy'n'pasted from Network.URI module
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
@@ -265,9 +287,11 @@ escapeURIChar p c
| d < 10 = chr (ord '0' + fromIntegral d)
| otherwise = chr (ord 'A' + fromIntegral (d - 10))
+
escapeURIString :: (Char -> Bool) -> String -> String
escapeURIString = concatMap . escapeURIChar
+
isUnreserved :: Char -> Bool
isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")
@@ -288,10 +312,12 @@ isAlphaNumChar c = isAlphaChar c || isDigitChar c
-- mapping is constant for any single run of Haddock. So for the time
-- being I'm going to use a write-once global variable.
+
{-# NOINLINE html_xrefs_ref #-}
html_xrefs_ref :: IORef (Map Module FilePath)
html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
+
{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
@@ -309,6 +335,7 @@ replace a b = map (\x -> if x == a then b else x)
-----------------------------------------------------------------------------
-- put here temporarily
+
markup :: DocMarkup id a -> Doc id -> a
markup m DocEmpty = markupEmpty m
markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
@@ -327,9 +354,11 @@ markup m (DocAName ref) = markupAName m ref
markup m (DocPic img) = markupPic m img
markup m (DocExamples e) = markupExample m e
+
markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)
+
-- | The identity markup
idMarkup :: DocMarkup a (Doc a)
idMarkup = Markup {
@@ -355,14 +384,18 @@ idMarkup = Markup {
-----------------------------------------------------------------------------
-- put here temporarily
+
newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
+
nullFormatVersion :: FormatVersion
nullFormatVersion = mkFormatVersion 0
+
mkFormatVersion :: Int -> FormatVersion
mkFormatVersion = FormatVersion
+
instance Binary FormatVersion where
put_ bh (FormatVersion i) =
case compare i 0 of
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 11:43:14 +0000