diff options
Diffstat (limited to 'src/HaddockUtil.hs')
| -rw-r--r-- | src/HaddockUtil.hs | 340 |
1 files changed, 0 insertions, 340 deletions
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs deleted file mode 100644 index 1d962c82..00000000 --- a/src/HaddockUtil.hs +++ /dev/null @@ -1,340 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) The University of Glasgow 2001-2002 --- (c) Simon Marlow 2003 --- - -module HaddockUtil ( - - -- * Misc utilities - restrictTo, - toDescription, - - -- * Filename utilities - basename, dirname, splitFilename3, - moduleHtmlFile, nameHtmlRef, - contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin, - anchorNameStr, - cssFile, iconFile, jsFile, plusFile, minusFile, - - -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg, - - -- * HTML cross reference mapping - html_xrefs_ref, - - -- * HsDoc markup - markup, - idMarkup, - - -- * Binary extras --- FormatVersion, mkFormatVersion - ) where - -import HaddockTypes -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) - -import GHC -import SrcLoc -import Name -import OccName -import Binary -import Module -import PackageConfig ( stringToPackageId ) - -import Control.Monad ( liftM, MonadPlus(..) ) -import Data.Char -import Data.IORef ( IORef, newIORef, readIORef ) -import Data.List ( intersect, isSuffixOf, intersperse ) -import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust ) -import Data.Word ( Word8 ) -import Data.Bits ( testBit ) -import Network.URI -import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( hPutStr, stderr ) -import System.IO.Unsafe ( unsafePerformIO ) - --- ----------------------------------------------------------------------------- --- Some Utilities - --- | extract a module's short description. -toDescription :: HaddockModule -> Maybe (HsDoc Name) -toDescription = hmi_description . hmod_info - --- --------------------------------------------------------------------------- --- 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 -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> - case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) - [con] -> TyClD (d { tcdCons = [con] }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) }) - _ -> decl - -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 (HsRecField n _ _) = (unLoc n) `elem` names - field_types flds = [ ty | HsRecField n ty _ <- flds] - - keep d | otherwise = Nothing - -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = filter keep decls - where keep d = fromJust (sigName d) `elem` names - -- has to have a name, since it's a class method type signature - --- ----------------------------------------------------------------------------- --- Filename mangling functions stolen from s main/DriverUtil.lhs. - -type Suffix = String - -splitFilename :: String -> (String,Suffix) -splitFilename f = split_longest_prefix f (=='.') - -basename :: String -> String -basename f = base where (_dir, base, _suff) = splitFilename3 f - -dirname :: String -> String -dirname f = dir where (dir, _base, _suff) = splitFilename3 f - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") -splitFilename3 :: String -> (String,String,Suffix) -splitFilename3 str - = let (dir, rest) = split_longest_prefix str isPathSeparator - (name, ext) = splitFilename rest - real_dir | null dir = "." - | otherwise = dir - in (real_dir, name, ext) - -split_longest_prefix :: String -> (Char -> Bool) -> (String,String) -split_longest_prefix s pred0 - = case pre0 of - [] -> ([], reverse suf) - (_:pre) -> (reverse pre, reverse suf) - where (suf,pre0) = break pred0 (reverse s) - -pathSeparator :: Char -#ifdef __WIN32__ -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif - -moduleHtmlFile :: Module -> FilePath -moduleHtmlFile mdl = - case Map.lookup mdl html_xrefs of - Nothing -> mdl' ++ ".html" - Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] - where - mdl' = map (\c -> if c == '.' then '-' else c) - (moduleNameString (moduleName mdl)) - -nameHtmlRef :: Module -> Name -> String -nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str) - -contentsHtmlFile, indexHtmlFile :: String -contentsHtmlFile = "index.html" -indexHtmlFile = "doc-index.html" - -subIndexHtmlFile :: Char -> String -subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" - where b | isAlpha a = [a] - | otherwise = show (ord a) - -anchorNameStr :: Name -> String -anchorNameStr name | isValOcc occName = "v:" ++ getOccString name - | otherwise = "t:" ++ getOccString name - where occName = nameOccName name - -pathJoin :: [FilePath] -> FilePath -pathJoin = foldr join [] - where join :: FilePath -> FilePath -> FilePath - join path1 "" = path1 - join "" path2 = path2 - join path1 path2 - | isPathSeparator (last path1) = path1++path2 - | otherwise = path1++pathSeparator:path2 - --- ----------------------------------------------------------------------------- --- Files we need to copy from our $libdir - -cssFile, iconFile, jsFile, plusFile,minusFile :: String -cssFile = "haddock.css" -iconFile = "haskell_icon.gif" -jsFile = "haddock.js" -plusFile = "plus.gif" -minusFile = "minus.gif" - ------------------------------------------------------------------------------ --- 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) = f a >>= return . Just - -escapeStr :: String -> String -#if __GLASGOW_HASKELL__ < 603 -escapeStr = flip escapeString unreserved -#else -escapeStr = escapeURIString isUnreserved -#endif - --- there should be a better way to check this using the GHC API -isConSym n = head (nameOccString n) == ':' -isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar - where fstChar = head (nameOccString n) - -nameOccString = occNameString . nameOccName - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - -mkModuleNoPkg :: String -> Module -mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) - ------------------------------------------------------------------------------ --- 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 #-} -html_xrefs :: Map Module FilePath -html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) - ------------------------------------------------------------------------------ --- put here temporarily - -markup :: DocMarkup id a -> HsDoc 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 ids) = markupIdentifier m ids -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocEmphasis d) = markupEmphasis 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 (DocURL url) = markupURL m url -markup m (DocAName ref) = markupAName m ref - -markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - --- | The identity markup -idMarkup :: DocMarkup a (HsDoc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupModule = DocModule, - markupEmphasis = DocEmphasis, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupURL = DocURL, - markupAName = DocAName - } - --- | Since marking up is just a matter of mapping 'Doc' into some --- other type, we can \'rename\' documentation by marking up 'Doc' into --- the same thing, modifying only the identifiers embedded in it. - -mapIdent f = idMarkup { markupIdentifier = f } - ------------------------------------------------------------------------------ --- put here temporarily - -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) - -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion i = FormatVersion i - -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - (w8 :: Word8) <- get bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion |