From 4c859013da2ed2822bedafc72080028eb3f0ae7b Mon Sep 17 00:00:00 2001 From: David Waern Date: Thu, 13 May 2010 19:51:10 +0000 Subject: Fix stylistic issues in H.Utils --- src/Haddock/Utils.hs | 43 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 5 deletions(-) (limited to 'src') 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 -- cgit v1.2.3