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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
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 = Package ByteString -- ^ packagename-version
ByteString -- ^ path (including #anchor)
| Broken ByteString -- ^ packagename-version
deriving (Show)
renderLink :: Link -> Builder
renderLink (Package 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 = parsePackageLink <|> parseBootlibLink
where
endOfLink c = isSpace c || c `elem` "\"'"
parseBootlibLink :: Parser Link
parseBootlibLink = do
string "${pkgroot}/" -- wtf haddock?
_ <- many (string "../")
string "share/doc/ghc-"
_ghcversion <- word (/= '/')
string "/html/libraries/"
pkg <- word (/= '/')
string "/"
path <- word (not . endOfLink)
if path == Char8.pack "src"
then return (Broken pkg) -- not sure if this happens in practice
else return (Package pkg path)
parsePackageLink :: Parser Link
parsePackageLink = do
string "file://"
search (void $ satisfy endOfLink)
(string "/.cabal/")
string "store/ghc-"
_ghcversion <- word (/= '/')
string "/"
namewithhash <- word (/= '/')
let pkg =
case BS.spanEnd ((`elem` "0123456789abcdefABCDEF") . tochar) namewithhash of
(pre, hash)
| BS.length hash == 64
, Just (pre', tochar -> '-') <- BS.unsnoc pre ->
pre'
| otherwise ->
namewithhash
string "/share/doc/html/"
path <- word (not . endOfLink)
if path == Char8.pack "src"
then return (Broken pkg)
else return (Package pkg path)
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
|
