index.hs 7.11 KB
Newer Older
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1 2 3 4 5 6 7 8

-- This generates the prelude index to the report by hyper-linking all
-- of the names in a hand-written document.  This is probably too
-- obscure to bother explaining.  Hardwires for the Haskell report at the
-- moment.

module Main where

9 10
import Data.Char
import System.IO.Error
Simon Peyton Jones's avatar
Simon Peyton Jones committed
11

12
main :: IO ()
Simon Peyton Jones's avatar
Simon Peyton Jones committed
13 14 15
main = do refs <- readRefFile "reportrefs"
          doFiles refs ["prelude-index"]

16 17
doFiles :: Refs -> [FilePath] -> IO ()
doFiles r files = do mapM_ (doFile r) files
18
                     putStrLn "Done."
Simon Peyton Jones's avatar
Simon Peyton Jones committed
19

20
doFile :: Refs -> FilePath -> IO ()
21 22 23
doFile r f = catchIOError
               (do putStrLn ("Reading " ++ f ++ ".idx")
                   ls <- readFile (f ++ ".idx")
Simon Peyton Jones's avatar
Simon Peyton Jones committed
24
                   let output = expandAllRefs r (lines ls)
25 26 27
                   writeFile ("haskell-report-html/" ++ f ++ ".html")
                             (unlines output))
               (\err -> putStrLn ("Error: " ++ show err))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
28 29 30 31 32 33

-- This sets up the parts of the state that need to be reset at the start of
-- each file.

type Refs = [(String,String)]

34
expandAllRefs :: Refs -> [String] -> [String]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
35
expandAllRefs r ls = expandAll1 r False ls
36 37 38

expandAll1 :: Refs -> Bool -> [String] -> [String]
expandAll1 _ _     [] = []
Ian Lynagh's avatar
Ian Lynagh committed
39 40
expandAll1 r table (l:ls) | l == "#table" = expandAll1 r True ls
                          | l == "#endtable" = expandAll1 r False ls
Simon Peyton Jones's avatar
Simon Peyton Jones committed
41 42 43
                          | table = ("<tr><td><tt>" ++ nbspaces (expandRefs r l)
                                     ++ "</tt></td></tr>") : rest
                          | otherwise = (expandRefs r l) : rest
Ian Lynagh's avatar
Ian Lynagh committed
44
 where rest = expandAll1 r table ls
Simon Peyton Jones's avatar
Simon Peyton Jones committed
45 46

expandRefs :: Refs -> String -> String
47
expandRefs _ "" = ""
Ian Lynagh's avatar
Ian Lynagh committed
48
expandRefs r ('#':l) = expandRef r "" l
Simon Peyton Jones's avatar
Simon Peyton Jones committed
49 50
expandRefs r (c:cs) = c : expandRefs r cs

51
expandRef :: Refs -> String -> String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
52 53 54 55 56
expandRef r txt ('V':l) = expandVar r txt (parseRef l)
expandRef r txt ('I':l) = expandInstance r txt (parseRef l)
expandRef r txt ('T':l) = expandTycon r txt (parseRef l)
expandRef r txt ('L':l) = expandLink r txt (parseRef l)
expandRef r txt ('S':l) = expandSect r txt (parseRef l)
57 58 59 60
expandRef r _   ('&':l) = "</tt></td><td><tt>" ++ expandRefs r l
expandRef r _   ('#':l) = "#" ++ expandRefs r l
expandRef r _   ('.':l) = expandRefs r l
expandRef _ _   l = error ("Bad ref:" ++ l ++ "\n")
Simon Peyton Jones's avatar
Simon Peyton Jones committed
61

62
parseRef :: String -> (String, String)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
63 64
parseRef = break (\c -> isSpace c || c == '#')

65
expandVar :: Refs -> String -> (String, String) -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
66 67 68 69 70 71
expandVar r txt (v,rest) = let n = mangleVar v
                               f = lookup n r in
                             case f of
                               Nothing -> trySig r txt v rest n
                               _ -> anchor v f n txt ++ expandRefs r rest

72
expandTycon :: Refs -> String -> (String, String) -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73 74 75 76
expandTycon r txt (t,rest) = let n = mangleTycon t
                                 f = lookup n r in
                             anchor t f n txt ++ expandRefs r rest

