diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Main.hs | 138 | ||||
| -rw-r--r-- | haddock-to-standalone.cabal | 20 |
3 files changed, 159 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Main (main) where + +import Control.Monad (ap, void, forM) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as Char8 +import Data.Char (chr, isSpace) +import Data.Foldable (asum) +import Data.Maybe (isNothing) +import Data.Word (Word8) +import System.Directory +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath ((</>)) +import System.IO (hPutStrLn, stderr, hFlush, stdout) +import Control.Applicative (Alternative(..)) + + +data Link = BootLib ByteString -- ^ packagename-version + ByteString -- ^ path (including #anchor) + | Broken ByteString -- ^ packagename-version + deriving (Show) + +renderLink :: Link -> Builder +renderLink (BootLib pkg path) = + mconcat [BSB.string8 "https://hackage.haskell.org/package/" + ,BSB.byteString pkg + ,BSB.string8 "/docs/" + ,BSB.byteString path] +renderLink (Broken pkg) = + mconcat [BSB.string8 "https://hackage.haskell.org/package/" + ,BSB.byteString pkg] + +newtype Parser a = Parser { runParser :: ByteString -> Maybe (a, ByteString) } + deriving (Functor) +instance Applicative Parser where + pure x = Parser (\s -> Just (x, s)) + (<*>) = ap +instance Monad Parser where + Parser g >>= f = Parser (\s -> g s >>= \(x, s') -> runParser (f x) s') +instance Alternative Parser where + empty = Parser (const Nothing) + Parser f <|> Parser g = Parser $ \s -> f s <|> g s + +parseLink :: Parser Link +parseLink = do + let endOfLink c = isSpace c || c `elem` "\"'" + string "../" <|> return () + string "file:///" + search (void $ satisfy endOfLink) + (string ".ghcup") + string "/ghc/" + _ <- word (/= '/') -- "9.2.2" + string "/share/doc/ghc-" + _ <- word (/= '/') -- "9.2.2" + string "/html/libraries/" + pkg <- word (/= '/') + string "/" + path <- word (not . endOfLink) + if path == Char8.pack "src" + then return (Broken pkg) + else return (BootLib pkg path) + where + string :: String -> Parser () + string w = + let w' = Char8.pack w + in Parser $ \s -> let (pre, post) = BS.splitAt (BS.length w') s + in if pre == w' then Just ((), post) else Nothing + + word :: (Char -> Bool) -> Parser ByteString + word f = Parser $ \s -> Just (BS.span (f . tochar) s) + + satisfy :: (Char -> Bool) -> Parser Char + satisfy f = Parser $ \s -> case BS.uncons s of + Just (c, cs) | f (tochar c) -> Just (tochar c, cs) + _ -> Nothing + + search :: Parser () -> Parser a -> Parser a + search stop p = Parser $ \s -> + asum $ map (runParser p) $ takeWhile (isNothing . runParser stop) $ BS.tails s + + tochar :: Word8 -> Char + tochar = chr . fromIntegral + +newtype Contents = Contents [Either Builder Link] + deriving (Show) + +serialise :: Contents -> Builder +serialise (Contents l) = foldMap (either id renderLink) l + +parseContents :: ByteString -> Contents +parseContents = go mempty + where + go :: Builder -> ByteString -> Contents + go prefix bs = case BS.uncons bs of + Nothing -> Contents [Left prefix] + Just (c, cs) -> + case runParser parseLink bs of + Just (link, s') -> let Contents l = parseContents s' + in Contents (Left (prefix) : Right link : l) + Nothing -> go (prefix <> BSB.word8 c) cs + +convertFile :: FilePath -> IO () +convertFile path = do + putStr $ "Converting " ++ path ++ " ..." + hFlush stdout + str <- BS.readFile path + let str' = BSB.toLazyByteString (serialise (parseContents str)) + if BSL.fromStrict str == str' + then putStrLn " (unchanged)" + else do putStrLn " UPDATING" + BSL.writeFile path str' + +recursiveListDirectory :: FilePath -> IO [FilePath] +recursiveListDirectory dir = do + entries <- listDirectory dir + fmap concat . forM entries $ \entry -> do + let path = dir </> entry + isdir <- doesDirectoryExist path + issym <- pathIsSymbolicLink path + if isdir && not issym + then recursiveListDirectory path + else return [path] + +main :: IO () +main = do + basedir <- getArgs >>= \case + [basedir] -> return basedir + _ -> do hPutStrLn stderr "Usage: haddock-to-standalone <doc directory>" + exitFailure + + entries <- recursiveListDirectory basedir + mapM_ convertFile entries diff --git a/haddock-to-standalone.cabal b/haddock-to-standalone.cabal new file mode 100644 index 0000000..795914a --- /dev/null +++ b/haddock-to-standalone.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.0 +name: haddock-to-standalone +synopsis: Replace links in rendered haddocks with hackage links +version: 0.1.0.0 +license: MIT +author: Tom Smeding +maintainer: tom@tomsmeding.com +build-type: Simple + +executable haddock-to-standalone + main-is: + Main.hs + build-depends: + base >= 4.13 && < 4.15, + bytestring >= 0.11.3.1 && < 0.12, + directory >= 1.3.7.0 && < 1.4, + filepath >= 1.4.2.2 && < 1.5 + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -threaded |