{-# 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