-- -- Haddock - A Haskell Documentation Tool -- -- (c) The University of Glasgow 2001-2002 -- (c) Simon Marlow 2003 -- module HaddockUtil ( -- * Misc utilities nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang, addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual, -- * Filename utilities basename, dirname, splitFilename3, moduleHtmlFile, nameHtmlRef, contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin, cssFile, iconFile, jsFile, plusFile, minusFile, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, -- * HTML cross reference mapping html_xrefs_ref, ) where import Binary import HaddockLex import HaddockParse import HaddockTypes import HsSyn import Map ( Map ) import qualified Map hiding ( Map ) import Control.Monad ( liftM, MonadPlus(..) ) import Data.Char ( isAlpha, isSpace, toUpper, ord, chr ) import Numeric ( showIntAtBase ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( intersect, isSuffixOf, intersperse ) import Data.Maybe ( maybeToList, fromMaybe ) import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) -- ----------------------------------------------------------------------------- -- Some Utilities nameOfQName :: HsQName -> HsName nameOfQName (Qual _ n) = n nameOfQName (UnQual n) = n unQual :: HsQName -> HsQName unQual (Qual _ n) = UnQual n unQual n = n collectNames :: [HsDecl] -> [HsName] collectNames ds = concat (map declBinders ds) unbang :: HsBangType -> HsType unbang (HsUnBangedTy ty) = ty unbang (HsBangedTy ty) = ty declBinders :: HsDecl -> [HsName] declBinders d = maybeToList (declMainBinder d) ++ declSubBinders d declMainBinder :: HsDecl -> Maybe HsName declMainBinder d = case d of HsTypeDecl _ n _ _ _ -> Just n HsDataDecl _ _ n _ _ _ _ -> Just n HsNewTypeDecl _ _ n _ _ _ _ -> Just n HsClassDecl _ _ n _ _ _ _ -> Just n HsTypeSig _ [n] _ _ -> Just n HsTypeSig _ _ _ _ -> error "declMainBinder" HsForeignImport _ _ _ _ n _ _ -> Just n _ -> Nothing declSubBinders :: HsDecl -> [HsName] declSubBinders d = case d of HsTypeDecl _ _ _ _ _ -> [] HsDataDecl _ _ _ _ cons _ _ -> concat (map conDeclBinders cons) HsNewTypeDecl _ _ _ _ con _ _ -> conDeclBinders con HsClassDecl _ _ _ _ _ decls _ -> collectNames decls HsTypeSig _ _ _ _ -> [] HsForeignImport _ _ _ _ _ _ _ -> [] _ -> [] conDeclBinders :: HsConDecl -> [HsName] conDeclBinders (HsConDecl _ n _ _ _ _) = [n] conDeclBinders (HsRecDecl _ n _ _ fields _) = n : concat (map fieldDeclBinders fields) fieldDeclBinders :: HsFieldDecl -> [HsName] fieldDeclBinders (HsFieldDecl ns _ _) = ns splitTyConApp :: HsType -> (HsQName, [HsType]) splitTyConApp t0 = split t0 [] where split :: HsType -> [HsType] -> (HsQName,[HsType]) split (HsTyApp t u) ts = split t (u:ts) split (HsTyCon t) ts = (t,ts) split _ _ = error "splitTyConApp" freeTyCons :: HsType -> [HsQName] freeTyCons ty = go ty [] where go (HsForAllType _ _ t) r = go t r go (HsTyApp t u) r = go t (go u r) go (HsTyCon c) r = c : r go (HsTyFun f a) r = go f (go a r) go (HsTyTuple _ ts) r = foldr go r ts go (HsTyVar _) r = r go (HsTyDoc t _) r = go t r -- | extract a module's short description. toDescription :: Interface -> Maybe Doc toDescription = description. iface_info -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). addFieldDoc :: HsFieldDecl -> Maybe Doc -> HsFieldDecl addFieldDoc (HsFieldDecl ns ty doc1) doc2 = HsFieldDecl ns ty (doc1 `mplus` doc2) addFieldDocs :: [HsFieldDecl] -> Maybe Doc -> [HsFieldDecl] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs addConDoc :: HsConDecl -> Maybe Doc -> HsConDecl addConDoc (HsConDecl pos nm tvs ctxt typeList doc1) doc2 = HsConDecl pos nm tvs ctxt typeList (doc1 `mplus` doc2) addConDoc (HsRecDecl pos nm tvs ctxt fields doc1) doc2= HsRecDecl pos nm tvs ctxt fields (doc1 `mplus` doc2) addConDocs :: [HsConDecl] -> Maybe Doc -> [HsConDecl] addConDocs [] _ = [] addConDocs (x:xs) doc = addConDoc x doc : xs -- --------------------------------------------------------------------------- -- Making abstract declarations restrictTo :: [HsName] -> HsDecl -> HsDecl restrictTo names decl = case decl of HsDataDecl loc ctxt n xs cons drv doc -> HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc decl@(HsNewTypeDecl loc ctxt n xs con drv doc) -> case restrictCons names [con] of [] -> HsDataDecl loc ctxt n xs [] drv doc [con'] -> HsNewTypeDecl loc ctxt n xs con' drv doc -- an abstract newtype decl appears as a data decl. HsClassDecl loc ctxt n tys fds decls doc -> HsClassDecl loc ctxt n tys fds (restrictDecls names decls) doc _ -> decl restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl] restrictCons names decls = [ d | Just d <- map keep decls ] where keep d@(HsConDecl _ n _ _ _ _) | n `elem` names = Just d keep d@(HsRecDecl loc n tvs ctx fields doc) | n `elem` names = if all field_avail fields then Just d else Just (HsConDecl loc n tvs ctx confields doc) -- 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. where field_avail (HsFieldDecl ns _ _) = all (`elem` names) ns confields = [ ty | HsFieldDecl ns ty doc <- fields, n <- ns ] keep d = Nothing restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl] restrictDecls names decls = filter keep decls where keep d = not (null (declBinders d `intersect` names)) -- ToDo: not really correct -- ----------------------------------------------------------------------------- -- Extract documentation from a declaration declDoc :: HsDecl -> Maybe Doc declDoc (HsTypeDecl _ _ _ _ d) = d declDoc (HsDataDecl _ _ _ _ _ _ d) = d declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d declDoc (HsClassDecl _ _ _ _ _ _ d) = d declDoc (HsTypeSig _ _ _ d) = d declDoc (HsForeignImport _ _ _ _ _ _ d) = d declDoc _ = Nothing -- ----------------------------------------------------------------------------- -- Parsing module headers -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. parseModuleHeader :: String -> Either String (String,ModuleInfo) parseModuleHeader str0 = let getKey :: String -> String -> (Maybe String,String) getKey key str = case parseKey key str of Nothing -> (Nothing,str) Just (value,rest) -> (Just value,rest) (moduleOpt,str1) = getKey "Module" str0 (descriptionOpt,str2) = getKey "Description" str1 (copyrightOpt,str3) = getKey "Copyright" str2 (licenseOpt,str4) = getKey "License" str3 (licenceOpt,str5) = getKey "Licence" str4 (maintainerOpt,str6) = getKey "Maintainer" str5 (stabilityOpt,str7) = getKey "Stability" str6 (portabilityOpt,str8) = getKey "Portability" str7 description1 :: Either String (Maybe Doc) description1 = case descriptionOpt of Nothing -> Right Nothing Just description -> case parseString . tokenise $ description of Left mess -> Left ("Cannot parse Description: " ++ mess) Right doc -> Right (Just doc) in case description1 of Left mess -> Left mess Right docOpt -> Right (str8,ModuleInfo { description = docOpt, portability = portabilityOpt, stability = stabilityOpt, maintainer = maintainerOpt }) -- | This function is how we read keys. -- -- all fields in the header are optional and have the form -- -- [spaces1][field name][spaces] ":" -- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* -- where each [spaces2] should have [spaces1] as a prefix. -- -- Thus for the key "Description", -- -- > Description : this is a -- > rather long -- > -- > description -- > -- > The module comment starts here -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". parseKey :: String -> String -> Maybe (String,String) parseKey key toParse0 = do let (spaces0,toParse1) = extractLeadingSpaces toParse0 indentation = spaces0 afterKey0 <- extractPrefix key toParse1 let afterKey1 = extractLeadingSpaces afterKey0 afterColon0 <- case snd afterKey1 of ':':afterColon -> return afterColon _ -> Nothing let (_,afterColon1) = extractLeadingSpaces afterColon0 return (scanKey True indentation afterColon1) where scanKey :: Bool -> String -> String -> (String,String) scanKey isFirst indentation [] = ([],[]) scanKey isFirst indentation str = let (nextLine,rest1) = extractNextLine str accept = isFirst || sufficientIndentation || allSpaces sufficientIndentation = case extractPrefix indentation nextLine of Just (c:_) | isSpace c -> True _ -> False allSpaces = case extractLeadingSpaces nextLine of (_,[]) -> True _ -> False in if accept then let (scanned1,rest2) = scanKey False indentation rest1 scanned2 = case scanned1 of "" -> if allSpaces then "" else nextLine _ -> nextLine ++ "\n" ++ scanned1 in (scanned2,rest2) else ([],str) extractLeadingSpaces :: String -> (String,String) extractLeadingSpaces [] = ([],[]) extractLeadingSpaces (s@(c:cs)) | isSpace c = let (spaces1,cs1) = extractLeadingSpaces cs in (c:spaces1,cs1) | True = ([],s) extractNextLine :: String -> (String,String) extractNextLine [] = ([],[]) extractNextLine (c:cs) | c == '\n' = ([],cs) | True = let (line,rest) = extractNextLine cs in (c:line,rest) -- indentation returns characters after last newline. indentation :: String -> String indentation s = fromMaybe s (indentation0 s) where indentation0 :: String -> Maybe String indentation0 [] = Nothing indentation0 (c:cs) = case indentation0 cs of Nothing -> if c == '\n' then Just cs else Nothing in0 -> in0 -- comparison is case-insensitive. extractPrefix :: String -> String -> Maybe String extractPrefix [] s = Just s extractPrefix s [] = Nothing extractPrefix (c1:cs1) (c2:cs2) | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 | True = Nothing -- ----------------------------------------------------------------------------- -- Filename mangling functions stolen from GHC'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 :: String -> FilePath moduleHtmlFile mdl = case Map.lookup (Module mdl) html_xrefs of Nothing -> mdl' ++ ".html" Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] where mdl' = map (\c -> if c == '.' then '-' else c) mdl nameHtmlRef :: String -> HsName -> String nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (hsAnchorNameStr 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) 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-util.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 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" [c] -> ['0',c] cs -> cs toChrHex d | d < 10 = chr (ord '0' + fromIntegral d) | otherwise = chr (ord 'A' + fromIntegral (d - 10)) escapeURIString :: (Char -> Bool) -> String -> String escapeURIString p s = concatMap (escapeURIChar p) s isUnreserved :: Char -> Bool isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") 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 #-} html_xrefs :: Map Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) ----------------------------------------------------------------------------- -- Binary instances for stuff instance Binary Module where put_ bh (Module m) = putString bh m get bh = do m <- getString bh; return $! (Module m) instance Binary HsQName where put_ bh (Qual m s) = do putByte bh 0; put_ bh m; put_ bh s put_ bh (UnQual s) = do putByte bh 1; put_ bh s get bh = do b <- getByte bh case b of 0 -> do m <- get bh; s <- get bh; return (Qual m s) _ -> do s <- get bh; return (UnQual s) instance Binary HsName where put_ bh (HsTyClsName s) = do putByte bh 0; put_ bh s put_ bh (HsVarName s) = do putByte bh 1; put_ bh s get bh = do b <- getByte bh case b of 0 -> do s <- get bh; return (HsTyClsName s) _ -> do s <- get bh; return (HsVarName s) instance Binary HsIdentifier where put_ bh (HsIdent s) = do putByte bh 0; putString bh s put_ bh (HsSymbol s) = do putByte bh 1; putString bh s put_ bh (HsSpecial s) = do putByte bh 2; putString bh s get bh = do b <- getByte bh case b of 0 -> do s <- getString bh; return (HsIdent s) 1 -> do s <- getString bh; return (HsSymbol s) _ -> do s <- getString bh; return (HsSpecial s) instance Binary id => Binary (GenDoc id) where put_ bh DocEmpty = putByte bh 0 put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2 put_ bh (DocString s) = do putByte bh 2;putString bh s put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id put_ bh (DocModule s) = do putByte bh 5;putString bh s put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd put_ bh (DocURL s) = do putByte bh 12;putString bh s put_ bh (DocAName s) = do putByte bh 13;putString bh s put_ bh (DocPic s) = do putByte bh 14;putString bh s get bh = do b <- getByte bh case b of 0 -> return DocEmpty 1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2) 2 -> do s <- getString bh;return (DocString s) 3 -> do gd <- get bh;return (DocParagraph gd) 4 -> do id <- get bh;return (DocIdentifier id) 5 -> do s <- getString bh;return (DocModule s) 6 -> do gd <- get bh;return (DocEmphasis gd) 7 -> do gd <- get bh;return (DocMonospaced gd) 8 -> do gd <- get bh;return (DocUnorderedList gd) 9 -> do gd <- get bh;return (DocOrderedList gd) 10 -> do gd <- get bh;return (DocDefList gd) 11 -> do gd <- get bh;return (DocCodeBlock gd) 12 -> do s <- getString bh;return (DocURL s) 13 -> do s <- getString bh;return (DocAName s) 14 -> do s <- getString bh;return (DocPic s) _ -> error ("Mysterious byte in document in interface" ++ show b)