1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
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
|