77
expandInstance :: Refs -> String -> (String, String) -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
78 79 80 81
expandInstance r txt (c,'#':rest ) = let (t,rest') = parseRef rest
                                         n = mangleInstance c t
                                         f = lookup n r in
                                       anchor c f n txt ++ expandRefs r rest'
82
expandInstance _ _   (_,l) = error ("bad instance " ++ l ++ "\n")
Simon Peyton Jones's avatar
Simon Peyton Jones committed
83

84
expandSect :: Refs -> String -> (String, String) -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
85 86 87 88 89
expandSect r txt (s,rest) = let n = mangleSect s
                                f = lookup n r in
                              "(see " ++ anchor s f n txt ++ ")" ++
                               expandRefs r rest

90
expandLink :: Refs -> String -> (String, String) -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
expandLink r _ (t,'#':l') = expandRef r t l'
92
expandLink _ _ (l,l') = error ("Bad link: " ++ l ++ l' ++ "\n")
Simon Peyton Jones's avatar
Simon Peyton Jones committed
93

94
trySig :: Refs -> String -> String -> String -> String -> String
Ian Lynagh's avatar
Ian Lynagh committed
95 96
trySig r txt v rest n =
   let c = parseClass rest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
97 98 99 100
       n = mangleTycon c
       f = lookup n r in
     anchor v f n txt ++ expandRefs r rest

101 102 103
anchor :: String -> Maybe String -> String -> String -> String
anchor str mfile tag txt =
         case mfile of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
104 105 106 107 108 109
           Just f -> "<a href=\"" ++ f ++ ".html#" ++ tag ++
                      "\">" ++ t ++ "</a>"
           Nothing -> "Bad tag:" ++ tag ++ " " ++ t
     where
       t = htmlS $ if txt == "" then str else txt

110
mangleVar :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
111 112
mangleVar n = "$v" ++ mangleName (filter (\c -> not (c `elem` "()")) n)

113
mangleTycon :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
114 115
mangleTycon n = "$t" ++ mangleName n

116
mangleInstance :: String -> String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
117 118
mangleInstance c t = "$i" ++ mangleName c ++ "$$" ++ mangleName t

119
mangleSect :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
120 121
mangleSect s = "sect" ++ s

122 123 124
mangleName :: String -> String
mangleName r = concatMap
                   (\c -> case c of '(' -> "$P"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
                                    ')' -> "$C"
                                    '-' -> "$D"
                                    '[' -> "$B"
                                    ']' -> "$c"
                                    ',' -> "$x"
                                    '#' -> "$p"
                                    '$' -> "$D"
                                    '|' -> "$b"
                                    '!' -> "$E"
                                    '&' -> "$A"
                                    '^' -> "$U"
                                    '>' -> "$G"
                                    '<' -> "$L"
                                    '=' -> "$Q"
                                    _   -> [c]) r

141
mangleType :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
142
mangleType t = mangleName (case t of
143
                              "(IO"    -> "IO"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
144
                              "(a->b)" -> "->"
145 146
                              "[a]"    -> "[]"
                              x        -> x)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
147 148 149 150



readRefFile :: String -> IO [(String, String)]
151 152
readRefFile f = catchIOError
                      (do l <- readFile f
Simon Peyton Jones's avatar
Simon Peyton Jones committed
153
                          return (map parseKV (lines l)))
154 155
                      (\e -> do putStrLn ("Can't read ref file: " ++ f)
                                print e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
156 157
                                return [])

158
parseKV :: String -> (String, String)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
159 160 161 162 163 164
parseKV l = let (k,l1) = span (/= '=') l
                val    = case l1 of
                           ('=':v) -> trim v
                           _       -> ""
              in (trimr k,val)

165
parseClass :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
166 167
parseClass s = let s1 = (skip "(" . skip "::") s
                   (c,_) = span isAlpha (trim s1) in
Ian Lynagh's avatar
Ian Lynagh committed
168
                 c
Simon Peyton Jones's avatar
Simon Peyton Jones committed
169

170
trim :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
171
trim s = dropWhile isSpace s
172 173

trimr :: String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
174
trimr s = reverse (dropWhile isSpace (reverse s))
175 176

starts :: String -> String -> Bool
Simon Peyton Jones's avatar
Simon Peyton Jones committed
177 178 179 180 181
starts [] _ = True
starts _ [] = False
starts (a:as) (b:bs) | a == b = starts as bs
                     | otherwise = False

182
skip :: String -> String -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
183 184 185 186
skip val s = if val `starts` (trim s) then
                drop (length val) (trim s)
             else s

187
htmlEncode :: Char -> String
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188 189 190 191 192
htmlEncode '>' = "&gt;"
htmlEncode '<' = "&lt;"
htmlEncode '&' = "&amp;"
htmlEncode c   = [c]

193 194
htmlS :: String -> String
htmlS s = concatMap htmlEncode s
Simon Peyton Jones's avatar
Simon Peyton Jones committed
195

196 197
nbspaces :: String -> String
nbspaces "" = ""
Simon Peyton Jones's avatar
Simon Peyton Jones committed
198 199 200 201
nbspaces (' ' : cs) = "&nbsp;" ++ nbspaces cs
nbspaces ('<':cs) = ['<'] ++ c ++ nbspaces r where
                        (c,r) = span (/= '>') cs
nbspaces (c:cs) = c:nbspaces cs