Commit 6b692919 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Fix most of the warnings in index.hs

parent bc2fd7c3
...@@ -26,7 +26,7 @@ verb-tex4ht: verb-tex4ht.o ...@@ -26,7 +26,7 @@ verb-tex4ht: verb-tex4ht.o
$(CC) -o $@ $^ $(CC) -o $@ $^
run_index: index.hs run_index: index.hs
$(GHC) -o run_index index.hs $(GHC) -o run_index index.hs -Wall
clean: clean:
rm -f verbatim verb-tex4ht run_tex run_index *.o *.hi rm -f verbatim verb-tex4ht run_tex run_index *.o *.hi
...@@ -7,15 +7,17 @@ ...@@ -7,15 +7,17 @@
module Main where module Main where
import Data.Char import Data.Char
import System.IO
import System.IO.Error import System.IO.Error
main :: IO ()
main = do refs <- readRefFile "reportrefs" main = do refs <- readRefFile "reportrefs"
doFiles refs ["prelude-index"] doFiles refs ["prelude-index"]
doFiles r files = do mapM (doFile r) files doFiles :: Refs -> [FilePath] -> IO ()
doFiles r files = do mapM_ (doFile r) files
putStrLn "Done." putStrLn "Done."
doFile :: Refs -> FilePath -> IO ()
doFile r f = catchIOError doFile r f = catchIOError
(do putStrLn ("Reading " ++ f ++ ".idx") (do putStrLn ("Reading " ++ f ++ ".idx")
ls <- readFile (f ++ ".idx") ls <- readFile (f ++ ".idx")
...@@ -29,8 +31,11 @@ doFile r f = catchIOError ...@@ -29,8 +31,11 @@ doFile r f = catchIOError
type Refs = [(String,String)] type Refs = [(String,String)]
expandAllRefs :: Refs -> [String] -> [String]
expandAllRefs r ls = expandAll1 r False ls expandAllRefs r ls = expandAll1 r False ls
expandAll1 r table [] = []
expandAll1 :: Refs -> Bool -> [String] -> [String]
expandAll1 _ _ [] = []
expandAll1 r table (l:ls) | l == "#table" = expandAll1 r True ls expandAll1 r table (l:ls) | l == "#table" = expandAll1 r True ls
| l == "#endtable" = expandAll1 r False ls | l == "#endtable" = expandAll1 r False ls
| table = ("<tr><td><tt>" ++ nbspaces (expandRefs r l) | table = ("<tr><td><tt>" ++ nbspaces (expandRefs r l)
...@@ -39,71 +44,84 @@ expandAll1 r table (l:ls) | l == "#table" = expandAll1 r True ls ...@@ -39,71 +44,84 @@ expandAll1 r table (l:ls) | l == "#table" = expandAll1 r True ls
where rest = expandAll1 r table ls where rest = expandAll1 r table ls
expandRefs :: Refs -> String -> String expandRefs :: Refs -> String -> String
expandRefs r "" = "" expandRefs _ "" = ""
expandRefs r ('#':l) = expandRef r "" l expandRefs r ('#':l) = expandRef r "" l
expandRefs r (c:cs) = c : expandRefs r cs expandRefs r (c:cs) = c : expandRefs r cs
expandRef :: Refs -> String -> String -> String
expandRef r txt ('V':l) = expandVar r txt (parseRef l) expandRef r txt ('V':l) = expandVar r txt (parseRef l)
expandRef r txt ('I':l) = expandInstance 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 ('T':l) = expandTycon r txt (parseRef l)
expandRef r txt ('L':l) = expandLink r txt (parseRef l) expandRef r txt ('L':l) = expandLink r txt (parseRef l)
expandRef r txt ('S':l) = expandSect r txt (parseRef l) expandRef r txt ('S':l) = expandSect r txt (parseRef l)
expandRef r txt ('&':l) = "</tt></td><td><tt>" ++ expandRefs r l expandRef r _ ('&':l) = "</tt></td><td><tt>" ++ expandRefs r l
expandRef r txt ('#':l) = "#" ++ expandRefs r l expandRef r _ ('#':l) = "#" ++ expandRefs r l
expandRef r txt ('.':l) = expandRefs r l expandRef r _ ('.':l) = expandRefs r l
expandRef r txt l = error ("Bad ref:" ++ l ++ "\n") expandRef _ _ l = error ("Bad ref:" ++ l ++ "\n")
parseRef :: String -> (String, String)
parseRef = break (\c -> isSpace c || c == '#') parseRef = break (\c -> isSpace c || c == '#')
expandVar :: Refs -> String -> (String, String) -> String
expandVar r txt (v,rest) = let n = mangleVar v expandVar r txt (v,rest) = let n = mangleVar v
f = lookup n r in f = lookup n r in
case f of case f of
Nothing -> trySig r txt v rest n Nothing -> trySig r txt v rest n
_ -> anchor v f n txt ++ expandRefs r rest _ -> anchor v f n txt ++ expandRefs r rest
expandTycon :: Refs -> String -> (String, String) -> String
expandTycon r txt (t,rest) = let n = mangleTycon t expandTycon r txt (t,rest) = let n = mangleTycon t
f = lookup n r in f = lookup n r in
anchor t f n txt ++ expandRefs r rest anchor t f n txt ++ expandRefs r rest
expandInstance :: Refs -> String -> (String, String) -> String
expandInstance r txt (c,'#':rest ) = let (t,rest') = parseRef rest expandInstance r txt (c,'#':rest ) = let (t,rest') = parseRef rest
n = mangleInstance c t n = mangleInstance c t
f = lookup n r in f = lookup n r in
anchor c f n txt ++ expandRefs r rest' anchor c f n txt ++ expandRefs r rest'
expandInstance r txt (c,l) = error ("bad instance " ++ l ++ "\n") expandInstance _ _ (_,l) = error ("bad instance " ++ l ++ "\n")
expandSect :: Refs -> String -> (String, String) -> String
expandSect r txt (s,rest) = let n = mangleSect s expandSect r txt (s,rest) = let n = mangleSect s
f = lookup n r in f = lookup n r in
"(see " ++ anchor s f n txt ++ ")" ++ "(see " ++ anchor s f n txt ++ ")" ++
expandRefs r rest expandRefs r rest
expandLink :: Refs -> String -> (String, String) -> String
expandLink r _ (t,'#':l') = expandRef r t l' expandLink r _ (t,'#':l') = expandRef r t l'
expandLink r _ (l,l') = error ("Bad link: " ++ l ++ l' ++ "\n") expandLink _ _ (l,l') = error ("Bad link: " ++ l ++ l' ++ "\n")
trySig :: Refs -> String -> String -> String -> String -> String
trySig r txt v rest n = trySig r txt v rest n =
let c = parseClass rest let c = parseClass rest
n = mangleTycon c n = mangleTycon c
f = lookup n r in f = lookup n r in
anchor v f n txt ++ expandRefs r rest anchor v f n txt ++ expandRefs r rest
anchor str file tag txt = anchor :: String -> Maybe String -> String -> String -> String
case file of anchor str mfile tag txt =
case mfile of
Just f -> "<a href=\"" ++ f ++ ".html#" ++ tag ++ Just f -> "<a href=\"" ++ f ++ ".html#" ++ tag ++
"\">" ++ t ++ "</a>" "\">" ++ t ++ "</a>"
Nothing -> "Bad tag:" ++ tag ++ " " ++ t Nothing -> "Bad tag:" ++ tag ++ " " ++ t
where where
t = htmlS $ if txt == "" then str else txt t = htmlS $ if txt == "" then str else txt
mangleVar :: String -> String
mangleVar n = "$v" ++ mangleName (filter (\c -> not (c `elem` "()")) n) mangleVar n = "$v" ++ mangleName (filter (\c -> not (c `elem` "()")) n)
mangleTycon :: String -> String
mangleTycon n = "$t" ++ mangleName n mangleTycon n = "$t" ++ mangleName n
mangleInstance :: String -> String -> String
mangleInstance c t = "$i" ++ mangleName c ++ "$$" ++ mangleName t mangleInstance c t = "$i" ++ mangleName c ++ "$$" ++ mangleName t
mangleSect :: String -> String
mangleSect s = "sect" ++ s mangleSect s = "sect" ++ s
mangleName :: String -> String
mangleName r = concat $ mangleName r = concatMap
map (\c -> case c of '(' -> "$P" (\c -> case c of '(' -> "$P"
')' -> "$C" ')' -> "$C"
'-' -> "$D" '-' -> "$D"
'[' -> "$B" '[' -> "$B"
...@@ -120,11 +138,12 @@ mangleName r = concat $ ...@@ -120,11 +138,12 @@ mangleName r = concat $
'=' -> "$Q" '=' -> "$Q"
_ -> [c]) r _ -> [c]) r
mangleType :: String -> String
mangleType t = mangleName (case t of mangleType t = mangleName (case t of
"(IO" -> "IO" "(IO" -> "IO"
"(a->b)" -> "->" "(a->b)" -> "->"
"[a]" -> "[]" "[a]" -> "[]"
x -> x) x -> x)
...@@ -136,36 +155,46 @@ readRefFile f = catchIOError ...@@ -136,36 +155,46 @@ readRefFile f = catchIOError
print e print e
return []) return [])
parseKV :: String -> (String, String)
parseKV l = let (k,l1) = span (/= '=') l parseKV l = let (k,l1) = span (/= '=') l
val = case l1 of val = case l1 of
('=':v) -> trim v ('=':v) -> trim v
_ -> "" _ -> ""
in (trimr k,val) in (trimr k,val)
parseClass :: String -> String
parseClass s = let s1 = (skip "(" . skip "::") s parseClass s = let s1 = (skip "(" . skip "::") s
(c,_) = span isAlpha (trim s1) in (c,_) = span isAlpha (trim s1) in
c c
trim :: String -> String
trim s = dropWhile isSpace s trim s = dropWhile isSpace s
trimr :: String -> String
trimr s = reverse (dropWhile isSpace (reverse s)) trimr s = reverse (dropWhile isSpace (reverse s))
starts :: String -> String -> Bool
starts [] _ = True starts [] _ = True
starts _ [] = False starts _ [] = False
starts (a:as) (b:bs) | a == b = starts as bs starts (a:as) (b:bs) | a == b = starts as bs
| otherwise = False | otherwise = False
skip :: String -> String -> String
skip val s = if val `starts` (trim s) then skip val s = if val `starts` (trim s) then
drop (length val) (trim s) drop (length val) (trim s)
else s else s
htmlEncode :: Char -> String
htmlEncode '>' = "&gt;" htmlEncode '>' = "&gt;"
htmlEncode '<' = "&lt;" htmlEncode '<' = "&lt;"
htmlEncode '&' = "&amp;" htmlEncode '&' = "&amp;"
htmlEncode c = [c] htmlEncode c = [c]
htmlS s = concat (map htmlEncode s) htmlS :: String -> String
htmlS s = concatMap htmlEncode s
nbspaces [] = [] nbspaces :: String -> String
nbspaces "" = ""
nbspaces (' ' : cs) = "&nbsp;" ++ nbspaces cs nbspaces (' ' : cs) = "&nbsp;" ++ nbspaces cs
nbspaces ('<':cs) = ['<'] ++ c ++ nbspaces r where nbspaces ('<':cs) = ['<'] ++ c ++ nbspaces r where
(c,r) = span (/= '>') cs (c,r) = span (/= '>') cs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment