1 files changed, 138 insertions, 0 deletions
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..052827b
--- /dev/null
+++ b/Main.hs
@@ -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