diff options
Diffstat (limited to 'src/Haddock/Utils.hs')
| -rw-r--r-- | src/Haddock/Utils.hs | 480 |
1 files changed, 0 insertions, 480 deletions
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs deleted file mode 100644 index ee7bfd0a..00000000 --- a/src/Haddock/Utils.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Utils --- Copyright : (c) The University of Glasgow 2001-2002, --- Simon Marlow 2003-2006, --- David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Utils ( - - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - - -- * Filename utilities - moduleHtmlFile, moduleHtmlFile', - contentsHtmlFile, indexHtmlFile, - frameIndexHtmlFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, - subIndexHtmlFile, - jsFile, framesFile, - - -- * Anchor and URL utilities - moduleNameUrl, moduleNameUrl', moduleUrl, - nameAnchorId, - makeAnchorId, - - -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - - -- * HTML cross reference mapping - html_xrefs_ref, html_xrefs_ref', - - -- * Doc markup - markup, - idMarkup, - - -- * List utilities - replace, - spanWith, - - -- * MTL stuff - MonadIO(..), - - -- * Logging - parseVerbosity, - out, - - -- * System tools - getProcessID - ) where - - -import Haddock.Types -import Haddock.GhcUtils - -import GHC -import Name - -import Control.Monad ( liftM ) -import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) -import Numeric ( showIntAtBase ) -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Data.IORef ( IORef, newIORef, readIORef ) -import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) -import System.Environment ( getProgName ) -import System.Exit -import System.IO ( hPutStr, stderr ) -import System.IO.Unsafe ( unsafePerformIO ) -import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE - -#ifndef mingw32_HOST_OS -import qualified System.Posix.Internals -#endif - -import MonadUtils ( MonadIO(..) ) - - --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - - -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity - - --- | Print a message to stdout, if it is not too verbose -out :: MonadIO m - => Verbosity -- ^ program verbosity - -> Verbosity -- ^ message verbosity - -> String -> m () -out progVerbosity msgVerbosity msg - | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg - | otherwise = return () - - --------------------------------------------------------------------------------- --- * Some Utilities --------------------------------------------------------------------------------- - - --- | Extract a module's short description. -toDescription :: Interface -> Maybe (Doc Name) -toDescription = hmi_description . ifaceInfo - - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) -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 -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" - -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | unLoc (con_name d) `elem` names = - case con_details d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail (ConDeclField n _ _) = unLoc n `elem` names - field_types flds = [ t | ConDeclField _ t _ <- flds ] - - keep _ = Nothing - - -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsTyVarBndrs Name --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } - - --------------------------------------------------------------------------------- --- * Filename mangling functions stolen from s main/DriverUtil.lhs. --------------------------------------------------------------------------------- - - -baseName :: ModuleName -> FilePath -baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString - - -moduleHtmlFile :: Module -> FilePath -moduleHtmlFile mdl = - case Map.lookup mdl html_xrefs of - Nothing -> baseName mdl' ++ ".html" - Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"] - where - mdl' = moduleName mdl - - -moduleHtmlFile' :: ModuleName -> FilePath -moduleHtmlFile' mdl = - case Map.lookup mdl html_xrefs' of - Nothing -> baseName mdl ++ ".html" - Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] - - -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 :: String -> String -subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" - where b | all isAlpha ls = ls - | otherwise = concatMap (show . ord) ls - - -------------------------------------------------------------------------------- --- * Anchor and URL utilities --- --- NB: Anchor IDs, used as the destination of a link within a document must --- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's --- various needs and compatibility constraints, means these IDs have to match: --- [A-Za-z][A-Za-z0-9:_.-]* --- Such IDs do not need to be escaped in any way when used as the fragment part --- of a URL. Indeed, %-escaping them can lead to compatibility issues as it --- isn't clear if such fragment identifiers should, or should not be unescaped --- before being matched with IDs in the target document. -------------------------------------------------------------------------------- - - -moduleUrl :: Module -> String -moduleUrl = moduleHtmlFile - - -moduleNameUrl :: Module -> OccName -> String -moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n - - -moduleNameUrl' :: ModuleName -> OccName -> String -moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n - - -nameAnchorId :: OccName -> String -nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) - where prefix | isValOcc name = 'v' - | otherwise = 't' - - --- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is --- identity preserving. -makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r - where - escape p c | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" - isLegal ':' = True - isLegal '_' = True - isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c - -- NB: '-' is legal in IDs, but we use it as the escape char - - -------------------------------------------------------------------------------- --- * Files we need to copy from our $libdir -------------------------------------------------------------------------------- - - -jsFile, framesFile :: String -jsFile = "haddock-util.js" -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 >> 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 --- (at least if you want to build network with haddock docs) -escapeURIChar :: (Char -> Bool) -> Char -> String -escapeURIChar p c - | p c = [c] - | otherwise = '%' : myShowHex (ord c) "" - where - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of - [] -> "00" - [a] -> ['0',a] - cs -> cs - toChrHex d - | 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` "-_.~") - - -isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool -isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') -isDigitChar c = c >= '0' && c <= '9' -isAlphaNumChar c = isAlphaChar c || isDigitChar c - - ------------------------------------------------------------------------------ --- * HTML cross references --- --- For each module, we need to know where its HTML documentation lives --- so that we can point hyperlinks to it. It is extremely --- inconvenient to plumb this information to all the places that need --- it (basically every function in HaddockHtml), and furthermore the --- 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_ref' #-} -html_xrefs_ref' :: IORef (Map ModuleName FilePath) -html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map")) - - -{-# NOINLINE html_xrefs #-} -html_xrefs :: Map Module FilePath -html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) - - -{-# NOINLINE html_xrefs' #-} -html_xrefs' :: Map ModuleName FilePath -html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') - - ------------------------------------------------------------------------------ --- * List utils ------------------------------------------------------------------------------ - - -replace :: Eq a => a -> a -> [a] -> [a] -replace a b = map (\x -> if x == a then b else x) - - -spanWith :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanWith _ [] = ([],[]) -spanWith p xs@(a:as) - | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) - | otherwise = ([],xs) - - ------------------------------------------------------------------------------ --- * 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) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -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 { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - - ------------------------------------------------------------------------------ --- * System tools ------------------------------------------------------------------------------ - - -#ifdef mingw32_HOST_OS -foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows -#else -getProcessID :: IO Int -getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid -#endif |