aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorsimonmar <unknown>2002-07-24 09:42:18 +0000
committersimonmar <unknown>2002-07-24 09:42:18 +0000
commit4d8d5e948cd6620ed923bf7b11ce408a728e3521 (patch)
tree07cdc2e4dde15cb1e3a212d7f22998198829e6b6 /src
parent1d44cadf21cdf3d5437e6cd438723d9ce7c895e2 (diff)
[haddock @ 2002-07-24 09:42:17 by simonmar]
Patches to quieten ghc -Wall, from those nice folks at Galois.
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs84
-rw-r--r--src/BlockTable.hs16
-rw-r--r--src/Digraph.lhs53
-rw-r--r--src/FastMutInt.hs24
-rw-r--r--src/HaddockHH.hs16
-rw-r--r--src/HaddockHtml.hs359
-rw-r--r--src/HaddockLex.hs70
-rw-r--r--src/HaddockModuleTree.hs7
-rw-r--r--src/HaddockRename.hs142
-rw-r--r--src/HaddockUtil.hs56
-rw-r--r--src/HaddockVersion.hs2
-rw-r--r--src/HsLexer.lhs194
-rw-r--r--src/HsParseMonad.lhs22
-rw-r--r--src/HsParseUtils.lhs136
-rw-r--r--src/HsSyn.lhs41
-rw-r--r--src/Html.hs95
-rw-r--r--src/Main.hs207
17 files changed, 871 insertions, 653 deletions
diff --git a/src/Binary.hs b/src/Binary.hs
index 9a632089..33e3017a 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -64,7 +64,6 @@ import Char
import Monad
import Exception
import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
-import Array
import IO
#if __GLASGOW_HASKELL__ < 503
import PrelIOBase -- ( IOError(..), IOErrorType(..) )
@@ -77,11 +76,19 @@ import GHC.IOBase ( IO(..) )
#endif
type BinArray = MutableByteArray RealWorld Int
+newArray_ :: Ix ix => (ix, ix) -> IO (MutableByteArray RealWorld ix)
newArray_ bounds = stToIO (newCharArray bounds)
+
+unsafeWrite :: Ix ix => MutableByteArray RealWorld ix -> ix -> Word8 -> IO ()
unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
+
+unsafeRead :: Ix ix => MutableByteArray RealWorld ix -> ix -> IO Word8
unsafeRead arr ix = stToIO (readWord8Array arr ix)
+hPutArray :: Handle -> MutableByteArray RealWorld a -> Int -> IO ()
hPutArray h arr sz = hPutBufBA h arr sz
+
+hGetArray :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
hGetArray h sz = hGetBufBA h sz
#if __GLASGOW_HASKELL__ < 503
@@ -160,14 +167,15 @@ openBinMem size
| size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
| otherwise = do
arr <- newArray_ (0,size-1)
- arr_r <- newIORef arr
+ arr_r0 <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
- sz_r <- newFastMutInt
- writeFastMutInt sz_r size
- return (BinMem undefined ix_r sz_r arr_r)
+ sz_r0 <- newFastMutInt
+ writeFastMutInt sz_r0 size
+ return (BinMem undefined ix_r sz_r0 arr_r0)
-noBinHandleUserData = error "Binary.BinHandle: no user data"
+--noBinHandleUserData :: a
+--noBinHandleUserData = error "Binary.BinHandle: no user data"
--getUserData :: BinHandle -> BinHandleState
--getUserData bh = state bh
@@ -180,24 +188,24 @@ seekBin :: BinHandle -> Bin a -> IO ()
seekBin (BinIO _ ix_r h) (BinPtr p) = do
writeFastMutInt ix_r p
hSeek h AbsoluteSeek (fromIntegral p)
-seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
- sz <- readFastMutInt sz_r
+seekBin h@(BinMem _ ix_r sz_r0 _) (BinPtr p) = do
+ sz <- readFastMutInt sz_r0
if (p >= sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
isEOFBin :: BinHandle -> IO Bool
-isEOFBin (BinMem _ ix_r sz_r a) = do
+isEOFBin (BinMem _ ix_r sz_r0 _) = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
+ sz <- readFastMutInt sz_r0
return (ix >= sz)
-isEOFBin (BinIO _ ix_r h) = hIsEOF h
+isEOFBin (BinIO _ _ h) = hIsEOF h
writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
-writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
+writeBinMem (BinMem _ ix_r _ arr_r0) fn = do
h <- openFileEx fn (BinaryMode WriteMode)
- arr <- readIORef arr_r
+ arr <- readIORef arr_r0
ix <- readFastMutInt ix_r
hPutArray h arr ix
hClose h
@@ -212,24 +220,24 @@ readBinMem filename = do
when (count /= filesize)
(error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
hClose h
- arr_r <- newIORef arr
+ arr_r0 <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
- sz_r <- newFastMutInt
- writeFastMutInt sz_r filesize
- return (BinMem undefined {-initReadState-} ix_r sz_r arr_r)
+ sz_r0 <- newFastMutInt
+ writeFastMutInt sz_r0 filesize
+ return (BinMem undefined {-initReadState-} ix_r sz_r0 arr_r0)
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ ix_r sz_r arr_r) off = do
- sz <- readFastMutInt sz_r
+expandBin (BinMem _ _ sz_r0 arr_r0) off = do
+ sz <- readFastMutInt sz_r0
let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
- arr <- readIORef arr_r
+ arr <- readIORef arr_r0
arr' <- newArray_ (0,sz'-1)
sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
| i <- [ 0 .. sz-1 ] ]
- writeFastMutInt sz_r sz'
- writeIORef arr_r arr'
+ writeFastMutInt sz_r0 sz'
+ writeIORef arr_r0 arr'
hPutStrLn stderr ("expanding to size: " ++ show sz')
return ()
expandBin (BinIO _ _ _) _ = return ()
@@ -239,14 +247,14 @@ expandBin (BinIO _ _ _) _ = return ()
-- Low-level reading/writing of bytes
putWord8 :: BinHandle -> Word8 -> IO ()
-putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
+putWord8 h@(BinMem _ ix_r sz_r0 arr_r0) w = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
+ sz <- readFastMutInt sz_r0
-- double the size of the array if it overflows
if (ix >= sz)
then do expandBin h ix
putWord8 h w
- else do arr <- readIORef arr_r
+ else do arr <- readIORef arr_r0
unsafeWrite arr ix w
writeFastMutInt ix_r (ix+1)
return ()
@@ -257,12 +265,12 @@ putWord8 (BinIO _ ix_r h) w = do
return ()
getWord8 :: BinHandle -> IO Word8
-getWord8 (BinMem _ ix_r sz_r arr_r) = do
+getWord8 (BinMem _ ix_r sz_r0 arr_r0) = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
+ sz <- readFastMutInt sz_r0
when (ix >= sz) $
throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
- arr <- readIORef arr_r
+ arr <- readIORef arr_r0
w <- unsafeRead arr ix
writeFastMutInt ix_r (ix+1)
return w
@@ -363,8 +371,8 @@ instance Binary Int64 where
-- Instances for standard types
instance Binary () where
- put_ bh () = return ()
- get _ = return ()
+ put_ _ () = return ()
+ get _ = return ()
-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
instance Binary Bool where
@@ -494,22 +502,23 @@ data ByteArray = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)
newByteArray :: Int# -> IO MBA
-newByteArray sz = IO $ \s ->
- case newByteArray# sz s of { (# s, arr #) ->
+newByteArray sz = IO $ \s0 ->
+ case newByteArray# sz s0 of { (# s, arr #) ->
(# s, MBA arr #) }
freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
-freezeByteArray arr = IO $ \s ->
- case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
+freezeByteArray arr0 = IO $ \s0 ->
+ case unsafeFreezeByteArray# arr0 s0 of { (# s, arr #) ->
(# s, BA arr #) }
writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
-writeByteArray arr i w8 = IO $ \s ->
- case word8ToWord w8 of { W# w# ->
- case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
+writeByteArray arr i w8 = IO $ \s0 ->
+ case fromIntegral w8 of { W# w# ->
+ case writeCharArray# arr i (chr# (word2Int# w#)) s0 of { s ->
(# s , () #) }}
+indexByteArray :: ByteArray# -> Int# -> Word8
indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
instance (Integral a, Binary a) => Binary (Ratio a) where
@@ -530,6 +539,7 @@ putString bh str = put_ bh word8s
word8s :: [Word8]
word8s = map (fromIntegral.ord) str
+getString :: BinHandle -> IO String
getString bh = do
word8s <- get bh
return (map (chr.fromIntegral) (word8s :: [Word8]))
diff --git a/src/BlockTable.hs b/src/BlockTable.hs
index af540f4a..5cd46f1b 100644
--- a/src/BlockTable.hs
+++ b/src/BlockTable.hs
@@ -9,7 +9,7 @@
-- Stability : experimental
-- Portability : portable
--
--- $Id: BlockTable.hs,v 1.1 2002/04/08 16:41:37 simonmar Exp $
+-- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
--
-- An Html combinator library
--
@@ -102,7 +102,7 @@ infixr 3 `above`
-- to show boxes aka the above ascii renditions.
instance (Show a) => Show (BlockTable a) where
- showsPrec p = showsTable
+ showsPrec _ = showsTable
type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
@@ -115,7 +115,7 @@ single :: a -> BlockTable a
single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1
empty :: BlockTable a
-empty = Table (\ x y r -> r) 0 0
+empty = Table (\ _ _ r -> r) 0 0
-- You can compose tables, horizonally and vertically
@@ -134,12 +134,12 @@ t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->
-- but is always true for these combinators.
-- I should assert this!
-- I should even prove this.
- beside (x:xs) (y:ys) = (x ++ y) : beside xs ys
- beside (x:xs) [] = x : xs ++ r
- beside [] (y:ys) = y : ys ++ r
- beside [] [] = r
+ beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys
+ beside' (x:xs) [] = x : xs ++ r
+ beside' [] (y:ys) = y : ys ++ r
+ beside' [] [] = r
in
- beside (lst1 []) (lst2 []))
+ beside' (lst1 []) (lst2 []))
-- trans flips (transposes) over the x and y axis of
-- the table. It is only used internally, and typically
diff --git a/src/Digraph.lhs b/src/Digraph.lhs
index cc97a4a6..6bf8de7b 100644
--- a/src/Digraph.lhs
+++ b/src/Digraph.lhs
@@ -61,6 +61,7 @@ data SCC vertex = AcyclicSCC vertex
flattenSCCs :: [SCC a] -> [a]
flattenSCCs = concatMap flattenSCC
+flattenSCC :: SCC vertex -> [vertex]
flattenSCC (AcyclicSCC v) = [v]
flattenSCC (CyclicSCC vs) = vs
\end{code}
@@ -73,8 +74,8 @@ stronglyConnComp
-- a vertex key, they are ignored
-> [SCC node]
-stronglyConnComp edges
- = map get_node (stronglyConnCompR edges)
+stronglyConnComp edges0
+ = map get_node (stronglyConnCompR edges0)
where
get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
@@ -89,10 +90,10 @@ stronglyConnCompR
-> [SCC (node, key, [key])]
stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
-stronglyConnCompR edges
+stronglyConnCompR edges0
= map decode forest
where
- (graph, vertex_fn) = graphFromEdges edges
+ (graph, vertex_fn) = graphFromEdges edges0
forest = scc graph
decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
| otherwise = AcyclicSCC (vertex_fn v)
@@ -128,7 +129,7 @@ mapT :: (Vertex -> a -> b) -> Table a -> Table b
mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
buildG :: Bounds -> [Edge] -> Graph
-buildG bounds edges = accumArray (flip (:)) [] bounds edges
+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
transposeG :: Graph -> Graph
transposeG g = buildG (bounds g) (reverseE g)
@@ -138,7 +139,7 @@ reverseE g = [ (w, v) | (v, w) <- edges g ]
outdegree :: Graph -> Table Int
outdegree = mapT numEdges
- where numEdges v ws = length ws
+ where numEdges _ ws = length ws
indegree :: Graph -> Table Int
indegree = outdegree . transposeG
@@ -150,30 +151,30 @@ graphFromEdges
:: Ord key
=> [(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]))
-graphFromEdges edges
+graphFromEdges edges0
= (graph, \v -> vertex_map ! v)
where
- max_v = length edges - 1
- bounds = (0,max_v) :: (Vertex, Vertex)
- sorted_edges = sortBy lt edges
+ max_v = length edges0 - 1
+ bounds0 = (0,max_v) :: (Vertex, Vertex)
+ sorted_edges = sortBy lt edges0
edges1 = zipWith (,) [0..] sorted_edges
- graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
- vertex_map = array bounds edges1
+ graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
+ key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
+ vertex_map = array bounds0 edges1
(_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
-- key_vertex :: key -> Maybe Vertex
-- returns Nothing for non-interesting vertices
- key_vertex k = find 0 max_v
+ key_vertex k = findVertex 0 max_v
where
- find a b | a > b
+ findVertex a b | a > b
= Nothing
- find a b = case compare k (key_map ! mid) of
- LT -> find a (mid-1)
+ findVertex a b = case compare k (key_map ! mid) of
+ LT -> findVertex a (mid-1)
EQ -> Just mid
- GT -> find (mid+1) b
+ GT -> findVertex (mid+1) b
where
mid = (a + b) `div` 2
\end{code}
@@ -194,7 +195,7 @@ mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
\begin{code}
instance Show a => Show (Tree a) where
- showsPrec p t s = showTree t ++ s
+ showsPrec _ t s = showTree t ++ s
showTree :: Show a => Tree a -> String
showTree = drawTree . mapTree show
@@ -205,7 +206,8 @@ showForest = unlines . map showTree
drawTree :: Tree String -> String
drawTree = unlines . draw
-draw (Node x ts) = grp this (space (length this)) (stLoop ts)
+draw :: Tree String -> [String]
+draw (Node x ts0) = grp this (space (length this)) (stLoop ts0)
where this = s1 ++ x ++ " "
space n = replicate n ' '
@@ -214,10 +216,11 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts)
stLoop [t] = grp s2 " " (draw t)
stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
+ rsLoop [] = error "rsLoop:Unexpected empty list."
rsLoop [t] = grp s5 " " (draw t)
rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
- grp fst rst = zipWith (++) (fst:repeat rst)
+ grp fst0 rst = zipWith (++) (fst0:repeat rst)
[s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
\end{code}
@@ -257,7 +260,7 @@ prune bnds ts = runST (mkEmpty bnds >>= \m ->
chop m ts)
chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
-chop m [] = return []
+chop _ [] = return []
chop m (Node v ts : us)
= contains m v >>= \visited ->
if visited then
@@ -281,7 +284,7 @@ chop m (Node v ts : us)
------------------------------------------------------------
\begin{code}
---preorder :: Tree a -> [a]
+preorder :: Tree a -> [a]
preorder (Node a ts) = a : preorderF ts
preorderF :: Forest a -> [a]
@@ -300,7 +303,7 @@ preArr bnds = tabulate bnds . preorderF
------------------------------------------------------------
\begin{code}
---postorder :: Tree a -> [a]
+postorder :: Tree a -> [a]
postorder (Node a ts) = postorderF ts ++ [a]
postorderF :: Forest a -> [a]
@@ -384,7 +387,7 @@ do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
++ [lu | Node (u,du,lu) xs <- us])
bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
-bicomps (Node (v,dv,lv) ts)
+bicomps (Node (v,_,_) ts)
= [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
diff --git a/src/FastMutInt.hs b/src/FastMutInt.hs
index 0e98852b..39f4f99b 100644
--- a/src/FastMutInt.hs
+++ b/src/FastMutInt.hs
@@ -33,31 +33,31 @@ newByteArray# = newCharArray#
data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
newFastMutInt :: IO FastMutInt
-newFastMutInt = IO $ \s ->
- case newByteArray# size s of { (# s, arr #) ->
+newFastMutInt = IO $ \s0 ->
+ case newByteArray# size s0 of { (# s, arr #) ->
(# s, FastMutInt arr #) }
where I# size = SIZEOF_HSINT
readFastMutInt :: FastMutInt -> IO Int
-readFastMutInt (FastMutInt arr) = IO $ \s ->
- case readIntArray# arr 0# s of { (# s, i #) ->
+readFastMutInt (FastMutInt arr) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s, i #) ->
(# s, I# i #) }
writeFastMutInt :: FastMutInt -> Int -> IO ()
-writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
- case writeIntArray# arr 0# i s of { s ->
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->
+ case writeIntArray# arr 0# i s0 of { s ->
(# s, () #) }
incFastMutInt :: FastMutInt -> IO Int -- Returns original value
-incFastMutInt (FastMutInt arr) = IO $ \s ->
- case readIntArray# arr 0# s of { (# s, i #) ->
- case writeIntArray# arr 0# (i +# 1#) s of { s ->
+incFastMutInt (FastMutInt arr) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s1, i #) ->
+ case writeIntArray# arr 0# (i +# 1#) s1 of { s ->
(# s, I# i #) } }
incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value
-incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->
- case readIntArray# arr 0# s of { (# s, i #) ->
- case writeIntArray# arr 0# (i +# n) s of { s ->
+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->
+ case readIntArray# arr 0# s0 of { (# s1, i #) ->
+ case writeIntArray# arr 0# (i +# n) s1 of { s ->
(# s, I# i #) } }
#endif
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 5feac3e4..d1c0f486 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -7,6 +7,7 @@ import HaddockModuleTree
import HaddockUtil
import HaddockTypes
+contentsHHFile, indexHHFile :: String
contentsHHFile = "index.hhc"
indexHHFile = "index.hhk"
@@ -36,6 +37,7 @@ ppHHContents odir mods = do
fn :: [String] -> [ModuleTree] -> Doc
fn ss [x] = ppNode ss x
fn ss (x:xs) = ppNode ss x $$ fn ss xs
+ fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
ppNode :: [String] -> ModuleTree -> Doc
ppNode ss (Node s leaf []) =
@@ -50,11 +52,11 @@ ppHHContents odir mods = do
text "<LI>" <> nest 4
(text "<OBJECT type=\"text/sitemap\">" $$
text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
- (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mod) <> text "\">" else empty) $$
+ (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mdl) <> text "\">" else empty) $$
text "</OBJECT>") $+$
text "</LI>"
where
- mod = foldr (++) "" (s' : map ('.':) ss')
+ mdl = foldr (++) "" (s' : map ('.':) ss')
(s':ss') = reverse (s:ss)
-- reconstruct the module name
@@ -80,15 +82,15 @@ ppHHIndex odir ifaces = do
iface_indices = map getIfaceIndex ifaces
full_index = foldr1 plusFM iface_indices
- getIfaceIndex (mod,iface) = listToFM
- [ (name, mod) | (name, Qual mod' _) <- fmToList (iface_env iface), mod == mod']
+ getIfaceIndex (mdl,iface) = listToFM
+ [ (name, mdl) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
ppList [] = empty
- ppList ((name,Module mod):mods) =
+ ppList ((name,Module mdl):mdls) =
text "<LI>" <> nest 4
(text "<OBJECT type=\"text/sitemap\">" $$
text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
- text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mod) <> char '#' <> text (show name) <> text "\">" $$
+ text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mdl) <> char '#' <> text (show name) <> text "\">" $$
text "</OBJECT>") $+$
text "</LI>" $$
- ppList mods
+ ppList mdls
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index bfe19114..cdca7672 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -4,7 +4,7 @@
-- (c) Simon Marlow 2002
--
-module HaddockHtml (ppHtml) where
+module HaddockHtml ( ppHtml ) where
import Prelude hiding (div)
import HaddockVersion
@@ -21,16 +21,13 @@ import List ( sortBy )
import Char ( toUpper, toLower )
import Monad ( when )
-#ifdef __GLASGOW_HASKELL__
-import IOExts
-#endif
-
import Html
import qualified Html
-- -----------------------------------------------------------------------------
-- Files we need to copy from our $libdir
+cssFile, iconFile :: String
cssFile = "haddock.css"
iconFile = "haskell_icon.gif"
@@ -52,8 +49,7 @@ ppHtml :: String
-> Bool -- do MS Help stuff
-> IO ()
-ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue
- do_ms_help = do
+ppHtml doctitle source_url ifaces odir maybe_css libdir inst_maps prologue do_ms_help = do
let
css_file = case maybe_css of
Nothing -> libdir ++ pathSeparator:cssFile
@@ -64,28 +60,31 @@ ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue
icon_destination = odir ++ pathSeparator:iconFile
visible_ifaces = filter visible ifaces
- visible (m,i) = OptHide `notElem` iface_options i
+ visible (_, i) = OptHide `notElem` iface_options i
css_contents <- readFile css_file
writeFile css_destination css_contents
icon_contents <- readFile icon_file
writeFile icon_destination icon_contents
- ppHtmlContents odir title source_url (map fst visible_ifaces) prologue
- ppHtmlIndex odir title visible_ifaces
+ ppHtmlContents odir doctitle source_url (map fst visible_ifaces) prologue
+ ppHtmlIndex odir doctitle visible_ifaces
-- Generate index and contents page for MS help if requested
when do_ms_help $ do
ppHHContents odir (map fst visible_ifaces)
ppHHIndex odir visible_ifaces
- mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces
-
+ mapM_ (ppHtmlModule odir doctitle source_url inst_maps) visible_ifaces
+contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
+
+subIndexHtmlFile :: Char -> Char -> String
subIndexHtmlFile k a = "doc-index-" ++ k:a:".html"
+footer :: HtmlTable
footer =
tda [theclass "botbar"] <<
( toHtml "Produced by" <+>
@@ -94,7 +93,8 @@ footer =
)
-src_button source_url mod file
+src_button :: Maybe String -> String -> String -> HtmlTable
+src_button source_url _ file
| Just u <- source_url =
let src_url = if (last u == '/') then u ++ file else u ++ '/':file
in
@@ -102,50 +102,55 @@ src_button source_url mod file
| otherwise =
Html.emptyTable
-
-parent_button mod =
- case span (/= '.') (reverse mod) of
- (m, '.':rest) ->
+parent_button :: String -> HtmlTable
+parent_button mdl =
+ case span (/= '.') (reverse mdl) of
+ (_, '.':rest) ->
topButBox (
anchor ! [href (moduleHtmlFile "" (reverse rest))] << toHtml "Parent")
_ ->
Html.emptyTable
+contentsButton :: HtmlTable
contentsButton = topButBox (anchor ! [href contentsHtmlFile] <<
toHtml "Contents")
+indexButton :: HtmlTable
indexButton = topButBox (anchor ! [href indexHtmlFile] << toHtml "Index")
-simpleHeader title =
+simpleHeader :: String -> HtmlTable
+simpleHeader doctitle =
(tda [theclass "topbar"] <<
vanillaTable << (
(td <<
image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
) <->
- (tda [theclass "title"] << toHtml title) <->
+ (tda [theclass "title"] << toHtml doctitle) <->
contentsButton <-> indexButton
))
-pageHeader mod iface title source_url =
+pageHeader :: String -> Interface -> String -> Maybe String -> HtmlTable
+pageHeader mdl iface doctitle source_url =
(tda [theclass "topbar"] <<
vanillaTable << (
(td <<
image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
) <->
- (tda [theclass "title"] << toHtml title) <->
- src_button source_url mod (iface_filename iface) <->
- parent_button mod <->
+ (tda [theclass "title"] << toHtml doctitle) <->
+ src_button source_url mdl (iface_filename iface) <->
+ parent_button mdl <->
contentsButton <->
indexButton
)
) </>
tda [theclass "modulebar"] <<
(vanillaTable << (
- (td << font ! [size "6"] << toHtml mod) <->
+ (td << font ! [size "6"] << toHtml mdl) <->
moduleInfo iface
)
)
+moduleInfo :: Interface -> HtmlTable
moduleInfo iface =
case iface_info iface of
Nothing -> Html.emptyTable
@@ -164,16 +169,16 @@ moduleInfo iface =
ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> Maybe Doc
-> IO ()
-ppHtmlContents odir title source_url mods prologue = do
- let tree = mkModuleTree mods
+ppHtmlContents odir doctitle _ mdls prologue = do
+ let tree = mkModuleTree mdls
html =
- header (thetitle (toHtml title) +++
+ header (thetitle (toHtml doctitle) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader title </>
+ simpleHeader doctitle </>
ppPrologue prologue </>
- ppModuleTree title tree </>
+ ppModuleTree doctitle tree </>
s15 </>
footer
)
@@ -186,7 +191,7 @@ ppPrologue (Just doc) =
docBox (docToHtml doc)
ppModuleTree :: String -> [ModuleTree] -> HtmlTable
-ppModuleTree title ts =
+ppModuleTree _ ts =
tda [theclass "section1"] << toHtml "Modules" </>
td << table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)
@@ -199,9 +204,10 @@ mkNode ss (Node s leaf ts) =
(tda [theclass "children"] <<
vanillaTable (toHtml (aboves (map (mkNode (s:ss)) ts))))
-mkLeaf s ss False = toHtml s
-mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s
- where mod = foldr (++) "" (s' : map ('.':) ss')
+mkLeaf :: String -> [String] -> Bool -> Html
+mkLeaf s _ False = toHtml s
+mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s
+ where mdl = foldr (++) "" (s' : map ('.':) ss')
(s':ss') = reverse (s:ss)
-- reconstruct the module name
@@ -209,13 +215,13 @@ mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s
-- Generate the index
ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHtmlIndex odir title ifaces = do
+ppHtmlIndex odir doctitle ifaces = do
let html =
- header (thetitle (toHtml (title ++ " (Index)")) +++
+ header (thetitle (toHtml (doctitle ++ " (Index)")) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader title </>
+ simpleHeader doctitle </>
tda [theclass "section1"] << toHtml "Type/Class Index" </>
index_html tycls_index 't' </>
tda [theclass "section1"] << toHtml "Function/Constructor Index" </>
@@ -246,11 +252,11 @@ ppHtmlIndex odir title ifaces = do
= writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c)
(renderHtml html)
where
- html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
+ html = header (thetitle (toHtml (doctitle ++ " (" ++ descr ++ "Index)")) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader title </>
+ simpleHeader doctitle </>
tda [theclass "section1"] <<
toHtml (descr ++ " Index (" ++ c:")") </>
td << table ! [cellpadding 0, cellspacing 5] <<
@@ -272,24 +278,25 @@ ppHtmlIndex odir title ifaces = do
iface_indices f = map (getIfaceIndex f) ifaces
full_index f = foldr (plusFM_C (++)) emptyFM (iface_indices f)
- getIfaceIndex f (mod,iface) = listToFM
- [ (name, [(mod, mod == mod')])
- | (name, Qual mod' _) <- fmToList (iface_env iface),
- f name ]
+ getIfaceIndex f (mdl,iface) = listToFM
+ [ (nm, [(mdl, mdl == mdl')])
+ | (nm, Qual mdl' _) <- fmToList (iface_env iface), f nm ]
indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable
indexElt (nm, entries) =
td << ppHsName nm
<-> td << (hsep [ if defining then
- bold << anchor ! [href (linkId (Module mod) nm)]
- << toHtml mod
+ bold << anchor ! [href (linkId (Module mdl) nm)]
+ << toHtml mdl
else
- anchor ! [href (linkId (Module mod) nm)] << toHtml mod
- | (Module mod, defining) <- entries ])
+ anchor ! [href (linkId (Module mdl) nm)] << toHtml mdl
+ | (Module mdl, defining) <- entries ])
-nameBeginsWith (HsTyClsName id) c = idBeginsWith id c
-nameBeginsWith (HsVarName id) c = idBeginsWith id c
+nameBeginsWith :: HsName -> Char -> Bool
+nameBeginsWith (HsTyClsName id0) c = idBeginsWith id0 c
+nameBeginsWith (HsVarName id0) c = idBeginsWith id0 c
+idBeginsWith :: HsIdentifier -> Char -> Bool
idBeginsWith (HsIdent s) c = head s `elem` [toLower c, toUpper c]
idBeginsWith (HsSymbol s) c = head s `elem` [toLower c, toUpper c]
idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
@@ -299,21 +306,21 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
ppHtmlModule :: FilePath -> String -> Maybe String -> InstMaps
-> (Module,Interface) -> IO ()
-ppHtmlModule odir title source_url inst_maps (Module mod,iface) = do
+ppHtmlModule odir doctitle source_url inst_maps (Module mdl,iface) = do
let html =
- header (thetitle (toHtml mod) +++
+ header (thetitle (toHtml mdl) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- pageHeader mod iface title source_url </> s15 </>
- ifaceToHtml mod iface inst_maps </> s15 </>
+ pageHeader mdl iface doctitle source_url </> s15 </>
+ ifaceToHtml mdl iface inst_maps </> s15 </>
footer
)
- writeFile (moduleHtmlFile odir mod) (renderHtml html)
+ writeFile (moduleHtmlFile odir mdl) (renderHtml html)
ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable
-ifaceToHtml mod iface inst_maps
- = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: body)
+ifaceToHtml _ iface inst_maps
+ = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
where
exports = numberSectionHeadings (iface_exports iface)
@@ -353,7 +360,7 @@ ifaceToHtml mod iface inst_maps
_ -> tda [ theclass "section1" ] << toHtml "Documentation"
| otherwise = Html.emptyTable
- body = map (processExport False inst_maps) exports
+ bdy = map (processExport False inst_maps) exports
ppModuleContents :: [ExportItem] -> HtmlTable
ppModuleContents exports
@@ -364,15 +371,15 @@ ppModuleContents exports
(sections, _leftovers{-should be []-}) = process 0 exports
process :: Int -> [ExportItem] -> ([Html],[ExportItem])
- process n [] = ([], [])
- process n items@(ExportGroup lev id doc : rest)
+ process _ [] = ([], [])
+ process n items@(ExportGroup lev id0 doc : rest)
| lev <= n = ( [], items )
- | otherwise = ( html:sections, rest2 )
+ | otherwise = ( html:secs, rest2 )
where
- html = (dterm << anchor ! [href ('#':id)] << docToHtml doc)
- +++ mk_subsections subsections
- (subsections, rest1) = process lev rest
- (sections, rest2) = process n rest1
+ html = (dterm << anchor ! [href ('#':id0)] << docToHtml doc)
+ +++ mk_subsections ssecs
+ (ssecs, rest1) = process lev rest
+ (secs, rest2) = process n rest1
process n (_ : rest) = process n rest
mk_subsections [] = noHtml
@@ -382,26 +389,29 @@ ppModuleContents exports
-- them from the contents:
numberSectionHeadings :: [ExportItem] -> [ExportItem]
numberSectionHeadings exports = go 1 exports
- where go n [] = []
+ where go :: Int -> [ExportItem] -> [ExportItem]
+ go _ [] = []
go n (ExportGroup lev _ doc : es)
= ExportGroup lev (show n) doc : go (n+1) es
go n (other:es)
= other : go n es
processExport :: Bool -> InstMaps -> ExportItem -> HtmlTable
-processExport summary inst_maps (ExportGroup lev id doc)
- = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
+processExport _ _ (ExportGroup lev id0 doc)
+ = ppDocGroup lev (anchor ! [name id0] << docToHtml doc)
processExport summary inst_maps (ExportDecl x decl)
= doDecl summary inst_maps x decl
-processExport summary inst_maps (ExportDoc doc)
+processExport _ _ (ExportDoc doc)
= docBox (docToHtml doc)
-processExport summary inst_maps (ExportModule (Module mod))
- = declBox (toHtml "module" <+> ppHsModule mod)
+processExport _ _ (ExportModule (Module mdl))
+ = declBox (toHtml "module" <+> ppHsModule mdl)
+forSummary :: ExportItem -> Bool
forSummary (ExportGroup _ _ _) = False
-forSummary (ExportDoc _) = False
-forSummary _ = True
+forSummary (ExportDoc _) = False
+forSummary _ = True
+ppDocGroup :: Int -> Html -> HtmlTable
ppDocGroup lev doc
| lev == 1 = tda [ theclass "section1" ] << doc
| lev == 2 = tda [ theclass "section2" ] << doc
@@ -412,13 +422,13 @@ ppDocGroup lev doc
-- Converting declarations to HTML
declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable
-declWithDoc True doc html_decl = declBox html_decl
+declWithDoc True _ html_decl = declBox html_decl
declWithDoc False Nothing html_decl = declBox html_decl
declWithDoc False (Just doc) html_decl =
declBox html_decl </> docBox (docToHtml doc)
doDecl :: Bool -> InstMaps -> HsQName -> HsDecl -> HtmlTable
-doDecl summary inst_maps x decl = do_decl decl
+doDecl summary inst_maps x d = do_decl d
where
do_decl (HsTypeSig _ [nm] ty doc)
= ppFunSig summary nm ty doc
@@ -436,19 +446,20 @@ doDecl summary inst_maps x decl = do_decl decl
(HsDataDecl loc ctx nm args [con] drv doc)
-- print it as a single-constructor datatype
- do_decl decl@(HsDataDecl loc ctx nm args cons drv doc)
- = ppHsDataDecl summary inst_maps False{-not newtype-} x decl
+ do_decl d0@(HsDataDecl{})
+ = ppHsDataDecl summary inst_maps False{-not newtype-} x d0
- do_decl decl@(HsClassDecl{})
- = ppHsClassDecl summary inst_maps x decl
+ do_decl d0@(HsClassDecl{})
+ = ppHsClassDecl summary inst_maps x d0
- do_decl (HsDocGroup loc lev str)
+ do_decl (HsDocGroup _ lev str)
= if summary then Html.emptyTable
else ppDocGroup lev (docToHtml str)
- do_decl _ = error ("do_decl: " ++ show decl)
+ do_decl _ = error ("do_decl: " ++ show d)
+ppTypeSig :: Bool -> HsName -> HsType -> Html
ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
-- -----------------------------------------------------------------------------
@@ -456,11 +467,11 @@ ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
ppShortDataDecl summary is_newty
- (HsDataDecl loc ctx nm args [con] drv _doc) =
+ (HsDataDecl _ _ nm args [con] _ _doc) =
ppHsDataHeader summary is_newty nm args
<+> equals <+> ppShortConstr summary con
ppShortDataDecl summary is_newty
- (HsDataDecl loc ctx nm args cons drv _doc) =
+ (HsDataDecl _ _ nm args cons _ _doc) =
vanillaTable << (
declBox (ppHsDataHeader summary is_newty nm args) </>
tda [theclass "body"] << vanillaTable << (
@@ -468,22 +479,25 @@ ppShortDataDecl summary is_newty
)
)
where do_constr c con = declBox (toHtml [c] <+> ppShortConstr summary con)
+ppShortDataDecl _ _ d =
+ error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d
-- The rest of the cases:
-
+ppHsDataDecl :: Ord key => Bool -> (a, FiniteMap key [InstHead])
+ -> Bool -> key -> HsDecl -> HtmlTable
ppHsDataDecl summary (_, ty_inst_map) is_newty
- x decl@(HsDataDecl loc ctx nm args cons drv doc)
+ x decl@(HsDataDecl _ _ nm args cons _ doc)
| summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
| otherwise
- = header </>
+ = dataheader </>
tda [theclass "body"] << vanillaTable << (
datadoc </>
constr_bit </>
instances_bit
)
where
- header = declBox (ppHsDataHeader False is_newty nm args)
+ dataheader = declBox (ppHsDataHeader False is_newty nm args)
constr_table
| any isRecDecl cons = spacedTable5
@@ -511,19 +525,23 @@ ppHsDataDecl summary (_, ty_inst_map) is_newty
tda [theclass "body"] << spacedTable1 << (
aboves (map (declBox.ppInstHead) is)
)
+ppHsDataDecl _ _ _ _ d =
+ error $ "HaddockHtml.ppHsDataDecl: unexpected decl " ++ show d
-isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True
-isRecDecl _ = False
+isRecDecl :: HsConDecl -> Bool
+isRecDecl (HsRecDecl{}) = True
+isRecDecl _ = False
ppShortConstr :: Bool -> HsConDecl -> Html
-ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) =
+ppShortConstr summary (HsConDecl _ nm tvs ctxt typeList _maybe_doc) =
ppHsConstrHdr tvs ctxt +++
hsep (ppHsBinder summary nm : map ppHsBangType typeList)
-ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
+ppShortConstr summary (HsRecDecl _ nm tvs ctxt fields _) =
ppHsConstrHdr tvs ctxt +++
ppHsBinder summary nm <+>
braces (vanillaTable << aboves (map (ppShortField summary) fields))
+ppHsConstrHdr :: [HsName] -> HsContext -> Html
ppHsConstrHdr tvs ctxt
= (if null tvs then noHtml else keyword "forall" <+>
hsep (map ppHsName tvs) <+>
@@ -531,31 +549,35 @@ ppHsConstrHdr tvs ctxt
+++
(if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
-ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) =
+ppSideBySideConstr :: HsConDecl -> HtmlTable
+ppSideBySideConstr (HsConDecl _ nm tvs ctxt typeList doc) =
declBox (hsep ((ppHsConstrHdr tvs ctxt +++
ppHsBinder False nm) : map ppHsBangType typeList)) <->
maybeRDocBox doc
-ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) =
+ppSideBySideConstr (HsRecDecl _ nm tvs ctxt fields doc) =
declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
maybeRDocBox doc </>
(tda [theclass "body"] << spacedTable1 <<
aboves (map ppSideBySideField fields))
+ppSideBySideField :: HsFieldDecl -> HtmlTable
ppSideBySideField (HsFieldDecl ns ty doc) =
declBox (hsep (punctuate comma (map (ppHsBinder False) ns))
<+> toHtml "::" <+> ppHsBangType ty) <->
maybeRDocBox doc
-ppHsFullConstr (HsConDecl pos nm tvs ctxt typeList doc) =
+{-
+ppHsFullConstr :: HsConDecl -> Html
+ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
declWithDoc False doc (
hsep ((ppHsConstrHdr tvs ctxt +++
ppHsBinder False nm) : map ppHsBangType typeList)
)
-ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) =
+ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
td << vanillaTable << (
case doc of
- Nothing -> aboves [hdr, fields_html]
- Just doc -> aboves [hdr, constr_doc, fields_html]
+ Nothing -> aboves [hdr, fields_html]
+ Just _ -> aboves [hdr, constr_doc, fields_html]
)
where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
@@ -569,22 +591,28 @@ ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) =
table ! [width "100%", cellpadding 0, cellspacing 8] << (
aboves (map ppFullField (concat (map expandField fields)))
)
+-}
-
+ppShortField :: Bool -> HsFieldDecl -> HtmlTable
ppShortField summary (HsFieldDecl ns ty _doc)
= tda [theclass "recfield"] << (
hsep (punctuate comma (map (ppHsBinder summary) ns))
<+> toHtml "::" <+> ppHsBangType ty
)
+{-
+ppFullField :: HsFieldDecl -> Html
ppFullField (HsFieldDecl [n] ty doc)
= declWithDoc False doc (
ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty
)
ppFullField _ = error "ppFullField"
+expandField :: HsFieldDecl -> [HsFieldDecl]
expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
+-}
+ppHsDataHeader :: Bool -> Bool -> HsName -> [HsName] -> Html
ppHsDataHeader summary is_newty nm args =
(if is_newty then keyword "newtype" else keyword "data") <+>
ppHsBinder summary nm <+> hsep (map ppHsName args)
@@ -596,6 +624,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsAType ty
-- -----------------------------------------------------------------------------
-- Class declarations
+ppClassHdr :: Bool -> HsContext -> HsName -> [HsName] -> [HsFunDep] -> Html
ppClassHdr summ [] n tvs fds =
keyword "class"
<+> ppHsBinder summ n <+> hsep (map ppHsName tvs)
@@ -605,6 +634,7 @@ ppClassHdr summ ctxt n tvs fds =
<+> ppHsBinder summ n <+> hsep (map ppHsName tvs)
<+> ppFds fds
+ppFds :: [HsFunDep] -> Html
ppFds fds =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map fundep fds))
@@ -612,8 +642,9 @@ ppFds fds =
fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
hsep (map ppHsName vars2)
-ppShortClassDecl summary inst_maps
- decl@(HsClassDecl loc ctxt nm tvs fds decls doc) =
+ppShortClassDecl :: Bool -> a -> HsDecl -> HtmlTable
+ppShortClassDecl summary _
+ (HsClassDecl _ ctxt nm tvs fds decls _) =
if null decls
then declBox hdr
else declBox (hdr <+> keyword "where")
@@ -627,19 +658,23 @@ ppShortClassDecl summary inst_maps
where
hdr = ppClassHdr summary ctxt nm tvs fds
+ppShortClassDecl _ _ d =
+ error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d
+ppHsClassDecl :: Ord key => Bool -> (FiniteMap key [InstHead], t_a4nrR)
+ -> key -> HsDecl -> HtmlTable
ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c
- decl@(HsClassDecl loc ctxt nm tvs fds decls doc)
+ decl@(HsClassDecl _ ctxt nm tvs fds decls doc)
| summary = ppShortClassDecl summary inst_maps decl
| otherwise
- = header </>
+ = classheader </>
tda [theclass "body"] << vanillaTable << (
classdoc </> methods_bit </> instances_bit
)
where
- header
+ classheader
| null decls = declBox hdr
| otherwise = declBox (hdr <+> keyword "where")
@@ -654,8 +689,8 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c
| otherwise =
s8 </> meth_hdr </>
tda [theclass "body"] << vanillaTable << (
- abovesSep s8 [ ppFunSig summary n ty doc
- | HsTypeSig _ [n] ty doc <- decls
+ abovesSep s8 [ ppFunSig summary n ty doc0
+ | HsTypeSig _ [n] ty doc0 <- decls
]
)
@@ -670,6 +705,8 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c
)
instances = lookupFM cls_inst_map orig_c
+ppHsClassDecl _ _ _ d =
+ error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d
ppInstHead :: InstHead -> Html
@@ -679,14 +716,15 @@ ppInstHead (ctxt,asst) = ppHsContext ctxt <+> darrow <+> ppHsAsst asst
-- ----------------------------------------------------------------------------
-- Type signatures
-ppFunSig summary nm ty doc
- | summary || no_arg_docs ty =
- declWithDoc summary doc (ppTypeSig summary nm ty)
+ppFunSig :: Bool -> HsName -> HsType -> Maybe Doc -> HtmlTable
+ppFunSig summary nm ty0 doc
+ | summary || no_arg_docs ty0 =
+ declWithDoc summary doc (ppTypeSig summary nm ty0)
| otherwise =
declBox (ppHsBinder False nm) </>
(tda [theclass "body"] << vanillaTable << (
- do_args dcolon ty </>
+ do_args dcolon ty0 </>
(if (isJust doc)
then ndocBox (docToHtml (fromJust doc))
else Html.emptyTable)
@@ -710,18 +748,18 @@ ppFunSig summary nm ty doc
= (declBox (leader <+> ppHsContext ctxt)
<-> rdocBox noHtml) </>
do_args darrow ty
- do_args leader (HsTyFun (HsTyDoc ty doc) r)
- = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc)) </>
- do_args arrow r
+ do_args leader (HsTyFun (HsTyDoc ty doc0) r)
+ = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc0))
+ </> do_args arrow r
do_args leader (HsTyFun ty r)
= (declBox (leader <+> ppHsBType ty) <-> rdocBox noHtml) </>
do_args arrow r
- do_args leader (HsTyDoc ty doc)
- = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc))
+ do_args leader (HsTyDoc ty doc0)
+ = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc0))
do_args leader ty
= declBox (leader <+> ppHsBType ty) <-> rdocBox (noHtml)
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
-- Types and contexts
ppHsAsst :: (HsQName,[HsType]) -> Html
@@ -731,6 +769,7 @@ ppHsContext :: HsContext -> Html
ppHsContext [] = empty
ppHsContext context = parenList (map ppHsAsst context)
+ppHsForAll :: Maybe [HsName] -> HsContext -> Html
ppHsForAll Nothing context =
hsep [ ppHsContext context, darrow ]
ppHsForAll (Just tvs) [] =
@@ -745,7 +784,8 @@ ppHsType (HsForAllType maybe_tvs context htype) =
ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
ppHsType t = ppHsBType t
-ppHsBType (HsTyDoc ty doc) = ppHsBType ty
+ppHsBType :: HsType -> Html
+ppHsBType (HsTyDoc ty _) = ppHsBType ty
ppHsBType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b
@@ -754,15 +794,15 @@ ppHsBType t = ppHsAType t
ppHsAType :: HsType -> Html
ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
-ppHsAType (HsTyVar name) = ppHsName name
-ppHsAType (HsTyCon name)
- | name == fun_tycon_qname = parens $ ppHsQName name
- | otherwise = ppHsQName name
+ppHsAType (HsTyVar nm) = ppHsName nm
+ppHsAType (HsTyCon nm)
+ | nm == fun_tycon_qname = parens $ ppHsQName nm
+ | otherwise = ppHsQName nm
ppHsAType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsAType t = parens $ ppHsType t
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
-- Names
linkTarget :: HsName -> Html
@@ -770,21 +810,22 @@ linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml ""
ppHsQName :: HsQName -> Html
ppHsQName (UnQual str) = ppHsName str
-ppHsQName n@(Qual mod str)
+ppHsQName n@(Qual mdl str)
| n == unit_con_name = ppHsName str
| isSpecial str = ppHsName str
- | otherwise = anchor ! [href (linkId mod str)] << ppHsName str
+ | otherwise = anchor ! [href (linkId mdl str)] << ppHsName str
-isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
-isSpecial (HsVarName id) | HsSpecial _ <- id = True
-isSpecial _ = False
+isSpecial :: HsName -> Bool
+isSpecial (HsTyClsName id0) | HsSpecial _ <- id0 = True
+isSpecial (HsVarName id0) | HsSpecial _ <- id0 = True
+isSpecial _ = False
ppHsName :: HsName -> Html
ppHsName nm = toHtml (hsNameStr nm)
hsNameStr :: HsName -> String
-hsNameStr (HsTyClsName id) = ppHsIdentifier id
-hsNameStr (HsVarName id) = ppHsIdentifier id
+hsNameStr (HsTyClsName id0) = ppHsIdentifier id0
+hsNameStr (HsVarName id0) = ppHsIdentifier id0
ppHsIdentifier :: HsIdentifier -> String
ppHsIdentifier (HsIdent str) = str
@@ -795,8 +836,9 @@ ppHsBinder :: Bool -> HsName -> Html
ppHsBinder True nm = anchor ! [href ('#':hsNameStr nm)] << ppHsBinder' nm
ppHsBinder False nm = linkTarget nm +++ bold << ppHsBinder' nm
-ppHsBinder' (HsTyClsName id) = ppHsBindIdent id
-ppHsBinder' (HsVarName id) = ppHsBindIdent id
+ppHsBinder' :: HsName -> Html
+ppHsBinder' (HsTyClsName id0) = ppHsBindIdent id0
+ppHsBinder' (HsVarName id0) = ppHsBindIdent id0
ppHsBindIdent :: HsIdentifier -> Html
ppHsBindIdent (HsIdent str) = toHtml str
@@ -804,20 +846,20 @@ ppHsBindIdent (HsSymbol str) = parens (toHtml str)
ppHsBindIdent (HsSpecial str) = toHtml str
linkId :: Module -> HsName -> String
-linkId (Module mod) str = moduleHtmlFile fp mod ++ '#': hsNameStr str
- where fp = case lookupFM html_xrefs (Module mod) of
- Just fp -> fp
- Nothing -> ""
+linkId (Module mdl) str = moduleHtmlFile fp mdl ++ '#': hsNameStr str
+ where fp = case lookupFM html_xrefs (Module mdl) of
+ Just fp0 -> fp0
+ Nothing -> ""
ppHsModule :: String -> Html
-ppHsModule mod = anchor ! [href (moduleHtmlFile fp mod)] << toHtml mod
- where fp = case lookupFM html_xrefs (Module mod) of
- Just fp -> fp
- Nothing -> ""
+ppHsModule mdl = anchor ! [href (moduleHtmlFile fp mdl)] << toHtml mdl
+ where fp = case lookupFM html_xrefs (Module mdl) of
+ Just fp0 -> fp0
+ Nothing -> ""
-- -----------------------------------------------------------------------------
-- * Doc Markup
-
+htmlMarkup :: DocMarkup [HsQName] Html
htmlMarkup = Markup {
markupParagraph = paragraph,
markupEmpty = toHtml "",
@@ -835,9 +877,10 @@ htmlMarkup = Markup {
-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers).
-docToHtml (DocParagraph p) = docToHtml p
-docToHtml (DocCodeBlock p) = docToHtml (DocMonospaced p)
-docToHtml doc = markup htmlMarkup doc
+docToHtml :: Doc -> Html
+docToHtml (DocParagraph d) = docToHtml d
+docToHtml (DocCodeBlock d) = docToHtml (DocMonospaced d)
+docToHtml doc = markup htmlMarkup doc
-- -----------------------------------------------------------------------------
-- * Misc
@@ -847,33 +890,40 @@ hsep [] = noHtml
hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
infixr 8 <+>
+(<+>) :: Html -> Html -> Html
a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b))
+keyword :: String -> Html
keyword s = thespan ! [theclass "keyword"] << toHtml s
+equals, comma :: Html
equals = char '='
comma = char ','
+char :: Char -> Html
char c = toHtml [c]
+
+empty :: Html
empty = noHtml
-parens p = char '(' +++ p +++ char ')'
-brackets p = char '[' +++ p +++ char ']'
-braces p = char '{' +++ p +++ char '}'
+parens, brackets, braces :: Html -> Html
+parens h = char '(' +++ h +++ char ')'
+brackets h = char '[' +++ h +++ char ']'
+braces h = char '{' +++ h +++ char '}'
punctuate :: Html -> [Html] -> [Html]
-punctuate p [] = []
-punctuate p (d:ds) = go d ds
+punctuate _ [] = []
+punctuate h (d0:ds) = go d0 ds
where
go d [] = [d]
- go d (e:es) = (d +++ p) : go e es
+ go d (e:es) = (d +++ h) : go e es
abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
-abovesSep p [] = Html.emptyTable
-abovesSep p (d:ds) = go d ds
+abovesSep _ [] = Html.emptyTable
+abovesSep h (d0:ds) = go d0 ds
where
go d [] = d
- go d (e:es) = d </> p </> go e es
+ go d (e:es) = d </> h </> go e es
parenList :: [Html] -> Html
parenList = parens . hsep . punctuate comma
@@ -881,9 +931,13 @@ parenList = parens . hsep . punctuate comma
ubxParenList :: [Html] -> Html
ubxParenList = ubxparens . hsep . punctuate comma
-ubxparens p = toHtml "(#" +++ p +++ toHtml "#)"
+ubxparens :: Html -> Html
+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+{-
+text :: Html
text = strAttr "TEXT"
+-}
-- a box for displaying code
declBox :: Html -> HtmlTable
@@ -907,20 +961,25 @@ maybeRDocBox Nothing = rdocBox (noHtml)
maybeRDocBox (Just doc) = rdocBox (docToHtml doc)
-- a box for the buttons at the top of the page
+topButBox :: Html -> HtmlTable
topButBox html = tda [theclass "topbut"] << html
-- a vanilla table has width 100%, no border, no padding, no spacing
-- a narrow table is the same but without width 100%.
+vanillaTable, narrowTable :: Html -> Html
vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]
narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0]
+spacedTable1, spacedTable5 :: Html -> Html
spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0]
spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
+constr_hdr, meth_hdr, inst_hdr :: HtmlTable
constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
inst_hdr = tda [ theclass "section4" ] << toHtml "Instances"
+dcolon, arrow, darrow :: Html
dcolon = toHtml "::"
arrow = toHtml "->"
darrow = toHtml "=>"
diff --git a/src/HaddockLex.hs b/src/HaddockLex.hs
index aa299ecd..fdfc743a 100644
--- a/src/HaddockLex.hs
+++ b/src/HaddockLex.hs
@@ -25,6 +25,7 @@ data Token
| TokBirdTrack
deriving Show
+isSpecial, isSingleQuote, isIdent :: Char -> Bool
isSpecial c = c `elem` ['\"', '@', '/']
isSingleQuote c = c `elem` ['\'', '`']
isIdent c = isAlphaNum c || c `elem` "_.!#$%&*+/<=>?@\\^|-~"
@@ -43,14 +44,16 @@ tokenise str = case str of
| isSpecial c -> TokSpecial c : tokenise1 cs
_other -> tokenise_string "" str
-tokenise_newline cs =
- case dropWhile nonNewlineSpace cs of
+tokenise_newline :: String -> [Token]
+tokenise_newline cs0 =
+ case dropWhile nonNewlineSpace cs0 of
'\n':cs -> TokPara : tokenise_para cs -- paragraph break
'>':cs -> TokBirdTrack : tokenise_birdtrack cs -- bird track
- _other -> tokenise_string "" cs
+ _ -> tokenise_string "" cs0
-tokenise_para cs =
- case dropWhile nonNewlineSpace cs of
+tokenise_para :: String -> [Token]
+tokenise_para cs0 =
+ case dropWhile nonNewlineSpace cs0 of
-- bullet: '*'
'*':cs -> TokBullet : tokenise cs
-- bullet: '-'
@@ -63,8 +66,9 @@ tokenise_para cs =
-- enumerated item: '(1)'
'(':cs | (ds,')':cs') <- span isDigit cs, not (null ds)
-> TokNumber : tokenise cs'
- other -> tokenise cs
+ _ -> tokenise cs0
+nonNewlineSpace :: Char -> Bool
nonNewlineSpace c = isSpace c && c /= '\n'
-- ----------------------------------------------------------------------------
@@ -75,20 +79,23 @@ tokenise1 :: String -> [Token]
tokenise1 str = tokenise_string "" str
-- found a single quote, check whether we have an identifier...
-tokenise_identifier q cs =
- let (ident,rest) = break (not.isIdent) cs in
+tokenise_identifier :: Char -> String -> [Token]
+tokenise_identifier q cs0 =
+ let (ident,rest) = break (not.isIdent) cs0 in
case (rest, strToHsQNames ident) of
(c:cs, Just names) | isSingleQuote c -> TokIdent names : tokenise1 cs
- _other -> tokenise_string [q] cs
+ _ -> tokenise_string [q] cs0
+tokenise_url :: String -> [Token]
tokenise_url cs =
- let (url,rest) = break (=='>') cs in
- TokURL url : case rest of
+ let (url,rest0) = break (=='>') cs in
+ TokURL url : case rest0 of
'>':rest -> tokenise1 rest
- _ -> tokenise1 rest
+ _ -> tokenise1 rest0
-tokenise_string str cs =
- case cs of
+tokenise_string :: String -> String -> [Token]
+tokenise_string str cs0 =
+ case cs0 of
[] -> tokString str []
'\\':c:cs -> tokenise_string (c:str) cs
'\n':cs -> tokenise_string_newline str cs
@@ -97,19 +104,22 @@ tokenise_string str cs =
| isSingleQuote c -> tokString str (tokenise_identifier c cs)
| otherwise -> tokenise_string (c:str) cs
-tokenise_string_newline str cs =
- case dropWhile nonNewlineSpace cs of
+tokenise_string_newline :: String -> String -> [Token]
+tokenise_string_newline str cs0 =
+ case dropWhile nonNewlineSpace cs0 of
'\n':cs -> tokString str (TokPara : tokenise_para cs)
-- paragraph break: throw away all whitespace
'>':cs -> tokString ('\n':str) (TokBirdTrack : tokenise_birdtrack cs)
-- keep the \n, but throw away any space before the '>'
- _other -> tokenise_string ('\n':str) cs
+ _ -> tokenise_string ('\n':str) cs0
-- don't throw away whitespace at all
+tokString :: String -> [Token] -> [Token]
tokString [] rest = rest
tokString cs rest = TokString (reverse cs) : rest
-- A bird-tracked line is verbatim, no markup characters are interpreted
+tokenise_birdtrack :: String -> [Token]
tokenise_birdtrack cs =
let (line, rest) = break (=='\n') cs in
TokString line : tokenise1 rest
@@ -118,27 +128,27 @@ tokenise_birdtrack cs =
-- Lex a string as a Haskell identifier
strToHsQNames :: String -> Maybe [HsQName]
-strToHsQNames str
- = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of
+strToHsQNames str0
+ = case lexer (\t -> returnP t) str0 (SrcLoc 1 1) 1 1 [] of
Ok _ (VarId str)
-> Just [ UnQual (HsVarName (HsIdent str)) ]
- Ok _ (QVarId (mod,str))
- -> Just [ Qual (Module mod) (HsVarName (HsIdent str)) ]
+ Ok _ (QVarId (mod0,str))
+ -> Just [ Qual (Module mod0) (HsVarName (HsIdent str)) ]
Ok _ (ConId str)
-> Just [ UnQual (HsTyClsName (HsIdent str)),
UnQual (HsVarName (HsIdent str)) ]
- Ok _ (QConId (mod,str))
- -> Just [ Qual (Module mod) (HsTyClsName (HsIdent str)),
- Qual (Module mod) (HsVarName (HsIdent str)) ]
+ Ok _ (QConId (mod0,str))
+ -> Just [ Qual (Module mod0) (HsTyClsName (HsIdent str)),
+ Qual (Module mod0) (HsVarName (HsIdent str)) ]
Ok _ (VarSym str)
-> Just [ UnQual (HsVarName (HsSymbol str)) ]
Ok _ (ConSym str)
-> Just [ UnQual (HsTyClsName (HsSymbol str)),
UnQual (HsVarName (HsSymbol str)) ]
- Ok _ (QVarSym (mod,str))
- -> Just [ Qual (Module mod) (HsVarName (HsSymbol str)) ]
- Ok _ (QConSym (mod,str))
- -> Just [ Qual (Module mod) (HsTyClsName (HsSymbol str)),
- Qual (Module mod) (HsVarName (HsSymbol str)) ]
- other
+ Ok _ (QVarSym (mod0,str))
+ -> Just [ Qual (Module mod0) (HsVarName (HsSymbol str)) ]
+ Ok _ (QConSym (mod0,str))
+ -> Just [ Qual (Module mod0) (HsTyClsName (HsSymbol str)),
+ Qual (Module mod0) (HsVarName (HsSymbol str)) ]
+ _other
-> Nothing
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index d8b46871..93f0f162 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -15,11 +15,12 @@ addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts)
| s1 == s2 = Node s2 (leaf || null ss) (addToTrees ss subs) : ts
| otherwise = mkSubTree (s1:ss) ++ t : ts
+mkSubTree :: [String] -> [ModuleTree]
mkSubTree [] = []
mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]
splitModule :: Module -> [String]
-splitModule (Module mod) = split mod
- where split mod = case break (== '.') mod of
+splitModule (Module mdl) = split mdl
+ where split mdl0 = case break (== '.') mdl0 of
(s1, '.':s2) -> s1 : split s2
- (s1, _) -> [s1]
+ (s1, _) -> [s1]
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index c773131e..2717e605 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -34,13 +34,17 @@ instance Monad (GenRnM n) where
(>>=) = thenRn
return = returnRn
-returnRn a = RnM (\lkp -> (a,[]))
+returnRn :: a -> GenRnM n a
+returnRn a = RnM (\_ -> (a,[]))
+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
m `thenRn` k = RnM (\lkp -> case unRn m lkp of
(a,out1) -> case unRn (k a) lkp of
(b,out2) -> (b,out1++out2))
+getLookupRn :: RnM (HsQName -> Maybe HsQName)
getLookupRn = RnM (\lkp -> (lkp,[]))
-outRn name = RnM (\lkp -> ((),[name]))
+outRn :: HsQName -> RnM ()
+outRn name = RnM (\_ -> ((),[name]))
lookupRn :: (HsQName -> a) -> HsQName -> RnM a
lookupRn and_then name = do
@@ -68,11 +72,11 @@ renameExportList spec = mapM renameExport spec
cs' <- mapM (lookupRn id) cs
lookupRn (\x' -> HsEThingWith x' cs') x
renameExport (HsEModuleContents m) = return (HsEModuleContents m)
- renameExport (HsEGroup lev doc) = do
- doc <- renameDoc doc
+ renameExport (HsEGroup lev doc0) = do
+ doc <- renameDoc doc0
return (HsEGroup lev doc)
- renameExport (HsEDoc doc) = do
- doc <- renameDoc doc
+ renameExport (HsEDoc doc0) = do
+ doc <- renameDoc doc0
return (HsEDoc doc)
renameExport (HsEDocNamed str) = return (HsEDocNamed str)
@@ -80,84 +84,89 @@ renameExportList spec = mapM renameExport spec
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
= case decl of
- HsTypeDecl loc t args ty doc -> do
- ty <- renameType ty
- doc <- renameMaybeDoc doc
+ HsTypeDecl loc t args ty0 doc0 -> do
+ ty <- renameType ty0
+ doc <- renameMaybeDoc doc0
return (HsTypeDecl loc t args ty doc)
- HsDataDecl loc ctx t args cons drv doc -> do
- cons <- mapM renameConDecl cons
- doc <- renameMaybeDoc doc
+ HsDataDecl loc ctx t args cons0 drv doc0 -> do
+ cons <- mapM renameConDecl cons0
+ doc <- renameMaybeDoc doc0
return (HsDataDecl loc ctx t args cons drv doc)
- HsNewTypeDecl loc ctx t args con drv doc -> do
- con <- renameConDecl con
- doc <- renameMaybeDoc doc
+ HsNewTypeDecl loc ctx t args con0 drv doc0 -> do
+ con <- renameConDecl con0
+ doc <- renameMaybeDoc doc0
return (HsNewTypeDecl loc ctx t args con drv doc)
- HsClassDecl loc ctxt nm tvs fds decls doc -> do
- ctxt <- mapM renamePred ctxt
- decls <- mapM renameDecl decls
- doc <- renameMaybeDoc doc
+ HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do
+ ctxt <- mapM renamePred ctxt0
+ decls <- mapM renameDecl decls0
+ doc <- renameMaybeDoc doc0
return (HsClassDecl loc ctxt nm tvs fds decls doc)
- HsTypeSig loc fs qt doc -> do
- qt <- renameType qt
- doc <- renameMaybeDoc doc
+ HsTypeSig loc fs qt0 doc0 -> do
+ qt <- renameType qt0
+ doc <- renameMaybeDoc doc0
return (HsTypeSig loc fs qt doc)
- HsForeignImport loc cc safe ent n ty doc -> do
- ty <- renameType ty
- doc <- renameMaybeDoc doc
+ HsForeignImport loc cc safe ent n ty0 doc0 -> do
+ ty <- renameType ty0
+ doc <- renameMaybeDoc doc0
return (HsForeignImport loc cc safe ent n ty doc)
- HsInstDecl loc ctxt asst decls -> do
- ctxt <- mapM renamePred ctxt
- asst <- renamePred asst
+ HsInstDecl loc ctxt0 asst0 decls -> do
+ ctxt <- mapM renamePred ctxt0
+ asst <- renamePred asst0
return (HsInstDecl loc ctxt asst decls)
- HsDocCommentNamed loc name doc -> do
- doc <- renameDoc doc
+ HsDocCommentNamed loc name doc0 -> do
+ doc <- renameDoc doc0
return (HsDocCommentNamed loc name doc)
_ ->
return decl
-renameConDecl (HsConDecl loc nm tvs ctxt tys doc) = do
- tys <- mapM renameBangTy tys
- doc <- renameMaybeDoc doc
+renameConDecl :: HsConDecl -> RnM HsConDecl
+renameConDecl (HsConDecl loc nm tvs ctxt tys0 doc0) = do
+ tys <- mapM renameBangTy tys0
+ doc <- renameMaybeDoc doc0
return (HsConDecl loc nm tvs ctxt tys doc)
-renameConDecl (HsRecDecl loc nm tvs ctxt fields doc) = do
- fields <- mapM renameField fields
- doc <- renameMaybeDoc doc
+renameConDecl (HsRecDecl loc nm tvs ctxt fields0 doc0) = do
+ fields <- mapM renameField fields0
+ doc <- renameMaybeDoc doc0
return (HsRecDecl loc nm tvs ctxt fields doc)
-renameField (HsFieldDecl ns ty doc) = do
- ty <- renameBangTy ty
- doc <- renameMaybeDoc doc
+renameField :: HsFieldDecl -> RnM HsFieldDecl
+renameField (HsFieldDecl ns ty0 doc0) = do
+ ty <- renameBangTy ty0
+ doc <- renameMaybeDoc doc0
return (HsFieldDecl ns ty doc)
+renameBangTy :: HsBangType -> RnM HsBangType
renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty
renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
-renamePred (c,tys) = do
- tys <- mapM renameType tys
+renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType])
+renamePred (c,tys0) = do
+ tys <- mapM renameType tys0
lookupRn (\c' -> (c',tys)) c
-renameType (HsForAllType tvs ctx ty) = do
- ctx <- mapM renamePred ctx
- ty <- renameType ty
+renameType :: HsType -> RnM HsType
+renameType (HsForAllType tvs ctx0 ty0) = do
+ ctx <- mapM renamePred ctx0
+ ty <- renameType ty0
return (HsForAllType tvs ctx ty)
-renameType (HsTyFun arg res) = do
- arg <- renameType arg
- res <- renameType res
+renameType (HsTyFun arg0 res0) = do
+ arg <- renameType arg0
+ res <- renameType res0
return (HsTyFun arg res)
-renameType (HsTyTuple b tys) = do
- tys <- mapM renameType tys
+renameType (HsTyTuple b tys0) = do
+ tys <- mapM renameType tys0
return (HsTyTuple b tys)
-renameType (HsTyApp ty arg) = do
- ty <- renameType ty
- arg <- renameType arg
+renameType (HsTyApp ty0 arg0) = do
+ ty <- renameType ty0
+ arg <- renameType arg0
return (HsTyApp ty arg)
renameType (HsTyVar nm) =
return (HsTyVar nm)
renameType (HsTyCon nm) =
lookupRn HsTyCon nm
-renameType (HsTyDoc ty doc) = do
- ty <- renameType ty
- doc <- renameDoc doc
+renameType (HsTyDoc ty0 doc0) = do
+ ty <- renameType ty0
+ doc <- renameDoc doc0
return (HsTyDoc ty doc)
-- -----------------------------------------------------------------------------
@@ -181,8 +190,10 @@ markupRename = Markup {
markupURL = return . DocURL
}
+renameDoc :: Doc -> RnM Doc
renameDoc = markup markupRename
+renameMaybeDoc :: Maybe Doc -> RnM (Maybe Doc)
renameMaybeDoc Nothing = return Nothing
renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
@@ -206,21 +217,22 @@ lookupForDoc qns = do
-- string representation.
return (DocString (show (head qns)))
where
- isQualified (Qual m i) = True
+ isQualified (Qual _ _) = True
isQualified _ = False
-- -----------------------------------------------------------------------------
+renameExportItems :: [ExportItem] -> RnM [ExportItem]
renameExportItems items = mapM rn items
where
- rn (ExportModule mod)
- = return (ExportModule mod)
- rn (ExportGroup lev id doc)
- = do doc <- renameDoc doc
- return (ExportGroup lev id doc)
- rn (ExportDecl x decl) -- x is an original name, don't rename it
- = do decl <- renameDecl decl
+ rn (ExportModule mod0)
+ = return (ExportModule mod0)
+ rn (ExportGroup lev id0 doc0)
+ = do doc <- renameDoc doc0
+ return (ExportGroup lev id0 doc)
+ rn (ExportDecl x decl0) -- x is an original name, don't rename it
+ = do decl <- renameDecl decl0
return (ExportDecl x decl)
- rn (ExportDoc doc)
- = do doc <- renameDoc doc
+ rn (ExportDoc doc0)
+ = do doc <- renameDoc doc0
return (ExportDoc doc)
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 80800559..878abeb7 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -39,48 +39,53 @@ import Monad
-- -----------------------------------------------------------------------------
-- Some Utilities
+nameOfQName :: HsQName -> HsName
nameOfQName (Qual _ n) = n
nameOfQName (UnQual n) = n
collectNames :: [HsDecl] -> [HsName]
collectNames ds = concat (map declBinders ds)
+unbang :: HsBangType -> HsType
unbang (HsUnBangedTy ty) = ty
unbang (HsBangedTy ty) = ty
+declBinders :: HsDecl -> [HsName]
declBinders d = maybeToList (declMainBinder d) ++ declSubBinders d
declMainBinder :: HsDecl -> Maybe HsName
declMainBinder d =
case d of
HsTypeDecl _ n _ _ _ -> Just n
- HsDataDecl _ _ n _ cons _ _ -> Just n
+ HsDataDecl _ _ n _ _ _ _ -> Just n
HsNewTypeDecl _ _ n _ _ _ _ -> Just n
- HsClassDecl _ _ n _ _ decls _ -> Just n
+ HsClassDecl _ _ n _ _ _ _ -> Just n
HsTypeSig _ [n] _ _ -> Just n
- HsTypeSig _ ns _ _ -> error "declMainBinder"
+ HsTypeSig _ _ _ _ -> error "declMainBinder"
HsForeignImport _ _ _ _ n _ _ -> Just n
_ -> Nothing
declSubBinders :: HsDecl -> [HsName]
declSubBinders d =
case d of
- HsTypeDecl _ n _ _ _ -> []
- HsDataDecl _ _ n _ cons _ _ -> concat (map conDeclBinders cons)
- HsNewTypeDecl _ _ n _ con _ _ -> conDeclBinders con
- HsClassDecl _ _ n _ _ decls _ -> collectNames decls
- HsTypeSig _ ns _ _ -> []
- HsForeignImport _ _ _ _ n _ _ -> []
+ HsTypeDecl _ _ _ _ _ -> []
+ HsDataDecl _ _ _ _ cons _ _ -> concat (map conDeclBinders cons)
+ HsNewTypeDecl _ _ _ _ con _ _ -> conDeclBinders con
+ HsClassDecl _ _ _ _ _ decls _ -> collectNames decls
+ HsTypeSig _ _ _ _ -> []
+ HsForeignImport _ _ _ _ _ _ _ -> []
_ -> []
+conDeclBinders :: HsConDecl -> [HsName]
conDeclBinders (HsConDecl _ n _ _ _ _) = [n]
conDeclBinders (HsRecDecl _ n _ _ fields _) =
n : concat (map fieldDeclBinders fields)
+fieldDeclBinders :: HsFieldDecl -> [HsName]
fieldDeclBinders (HsFieldDecl ns _ _) = ns
splitTyConApp :: HsType -> (HsQName, [HsType])
-splitTyConApp t = split t []
+splitTyConApp t0 = split t0 []
where
split :: HsType -> [HsType] -> (HsQName,[HsType])
split (HsTyApp t u) ts = split t (u:ts)
@@ -93,25 +98,29 @@ freeTyCons ty = go ty []
go (HsTyApp t u) r = go t (go u r)
go (HsTyCon c) r = c : r
go (HsTyFun f a) r = go f (go a r)
- go (HsTyTuple b ts) r = foldr go r ts
- go (HsTyVar v) r = r
+ go (HsTyTuple _ ts) r = foldr go r ts
+ go (HsTyVar _) r = r
go (HsTyDoc t _) r = go t r
-- -----------------------------------------------------------------------------
-- Adding documentation to record fields (used in parsing).
+addFieldDoc :: HsFieldDecl -> Maybe Doc -> HsFieldDecl
addFieldDoc (HsFieldDecl ns ty doc1) doc2 =
HsFieldDecl ns ty (doc1 `mplus` doc2)
-addFieldDocs [] doc = []
+addFieldDocs :: [HsFieldDecl] -> Maybe Doc -> [HsFieldDecl]
+addFieldDocs [] _ = []
addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
+addConDoc :: HsConDecl -> Maybe Doc -> HsConDecl
addConDoc (HsConDecl pos nm tvs ctxt typeList doc1) doc2 =
HsConDecl pos nm tvs ctxt typeList (doc1 `mplus` doc2)
addConDoc (HsRecDecl pos nm tvs ctxt fields doc1) doc2=
HsRecDecl pos nm tvs ctxt fields (doc1 `mplus` doc2)
-addConDocs [] doc = []
+addConDocs :: [HsConDecl] -> Maybe Doc -> [HsConDecl]
+addConDocs [] _ = []
addConDocs (x:xs) doc = addConDoc x doc : xs
-- ---------------------------------------------------------------------------
@@ -141,6 +150,7 @@ restrictDecls names decls = filter keep decls
-- -----------------------------------------------------------------------------
-- Extract documentation from a declaration
+declDoc :: HsDecl -> Maybe Doc
declDoc (HsTypeDecl _ _ _ _ d) = d
declDoc (HsDataDecl _ _ _ _ _ _ d) = d
declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d
@@ -155,13 +165,14 @@ declDoc _ = Nothing
parseModuleHeader :: String -> (String, Maybe ModuleInfo)
parseModuleHeader str =
case matchRegexAll moduleHeaderRE str of
- Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) ->
+ Just (_, _, after, _, (_:_:_:s1:s2:s3:_)) ->
(after, Just (ModuleInfo {
portability = s3,
stability = s2,
maintainer = s1 }))
_other -> (str, Nothing)
+moduleHeaderRE :: Regex
moduleHeaderRE = mkRegexWithOpts
"^([ \t\n]*Module[ \t]*:.*\n)?\
\([ \t\n]*Copyright[ \t]*:.*\n)?\
@@ -208,11 +219,11 @@ splitFilename3 str
in (real_dir, name, ext)
split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
-split_longest_prefix s pred
- = case pre of
+split_longest_prefix s pred0
+ = case pre0 of
[] -> ([], reverse suf)
(_:pre) -> (reverse pre, reverse suf)
- where (suf,pre) = break pred (reverse s)
+ where (suf,pre0) = break pred0 (reverse s)
pathSeparator :: Char
#ifdef __WIN32__
@@ -230,8 +241,8 @@ isPathSeparator ch =
#endif
moduleHtmlFile :: FilePath -> String -> FilePath
-moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename?
-moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html"
+moduleHtmlFile "" mod0 = mod0 ++ ".html" -- ToDo: Z-encode filename?
+moduleHtmlFile dir mod0 = dir ++ pathSeparator : mod0 ++ ".html"
-----------------------------------------------------------------------------
-- misc.
@@ -242,11 +253,12 @@ die s = hPutStr stderr s >> exitWith (ExitFailure 1)
dieMsg :: String -> IO a
dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s)
-mapSnd f [] = []
+mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
+mapSnd _ [] = []
mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM f Nothing = return Nothing
+mapMaybeM _ Nothing = return Nothing
mapMaybeM f (Just a) = f a >>= return . Just
-----------------------------------------------------------------------------
diff --git a/src/HaddockVersion.hs b/src/HaddockVersion.hs
index 5048d899..6ff50976 100644
--- a/src/HaddockVersion.hs
+++ b/src/HaddockVersion.hs
@@ -8,9 +8,11 @@ module HaddockVersion (
projectName, projectVersion, projectUrl
) where
+projectName, projectUrl :: String
projectName = "Haddock"
projectUrl = "http://www.haskell.org/haddock"
-- The version comes in via CPP from mk/version.mk
+projectVersion :: String
projectVersion = tail "\
\ HADDOCK_VERSION"
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index dcf3ebbc..e2a9ce90 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.11 2002/05/17 10:51:57 simonmar Exp $
+-- $Id: HsLexer.lhs,v 1.12 2002/07/24 09:42:18 simonmar Exp $
--
-- (c) The GHC Team, 1997-2000
--
@@ -180,11 +180,13 @@ reserved_ids = [
( "stdcall", KW_StdCall )
]
+isIdent, isSymbol, isWhite :: Char -> Bool
isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_'
isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"
isWhite c = elem c " \n\r\t\v\f"
-tAB_LENGTH = 8 :: Int
+tAB_LENGTH :: Int
+tAB_LENGTH = 8
-- The source location, (y,x), is the coordinates of the previous token.
-- col is the current column in the source file. If col is 0, we are
@@ -197,23 +199,23 @@ tAB_LENGTH = 8 :: Int
lexer :: (Token -> P a) -> P a
-lexer cont input (SrcLoc _ x) y col =
+lexer cont input (SrcLoc _ x0) y0 col =
if col == 0
- then tab y x True input
- else tab y col False input -- throw away old x
+ then tab y0 x0 True input
+ else tab y0 col False input -- throw away old x
where
-- move past whitespace and comments
- tab y x bol [] =
+ tab y x _ [] =
cont EOF [] (SrcLoc y x) col y
tab y x bol ('\t':s) =
tab y (nextTab x) bol s
- tab y x bol ('\n':s) =
+ tab y _ _ ('\n':s) =
newLine cont s y
-- single-line comments
tab y x bol s@('-':'-':' ':c:_) | doc c =
is_a_token bol s y x
- tab y x bol ('-':'-':s) =
+ tab y _ _ ('-':'-':s) =
newLine cont (drop 1 (dropWhile (/= '\n') s)) y
-- multi-line nested comments
@@ -231,7 +233,7 @@ lexer cont input (SrcLoc _ x) y col =
| bol = lexBOL cont s (SrcLoc y x) y x
| otherwise = lexToken cont s (SrcLoc y x) y x
- newLine cont s y = tab (y+1) 1 True s
+ newLine _ s y = tab (y+1) 1 True s
doc '|' = True
doc '/' = True
@@ -241,6 +243,7 @@ lexer cont input (SrcLoc _ x) y col =
doc '#' = True
doc _ = False
+nextTab :: Int -> Int
nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)
-- When we are lexing the first token of a line, check whether we need to
@@ -275,10 +278,13 @@ lexBOL cont s loc y x context =
Layout n -> x == n
lexToken :: (Token -> P a) -> P a
-lexToken cont [] loc y x = error "Internal error: empty input in lexToken"
-lexToken cont s loc y x =
+--lexToken _ [] loc _ _ =
+-- error $ "Internal error: empty input in lexToken at " ++ show loc
+lexToken cont s0 loc y x =
-- trace ("lexer: y="++show y++" x="++show x++"\n") $
- case s of
+ case s0 of
+ [] -> error $ "Internal error: empty input in lexToken at "
+ ++ show loc
-- First the doc comments
'-':'-':' ':s -> do_doc s False
'{':'-':' ':s -> do_doc s True
@@ -294,11 +300,11 @@ lexToken cont s loc y x =
'[':s -> forward 1 LeftSquare s
']':s -> forward 1 RightSquare s
'`':s -> forward 1 BackQuote s
- '{':s -> \ctxt -> forward 1 LeftCurly s (NoLayout : ctxt)
- '}':s -> \ctxt -> case ctxt of
- (_:ctxt) -> forward 1 RightCurly s ctxt
+ '{':s -> \ctxt -> forward 1 LeftCurly s (NoLayout : ctxt)
+ '}':s -> \ctxt0 -> case ctxt0 of
+ (_:ctxt) -> forward 1 RightCurly s ctxt
-- pop context on '}'
- [] -> error "Internal error: empty context in lexToken"
+ [] -> error "Internal error: empty context in lexToken"
'\'':s -> lexChar cont s loc y (x+1)
'\"':s{-"-} -> lexString cont s loc y (x+1)
@@ -317,12 +323,12 @@ lexToken cont s loc y x =
c:s | isLower c || c == '_' ->
let
(idtail, rest) = slurpIdent s
- id = c:idtail
+ id0 = c:idtail
l_id = 1 + length idtail
in
- case lookup id reserved_ids of
+ case lookup id0 reserved_ids of
Just keyword -> forward l_id keyword rest
- Nothing -> forward l_id (VarId id) rest
+ Nothing -> forward l_id (VarId id0) rest
| isUpper c -> lexCon "" cont (c:s) loc y x
| isSymbol c ->
@@ -343,7 +349,7 @@ lexToken cont s loc y x =
parseError ("illegal character \'" ++ show c ++ "\'\n")
s loc y x
- where forward n t s = cont t s loc y (x+n)
+ where forward n t str = cont t str loc y (x+n)
-- this is all terribly ugly, sorry :(
do_doc ('|':s) nested = multi nested DocCommentNext cont s loc y x
@@ -352,24 +358,32 @@ lexToken cont s loc y x =
do_doc ('$':s) nested = multi nested DocCommentNamed cont s loc y x
do_doc ('#':s) nested = multi nested DocOptions cont s loc y x
do_doc ('*':s) nested = section 1 s
- where section n ('*':s) = section (n+1) s
- section n s
- | nested = nestedDocComment (DocSection n) cont s loc y x
- | otherwise = oneLineDocComment (DocSection n) cont s loc y x
- do_doc _ _ = error "Internal error: HsLexer.do_doc"
-
+ where section n ('*':s1) = section (n+1) s1
+ section n s1
+ | nested = nestedDocComment (DocSection n) cont s1 loc y x
+ | otherwise = oneLineDocComment (DocSection n) cont s1 loc y x
+ do_doc _ _ = error "Internal error: HsLexer.do_doc"
+
+
+multi :: Num a => Bool -> ([Char] -> b)
+ -> (b -> [Char] -> c -> a -> Int -> d)
+ -> [Char] -> c -> a -> Int -> d
multi True = nestedDocComment
multi False = multiLineDocComment
+afterNum :: Num a => (Token -> [Char] -> b -> c -> a -> d)
+ -> Integer -> [Char] -> b -> c -> a -> d
afterNum cont i ('#':s) loc y x = cont (PrimInt i) s loc y (x+1)
afterNum cont i s loc y x = cont (IntTok i) s loc y x
-lexNum cont c s loc y x =
- let (num, after_num) = span isDigit (c:s)
+lexNum :: (Token -> [Char] -> a -> b -> Int -> c)
+ -> Char -> [Char] -> a -> b -> Int -> c
+lexNum cont c0 s0 loc y x =
+ let (num, after_num) = span isDigit (c0:s0)
in
case after_num of
- '.':c:s | isDigit c ->
- let (frac,after_frac) = span isDigit s
+ '.':c1:s1 | isDigit c1 ->
+ let (frac,after_frac) = span isDigit s1
in
let float = num ++ '.':frac
(f, after_exp)
@@ -378,17 +392,17 @@ lexNum cont c s loc y x =
'e':s -> do_exponent s
_ -> (float, after_frac)
- do_exponent s =
- case s of
+ do_exponent s2 =
+ case s2 of
'-':c:s | isDigit c ->
- let (exp,rest) = span isDigit (c:s) in
- (float ++ 'e':'-':exp, rest)
+ let (exp0,rest) = span isDigit (c:s) in
+ (float ++ 'e':'-':exp0, rest)
'+':c:s | isDigit c ->
- let (exp,rest) = span isDigit (c:s) in
- (float ++ 'e':'+':exp, rest)
+ let (exp0,rest) = span isDigit (c:s) in
+ (float ++ 'e':'+':exp0, rest)
c:s | isDigit c ->
- let (exp,rest) = span isDigit (c:s) in
- (float ++ 'e':exp, rest)
+ let (exp0,rest) = span isDigit (c:s) in
+ (float ++ 'e':exp0, rest)
_ -> (float, after_frac)
x' = x + length f
@@ -402,6 +416,7 @@ lexNum cont c s loc y x =
-- GHC extension: allow trailing '#'s in an identifier.
+slurpIdent :: String -> (String, String)
slurpIdent s = slurp' s []
where
slurp' [] i = (reverse i, [])
@@ -410,16 +425,18 @@ slurpIdent s = slurp' s []
| c == '#' = slurphashes cs (c:i)
slurp' cs i = (reverse i, cs)
+slurphashes :: String -> String -> (String, String)
slurphashes [] i = (reverse i, [])
slurphashes ('#':cs) i = slurphashes cs ('#':i)
slurphashes s i = (reverse i, s)
-
-lexCon qual cont s loc y x =
+lexCon :: [Char] -> (Token -> String -> a -> b -> Int -> c)
+ -> String -> a -> b -> Int -> c
+lexCon qual cont s0 loc y x =
let
forward n t s = cont t s loc y (x+n)
- (con, rest) = slurpIdent s
+ (con, rest) = slurpIdent s0
l_con = length con
just_a_conid
@@ -434,13 +451,13 @@ lexCon qual cont s loc y x =
| isLower c1 -> -- qualified varid?
let
(idtail, rest1) = slurpIdent s1
- id = c1:idtail
+ id0 = c1:idtail
l_id = 1 + length idtail
in
- case lookup id reserved_ids of
+ case lookup id0 reserved_ids of
-- cannot qualify a reserved word
- Just keyword -> just_a_conid
- Nothing -> forward (l_con+1+l_id) (QVarId (qual',id)) rest1
+ Just _ -> just_a_conid
+ Nothing -> forward (l_con+1+l_id) (QVarId (qual', id0)) rest1
| isUpper c1 -> -- qualified conid?
lexCon qual' cont (c1:s1) loc y (x+l_con+1)
@@ -463,41 +480,41 @@ lexCon qual cont s loc y x =
lexChar :: (Token -> P a) -> P a
-lexChar cont s loc y x = case s of
- '\\':s -> (escapeChar s `thenP` \(e,s,i) _ _ _ _ ->
- charEnd e s loc y (x+i)) s loc y x
- c:s -> charEnd c s loc y (x+1)
- [] -> error "Internal error: lexChar"
+lexChar cont s0 loc0 y x = case s0 of
+ '\\':s1 -> (escapeChar s1 `thenP` \(e,s,i) _ _ _ _ ->
+ charEnd e s loc0 y (x+i)) s1 loc0 y x
+ c:s -> charEnd c s loc0 y (x+1)
+ [] -> error "Internal error: lexChar"
- where charEnd c ('\'':'#':s) = \loc y x -> cont (PrimChar c) s loc y (x+2)
- charEnd c ('\'':s) = \loc y x -> cont (Character c) s loc y (x+1)
- charEnd c s = parseError "Improperly terminated character constant" s
+ where charEnd c ('\'':'#':s) = \loc y0 x0 -> cont (PrimChar c) s loc y0 (x0+2)
+ charEnd c ('\'':s) = \loc y0 x0 -> cont (Character c) s loc y0 (x0+1)
+ charEnd _ s = parseError "Improperly terminated character constant" s
lexString :: (Token -> P a) -> P a
-lexString cont s loc y x = loop "" s x y
+lexString cont s0 loc y0 x0 = loop "" s0 x0 y0
where
- loop e s x y = case s of
+ loop e s1 x y = case s1 of
'\\':'&':s -> loop e s (x+2) y
'\\':c:s | isSpace c -> stringGap e s (x+2) y
- | otherwise -> (escapeChar (c:s) `thenP` \(e',s,i) _ _ _ _ ->
- loop (e':e) s (x+i) y) s loc y x
+ | otherwise -> (escapeChar (c:s) `thenP` \(e',s2,i) _ _ _ _ ->
+ loop (e':e) s2 (x+i) y) s loc y x
'\"':'#':s -> cont (PrimString (reverse e)) s loc y (x+2)
'\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1)
c:s -> loop (c:e) s (x+1) y
- [] -> parseError "Improperly terminated string" s loc y x
+ [] -> parseError "Improperly terminated string" s1 loc y x
- stringGap e s x y = case s of
+ stringGap e s1 x y = case s1 of
'\n':s -> stringGap e s 1 (y+1)
'\\':s -> loop e s (x+1) y
- c:s' | isSpace c -> stringGap e s' (x+1) y
- | otherwise ->
- parseError "Illegal character in string gap" s loc y x
+ c:s | isSpace c -> stringGap e s (x+1) y
+ | otherwise ->
+ parseError "Illegal character in string gap" s1 loc y x
[] -> error "Internal error: stringGap"
-- ToDo: \o, \x, \<octal> things.
escapeChar :: String -> P (Char,String,Int)
-escapeChar s = case s of
+escapeChar s0 = case s0 of
'x':c:s | isHexDigit c ->
let (num,rest) = span isHexDigit (c:s) in
@@ -525,7 +542,7 @@ escapeChar s = case s of
-- Production ascii from section B.2
- '^':x@(c:s) -> cntrl x
+ '^':x@(_:_) -> cntrl x
'N':'U':'L':s -> returnP ('\NUL',s,4)
'S':'O':'H':s -> returnP ('\SOH',s,4)
'S':'T':'X':s -> returnP ('\STX',s,4)
@@ -575,37 +592,49 @@ cntrl :: String -> P (Char,String,Int)
cntrl (c:s) | c >= '@' && c <= '_' = returnP (chr (ord c - ord '@'), s,2)
cntrl _ = parseError "Illegal control character"
-nestedComment cont y x bol s =
- case s of
+nestedComment :: Num a => (a -> Int -> Bool -> [Char] -> b)
+ -> a -> Int -> Bool -> [Char] -> b
+nestedComment cont y x bol s0 =
+ case s0 of
'-':'}':s -> cont y (x+2) bol s
'{':'-':s -> nestedComment (nestedComment cont) y (x+2) bol s
'\t':s -> nestedComment cont y (nextTab x) bol s
'\n':s -> nestedComment cont (y+1) 1 True s
- c:s -> nestedComment cont y (x+1) bol s
+ _:s -> nestedComment cont y (x+1) bol s
[] -> error "Internal error: nestedComment"
-
-nestedDocComment f cont s loc y x = go f cont "" y x s
+nestedDocComment :: Num a => ([Char] -> b)
+ -> (b -> [Char] -> c -> a -> Int -> d)
+ -> [Char] -> c -> a -> Int -> d
+nestedDocComment f0 cont0 s0 loc y0 x0 = go f0 cont0 "" y0 x0 s0
where
- go f cont acc y x s =
- case s of
- '-':'}':s -> cont (f (reverse acc)) s loc y (x+2)
- '{':'-':s -> nestedComment (\y x bol s -> go f cont acc y x s)
- y (x+2) False s
- '\t':s -> go f cont ('\t':acc) y (nextTab x) s
- '\n':s -> go f cont ('\n':acc) (y+1) 1 s
- c:s -> go f cont (c:acc) y (x+1) s
+ go f cont acc y1 x1 s1 =
+ case s1 of
+ '-':'}':s -> cont (f (reverse acc)) s loc y1 (x1+2)
+ '{':'-':s -> nestedComment (\y x _ s2 -> go f cont acc y x s2)
+ y1 (x1+2) False s
+ '\t':s -> go f cont ('\t':acc) y1 (nextTab x1) s
+ '\n':s -> go f cont ('\n':acc) (y1+1) 1 s
+ c:s -> go f cont (c:acc) y1 (x1+1) s
[] -> error "Internal error: nestedComment"
+oneLineDocComment :: ([Char] -> a)
+ -> (a -> [Char] -> b -> c -> d -> e)
+ -> [Char] -> b -> c -> d -> e
oneLineDocComment f cont s loc y x
= cont (f line) rest loc y x -- continue with the newline char
where (line, rest) = break (== '\n') s
+multiLineDocComment :: Num a => ([Char] -> b)
+ -> (b -> [Char] -> c -> a -> d -> e)
+ -> [Char] -> c -> a -> d -> e
multiLineDocComment f cont s loc y x
= cont (f comment) s' loc y' x -- continue with the newline char
where (s', comment, y') = slurpExtraCommentLines s [] y
-slurpExtraCommentLines s lines y
+slurpExtraCommentLines :: Num a => [Char] -> [[Char]] -> a
+ -> ([Char], [Char], a)
+slurpExtraCommentLines s0 lines0 y
= case rest of
'\n':nextline ->
case dropWhile nonNewlineSpace nextline of
@@ -614,12 +643,13 @@ slurpExtraCommentLines s lines y
-- want them in the doc.
'-':'-':c:s | c /= '-'
-> slurpExtraCommentLines (c:s)
- ((line++"\n"):lines) (y+1)
+ ((line++"\n"):lines0) (y+1)
_ -> (rest, finished, y)
- other -> (rest, finished, y)
+ _ -> (rest, finished, y)
where
- (line, rest) = break (== '\n') s
- finished = concat (reverse (line:lines))
+ (line, rest) = break (== '\n') s0
+ finished = concat (reverse (line:lines0))
+nonNewlineSpace :: Char -> Bool
nonNewlineSpace c = isSpace c && c /= '\n'
\end{code}
diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs
index af29dd80..748fbad1 100644
--- a/src/HsParseMonad.lhs
+++ b/src/HsParseMonad.lhs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: HsParseMonad.lhs,v 1.1 2002/04/04 16:23:43 simonmar Exp $
+-- $Id: HsParseMonad.lhs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
--
-- (c) The GHC Team 1997-2000
--
@@ -31,38 +31,40 @@ type P a
-> ParseResult a
thenP :: P a -> (a -> P b) -> P b
-m `thenP` k = \i l n c s ->
- case m i l n c s of
+m `thenP` k = \i l n c s0 ->
+ case m i l n c s0 of
Failed s -> Failed s
Ok s' a -> case k a of k' -> k' i l n c s'
+thenP_ :: P a -> P b -> P b
m `thenP_` k = m `thenP` \_ -> k
mapP :: (a -> P b) -> [a] -> P [b]
-mapP f [] = returnP []
+mapP _ [] = returnP []
mapP f (a:as) =
f a `thenP` \b ->
mapP f as `thenP` \bs ->
returnP (b:bs)
-returnP a = \i l n c s -> Ok s a
+returnP :: a -> P a
+returnP a = \_ _ _ _ s -> Ok s a
failP :: String -> P a
-failP err = \i l n c s -> Failed err
+failP err = \_ _ _ _ _ -> Failed err
getSrcLoc :: P SrcLoc
-getSrcLoc = \i l n c s -> Ok s l
+getSrcLoc = \_ l _ _ s -> Ok s l
getContext :: P [LexContext]
-getContext = \i l n c s -> Ok s s
+getContext = \_ _ _ _ s -> Ok s s
pushContext :: LexContext -> P ()
pushContext ctxt =
--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
- \i l n c s -> Ok (ctxt:s) ()
+ \_ _ _ _ s -> Ok (ctxt:s) ()
popContext :: P ()
-popContext = \i l n c stk ->
+popContext = \_ _ _ _ stk ->
case stk of
(_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $
Ok s ()
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index a287cb9d..de4a2562 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: HsParseUtils.lhs,v 1.4 2002/06/03 13:05:58 simonmar Exp $
+-- $Id: HsParseUtils.lhs,v 1.5 2002/07/24 09:42:18 simonmar Exp $
--
-- (c) The GHC Team 1997-2000
--
@@ -45,13 +45,13 @@ parseError s = \r (SrcLoc y x) ->
failP (show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x)
splitTyConApp :: HsType -> P (HsName,[HsType])
-splitTyConApp t = split t []
+splitTyConApp t0 = split t0 []
where
split :: HsType -> [HsType] -> P (HsName,[HsType])
split (HsTyApp t u) ts = split t (u:ts)
split (HsTyCon (UnQual t)) ts = returnP (t,ts)
-- to cope with data [] = [] | a:[a]
- split (HsTyCon (Qual m t)) ts = returnP (t,ts)
+ split (HsTyCon (Qual _ t)) ts = returnP (t,ts)
split _ _ = parseError "Illegal data/newtype declaration"
-----------------------------------------------------------------------------
@@ -100,7 +100,7 @@ checkClassHeader ty =
checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName]))
checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)
checkSimple _kw (HsTyCon (UnQual t)) xs = returnP (t,xs)
-checkSimple kw (HsTyCon (Qual m t)) xs
+checkSimple _ (HsTyCon (Qual m t)) xs
| m == prelude_mod = returnP (t,xs) -- for "special" declarations
checkSimple kw _ _ = failP ("Illegal " ++ kw ++ " declaration")
@@ -118,29 +118,29 @@ checkPatterns es = mapP checkPattern es
checkPat :: HsExp -> [HsPat] -> P HsPat
checkPat (HsCon c) args = returnP (HsPApp c args)
-checkPat (HsApp f x) args = checkPat x [] `thenP` \x -> checkPat f (x:args)
-checkPat e [] = case e of
- HsVar (UnQual x) -> returnP (HsPVar x)
- HsLit l -> returnP (HsPLit l)
- HsInfixApp l op r -> checkPat l [] `thenP` \l ->
- checkPat r [] `thenP` \r ->
- case op of
- HsCon c -> returnP (HsPInfixApp l c r)
- _ -> patFail
- HsTuple b es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (HsPTuple b ps)
- HsList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (HsPList ps)
- HsParen e -> checkPat e [] `thenP` (returnP . HsPParen)
- HsAsPat n e -> checkPat e [] `thenP` (returnP . HsPAsPat n)
- HsWildCard -> returnP HsPWildCard
- HsIrrPat e -> checkPat e [] `thenP` (returnP . HsPIrrPat)
- HsRecConstr c fs -> mapP checkPatField fs `thenP` \fs ->
- returnP (HsPRec c fs)
- HsNegApp (HsLit l) -> returnP (HsPNeg (HsPLit l))
- HsExpTypeSig l e ty -> checkPat e [] `thenP` \e ->
- returnP (HsPTypeSig e ty)
- _ -> patFail
+checkPat (HsApp f x0) args = checkPat x0 [] `thenP` \x -> checkPat f (x:args)
+checkPat e0 [] = case e0 of
+ HsVar (UnQual x) -> returnP (HsPVar x)
+ HsLit l -> returnP (HsPLit l)
+ HsInfixApp l0 op r0 -> checkPat l0 [] `thenP` \l ->
+ checkPat r0 [] `thenP` \r ->
+ case op of
+ HsCon c -> returnP (HsPInfixApp l c r)
+ _ -> patFail
+ HsTuple b es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (HsPTuple b ps)
+ HsList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (HsPList ps)
+ HsParen e -> checkPat e [] `thenP` (returnP . HsPParen)
+ HsAsPat n e -> checkPat e [] `thenP` (returnP . HsPAsPat n)
+ HsWildCard -> returnP HsPWildCard
+ HsIrrPat e -> checkPat e [] `thenP` (returnP . HsPIrrPat)
+ HsRecConstr c fs0 -> mapP checkPatField fs0 `thenP` \fs ->
+ returnP (HsPRec c fs)
+ HsNegApp (HsLit l) -> returnP (HsPNeg (HsPLit l))
+ HsExpTypeSig _ e1 ty -> checkPat e1 [] `thenP` \e ->
+ returnP (HsPTypeSig e ty)
+ _ -> patFail
checkPat _ _ = patFail
@@ -148,24 +148,25 @@ checkPatField :: HsFieldUpdate -> P HsPatField
checkPatField (HsFieldUpdate n e) =
checkPat e [] `thenP` \p ->returnP (HsPFieldPat n p)
+patFail :: P a
patFail = parseError "Parse error in pattern"
-----------------------------------------------------------------------------
-- Check Expression Syntax
checkExpr :: HsExp -> P HsExp
-checkExpr e = case e of
- HsVar _ -> returnP e
- HsCon _ -> returnP e
- HsLit _ -> returnP e
+checkExpr e0 = case e0 of
+ HsVar _ -> returnP e0
+ HsCon _ -> returnP e0
+ HsLit _ -> returnP e0
HsInfixApp e1 e2 e3 -> check3Exprs e1 e2 e3 HsInfixApp
HsApp e1 e2 -> check2Exprs e1 e2 HsApp
HsNegApp e -> check1Expr e HsNegApp
HsLambda ps e -> check1Expr e (HsLambda ps)
HsLet bs e -> check1Expr e (HsLet bs)
HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
- HsCase e alts -> mapP checkAlt alts `thenP` \alts ->
- checkExpr e `thenP` \e ->
+ HsCase e1 alts0 -> mapP checkAlt alts0 `thenP` \alts ->
+ checkExpr e1 `thenP` \e ->
returnP (HsCase e alts)
HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
HsTuple b es -> checkManyExprs es (HsTuple b)
@@ -173,19 +174,19 @@ checkExpr e = case e of
HsParen e -> check1Expr e HsParen
HsLeftSection e1 e2 -> check2Exprs e1 e2 HsLeftSection
HsRightSection e1 e2 -> check2Exprs e1 e2 HsRightSection
- HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
+ HsRecConstr c fields0 -> mapP checkField fields0 `thenP` \fields ->
returnP (HsRecConstr c fields)
- HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
- checkExpr e `thenP` \e ->
+ HsRecUpdate e1 fields0 -> mapP checkField fields0 `thenP` \fields ->
+ checkExpr e1 `thenP` \e ->
returnP (HsRecUpdate e fields)
HsEnumFrom e -> check1Expr e HsEnumFrom
HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
- HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
- checkExpr e `thenP` \e ->
+ HsListComp e1 stmts0 -> mapP checkStmt stmts0 `thenP` \stmts ->
+ checkExpr e1 `thenP` \e ->
returnP (HsListComp e stmts)
- HsExpTypeSig loc e ty -> checkExpr e `thenP` \e ->
+ HsExpTypeSig loc e1 ty -> checkExpr e1 `thenP` \e ->
returnP (HsExpTypeSig loc e ty)
_ -> parseError "parse error in expression"
@@ -195,52 +196,59 @@ check1Expr e f = checkExpr e `thenP` (returnP . f)
check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
check2Exprs e1 e2 f =
- checkExpr e1 `thenP` \e1 ->
- checkExpr e2 `thenP` \e2 ->
- returnP (f e1 e2)
+ checkExpr e1 `thenP` \e1' ->
+ checkExpr e2 `thenP` \e2' ->
+ returnP (f e1' e2')
check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
check3Exprs e1 e2 e3 f =
- checkExpr e1 `thenP` \e1 ->
- checkExpr e2 `thenP` \e2 ->
- checkExpr e3 `thenP` \e3 ->
- returnP (f e1 e2 e3)
-
-checkManyExprs es f =
- mapP checkExpr es `thenP` \es ->
+ checkExpr e1 `thenP` \e1' ->
+ checkExpr e2 `thenP` \e2' ->
+ checkExpr e3 `thenP` \e3' ->
+ returnP (f e1' e2' e3')
+
+checkManyExprs :: [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
+checkManyExprs es0 f =
+ mapP checkExpr es0 `thenP` \es ->
returnP (f es)
-checkAlt (HsAlt loc p galts bs)
- = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
+checkAlt :: HsAlt -> P HsAlt
+checkAlt (HsAlt loc p galts0 bs)
+ = checkGAlts galts0 `thenP` \galts -> returnP (HsAlt loc p galts bs)
+checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
checkGAlts (HsGuardedAlts galts)
= mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
-checkGAlt (HsGuardedAlt loc stmts e) =
- mapP checkStmt stmts `thenP` \stmts ->
- checkExpr e `thenP` \e ->
+checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
+checkGAlt (HsGuardedAlt loc stmts0 e0) =
+ mapP checkStmt stmts0 `thenP` \stmts ->
+ checkExpr e0 `thenP` \e ->
returnP (HsGuardedAlt loc stmts e)
+checkStmt :: HsStmt -> P HsStmt
checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
checkStmt (HsQualifier e) = check1Expr e HsQualifier
-checkStmt s@(HsLetStmt bs) = returnP s
+checkStmt s@(HsLetStmt _) = returnP s
+checkField :: HsFieldUpdate -> P HsFieldUpdate
checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
-----------------------------------------------------------------------------
-- Check Equation Syntax
checkValDef :: (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-checkValDef (srcloc, lhs, rhs, whereBinds) =
- case isFunLhs lhs [] of
+checkValDef (srcloc, lhs0, rhs, whereBinds) =
+ case isFunLhs lhs0 [] of
Just (f,es) -> checkPatterns es `thenP` \ps ->
returnP (HsFunBind [HsMatch srcloc f ps rhs whereBinds])
- Nothing -> checkPattern lhs `thenP` \lhs ->
+ Nothing -> checkPattern lhs0 `thenP` \lhs ->
returnP (HsPatBind srcloc lhs rhs whereBinds)
-- A variable binding is parsed as an HsPatBind.
+isFunLhs :: HsExp -> [HsExp] -> Maybe (HsQName, [HsExp])
isFunLhs (HsInfixApp l (HsVar op) r) es = Just (op, l:r:es)
isFunLhs (HsApp (HsVar f) e) es = Just (f,e:es)
isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)
@@ -278,8 +286,10 @@ readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds
readInteger ds = readInteger2 10 isDigit ds
readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer
-readInteger2 radix isDig ds
- = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)
+readInteger2 radix isDig ds
+ | and $ map isDig ds
+ = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)
+ | otherwise = error $ "readInteger2:expected all digits, got " ++ show ds
-- Hack...
@@ -290,7 +300,7 @@ readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0; ('+':e2) ->
e = dropWhile (=='e') r2
mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
-mkRecConstrOrUpdate (HsCon c) fs = returnP (HsRecConstr c fs)
-mkRecConstrOrUpdate exp fs@(_:_) = returnP (HsRecUpdate exp fs)
-mkRecConstrOrUpdate _ _ = parseError "Empty record update"
+mkRecConstrOrUpdate (HsCon c) fs = returnP (HsRecConstr c fs)
+mkRecConstrOrUpdate exp0 fs@(_:_) = returnP (HsRecUpdate exp0 fs)
+mkRecConstrOrUpdate _ _ = parseError "Empty record update"
\end{code}
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 0801983a..77a621df 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.12 2002/07/19 09:59:02 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.13 2002/07/24 09:42:18 simonmar Exp $
%
% (c) The GHC Team, 1997-2002
%
@@ -44,7 +44,7 @@ newtype Module = Module String
deriving (Eq,Ord)
instance Show Module where
- showsPrec p (Module m) = showString m
+ showsPrec _ (Module m) = showString m
data HsQName
= Qual Module HsName
@@ -299,29 +299,41 @@ data HsGuardedAlt
-- Smart constructors
-- pinched from GHC
+mkHsForAllType :: Maybe [HsName] -> [HsAsst] -> HsType -> HsType
mkHsForAllType (Just []) [] ty = ty -- Explicit for-all with no tyvars
mkHsForAllType mtvs1 [] (HsForAllType mtvs2 ctxt ty)
= mkHsForAllType (mtvs1 `plus` mtvs2) ctxt ty
where
- mtvs1 `plus` Nothing = mtvs1
- Nothing `plus` mtvs2 = mtvs2
+ mtvs `plus` Nothing = mtvs
+ Nothing `plus` mtvs = mtvs
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllType tvs ctxt ty = HsForAllType tvs ctxt ty
-----------------------------------------------------------------------------
-- Builtin names.
+prelude_mod, main_mod :: Module
prelude_mod = Module "Prelude"
main_mod = Module "Main"
+unit_ident, nil_ident :: HsIdentifier
unit_ident = HsSpecial "()"
-tuple_ident i = HsSpecial ("("++replicate i ','++")")
nil_ident = HsSpecial "[]"
+tuple_ident :: Int -> HsIdentifier
+tuple_ident i = HsSpecial ("("++replicate i ','++")")
+
+unit_con_name, nil_con_name :: HsQName
unit_con_name = Qual prelude_mod (HsVarName unit_ident)
-tuple_con_name i = Qual prelude_mod (HsVarName (tuple_ident i))
nil_con_name = Qual prelude_mod (HsVarName nil_ident)
+tuple_con_name :: Int -> HsQName
+tuple_con_name i = Qual prelude_mod (HsVarName (tuple_ident i))
+
+as_name, qualified_name, hiding_name, unsafe_name, safe_name
+ , forall_name, threadsafe_name, export_name, ccall_name, stdcall_name
+ , dotnet_name, minus_name, pling_name, dot_name :: HsName
+
as_name = HsVarName (HsIdent "as")
qualified_name = HsVarName (HsIdent "qualified")
hiding_name = HsVarName (HsIdent "hiding")
@@ -337,19 +349,31 @@ minus_name = HsVarName (HsSymbol "-")
pling_name = HsVarName (HsSymbol "!")
dot_name = HsVarName (HsSymbol ".")
+unit_tycon_name, fun_tycon_name, list_tycon_name :: HsName
+
unit_tycon_name = HsTyClsName unit_ident
fun_tycon_name = HsTyClsName (HsSpecial "->")
list_tycon_name = HsTyClsName (HsSpecial "[]")
+
+tuple_tycon_name :: Int -> HsName
tuple_tycon_name i = HsTyClsName (tuple_ident i)
+unit_tycon_qname, fun_tycon_qname, list_tycon_qname :: HsQName
+
unit_tycon_qname = Qual prelude_mod unit_tycon_name
fun_tycon_qname = Qual prelude_mod fun_tycon_name
list_tycon_qname = Qual prelude_mod list_tycon_name
+
+tuple_tycon_qname :: Int -> HsQName
tuple_tycon_qname i = Qual prelude_mod (tuple_tycon_name i)
+unit_tycon, fun_tycon, list_tycon :: HsType
+
unit_tycon = HsTyCon unit_tycon_qname
fun_tycon = HsTyCon fun_tycon_qname
list_tycon = HsTyCon list_tycon_qname
+
+tuple_tycon :: Int -> HsType
tuple_tycon i = HsTyCon (tuple_tycon_qname i)
-- -----------------------------------------------------------------------------
@@ -397,7 +421,7 @@ markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s) = markupString m s
markup m (DocParagraph d) = markupParagraph m (markup m d)
markup m (DocIdentifier i) = markupIdentifier m i
-markup m (DocModule mod) = markupModule m mod
+markup m (DocModule mod0) = markupModule m mod0
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
@@ -408,6 +432,7 @@ markup m (DocURL url) = markupURL m url
-- | Since marking up is just a matter of mapping 'Doc' into some
-- other type, we can \'rename\' documentation by marking up 'Doc' into
-- the same thing, modifying only the identifiers embedded in it.
+mapIdent :: (a -> GenDoc b) -> DocMarkup a (GenDoc b)
mapIdent f = Markup {
markupEmpty = DocEmpty,
markupString = DocString,
@@ -427,6 +452,7 @@ mapIdent f = Markup {
-- ** Smart constructors
-- used to make parsing easier; we group the list items later
+docAppend :: Doc -> Doc -> Doc
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
= DocUnorderedList (ds1++ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
@@ -442,6 +468,7 @@ docAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph :: Doc -> Doc
docParagraph (DocMonospaced p)
= DocCodeBlock p
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
diff --git a/src/Html.hs b/src/Html.hs
index 9f2f7439..04294b81 100644
--- a/src/Html.hs
+++ b/src/Html.hs
@@ -9,7 +9,7 @@
-- Stability : experimental
-- Portability : portable
--
--- $Id: Html.hs,v 1.1 2002/04/08 16:41:38 simonmar Exp $
+-- $Id: Html.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
--
-- An Html combinator library
--
@@ -74,7 +74,7 @@ instance HTML Char where
toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
instance (HTML a) => HTML [a] where
- toHtml xs = toHtmlFromList xs
+ toHtml xs = toHtmlFromList xs
class ADDATTRS a where
(!) :: a -> [HtmlAttr] -> a
@@ -85,9 +85,15 @@ instance (ADDATTRS b) => ADDATTRS (a -> b) where
instance ADDATTRS Html where
(Html htmls) ! attr = Html (map addAttrs htmls)
where
- addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
- = html { markupAttrs = markupAttrs ++ attr }
- addAttrs html = html
+ addAttrs html =
+ case html of
+ HtmlTag { markupAttrs = markupAttrs0
+ , markupTag = markupTag0
+ , markupContent = markupContent0 } ->
+ HtmlTag { markupAttrs = markupAttrs0 ++ attr
+ , markupTag = markupTag0
+ , markupContent = markupContent0 }
+ _ -> html
(<<) :: (HTML a) => (Html -> b) -> a -> b
@@ -104,15 +110,16 @@ noHtml :: Html
noHtml = Html []
+isNoHtml :: Html -> Bool
isNoHtml (Html xs) = null xs
tag :: String -> Html -> Html
-tag str htmls = Html [
- HtmlTag {
- markupTag = str,
- markupAttrs = [],
- markupContent = htmls }]
+tag str htmls =
+ Html [ HtmlTag { markupTag = str,
+ markupAttrs = [],
+ markupContent = htmls }
+ ]
itag :: String -> Html
itag str = tag str noHtml
@@ -694,9 +701,10 @@ p = paragraph
-- ---------------------------------------------------------------------------
-- Html tables
+cell :: Html -> HtmlTable
cell h = let
cellFn x y = h ! (add x colspan $ add y rowspan $ [])
- add 1 fn rest = rest
+ add 1 _ rest = rest
add n fn rest = fn n : rest
r = BT.single cellFn
in
@@ -720,22 +728,30 @@ td = cell . thetd
tda :: [HtmlAttr] -> Html -> HtmlTable
tda as = cell . (thetd ! as)
+above, beside :: HtmlTable -> HtmlTable -> HtmlTable
above a b = combine BT.above a b
beside a b = combine BT.beside a b
infixr 3 </> -- combining table cells
infixr 4 <-> -- combining table cells
+(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable
(</>) = above
(<->) = beside
+emptyTable :: HtmlTable
emptyTable = HtmlTable BT.empty
+aboves, besides :: [HtmlTable] -> HtmlTable
aboves = foldr above emptyTable
besides = foldr beside emptyTable
mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable r = HtmlTable r
+combine :: (BT.BlockTable (Int -> Int -> Html)
+ -> BT.BlockTable (Int -> Int -> Html)
+ -> BT.BlockTable (Int -> Int -> Html))
+ -> HtmlTable -> HtmlTable -> HtmlTable
combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
-- renderTable takes the HtmlTable, and renders it back into
@@ -767,6 +783,7 @@ instance Show HtmlTable where
-- gets padded. If you want more power, then
-- use the system above, or build tables explicitly.
+simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html
simpleTable attr cellAttr lst
= table ! attr
<< (aboves
@@ -797,7 +814,7 @@ treeHtml colors h = table ! [
treeHtmls c ts = aboves (zipWith treeHtml' c ts)
treeHtml' :: [String] -> HtmlTree -> HtmlTable
- treeHtml' (c:_) (HtmlLeaf leaf) = cell
+ treeHtml' (_:_) (HtmlLeaf leaf) = cell
(thetd ! [width "100%"]
<< bold
<< leaf)
@@ -825,6 +842,7 @@ instance HTML HtmlTree where
toHtml x = treeHtml treeColors x
-- type "length treeColors" to see how many colors are here.
+treeColors :: [String]
treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
@@ -851,19 +869,19 @@ debugHtml obj = table ! [border 0] << (
debug (HtmlString str) = HtmlLeaf (spaceHtml +++
linesToHtml (lines str))
debug (HtmlTag {
- markupTag = markupTag,
- markupContent = markupContent,
- markupAttrs = markupAttrs
+ markupTag = markupTag0,
+ markupContent = markupContent0,
+ markupAttrs = markupAttrs0
}) =
- case markupContent of
+ case markupContent0 of
Html [] -> HtmlNode hd [] noHtml
Html xs -> HtmlNode hd (map debug xs) tl
where
- args = if null markupAttrs
+ args = if null markupAttrs0
then ""
- else " " ++ unwords (map show markupAttrs)
- hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
- tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
+ else " " ++ unwords (map show markupAttrs0)
+ hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">")
+ tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">")
-- ---------------------------------------------------------------------------
-- Hotlink datatype
@@ -902,7 +920,7 @@ defList items
widget :: String -> String -> [HtmlAttr] -> Html
-widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
+widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0)
checkbox :: String -> String -> Html
hidden :: String -> String -> Html
@@ -944,6 +962,7 @@ renderHtml theHtml =
foldr (.) id (map (renderHtml' 0)
(getHtmlElements (tag "HTML" << theHtml))) "\n"
+renderMessage :: String
renderMessage =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++
"<!--Rendered using the Haskell Html Library v0.2-->\n"
@@ -964,38 +983,40 @@ prettyHtml theHtml =
renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' _ (HtmlString str) = (++) str
renderHtml' n (HtmlTag
- { markupTag = name,
+ { markupTag = name0,
markupContent = html,
- markupAttrs = markupAttrs })
- = if isNoHtml html && elem name validHtmlITags
- then renderTag True name markupAttrs n
- else (renderTag True name markupAttrs n
+ markupAttrs = markupAttrs0 })
+ = if isNoHtml html && elem name0 validHtmlITags
+ then renderTag True name0 markupAttrs0 n
+ else (renderTag True name0 markupAttrs0 n
. foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
- . renderTag False name [] n)
+ . renderTag False name0 [] n)
prettyHtml' :: HtmlElement -> [String]
prettyHtml' (HtmlString str) = [str]
prettyHtml' (HtmlTag
- { markupTag = name,
+ { markupTag = name0,
markupContent = html,
- markupAttrs = markupAttrs })
- = if isNoHtml html && elem name validHtmlITags
+ markupAttrs = markupAttrs0 })
+ = if isNoHtml html && elem name0 validHtmlITags
then
- [rmNL (renderTag True name markupAttrs 0 "")]
+ [rmNL (renderTag True name0 markupAttrs0 0 "")]
else
- [rmNL (renderTag True name markupAttrs 0 "")] ++
+ [rmNL (renderTag True name0 markupAttrs0 0 "")] ++
shift (concat (map prettyHtml' (getHtmlElements html))) ++
- [rmNL (renderTag False name [] 0 "")]
+ [rmNL (renderTag False name0 [] 0 "")]
where
shift = map (\x -> " " ++ x)
+
+rmNL :: [Char] -> [Char]
rmNL = filter (/= '\n')
-- This prints the Tags The lack of spaces in intentunal, because Html is
-- actually space dependant.
renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
-renderTag x name markupAttrs n r
- = open ++ name ++ rest markupAttrs ++ ">" ++ r
+renderTag x name0 markupAttrs0 n r
+ = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r
where
open = if x then "<" else "</"
@@ -1006,6 +1027,6 @@ renderTag x name markupAttrs n r
rest attr = " " ++ unwords (map showPair attr) ++ nl
showPair :: HtmlAttr -> String
- showPair (HtmlAttr tag val)
- = tag ++ " = \"" ++ val ++ "\""
+ showPair (HtmlAttr tag0 val)
+ = tag0 ++ " = \"" ++ val ++ "\""
diff --git a/src/Main.hs b/src/Main.hs
index 94a53b7d..4de10e3e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -45,14 +45,15 @@ import PackedString
-----------------------------------------------------------------------------
-- Top-level stuff
-
+main :: IO ()
main = do
- args <- getArgs
- case getOpt Permute options args of
+ cmdline <- getArgs
+ case getOpt Permute options cmdline of
(flags, args, [] ) -> run flags args
(_, _, errors) -> do sequence_ (map putStr errors)
putStr usage
+usage :: String
usage = usageInfo "usage: haddock [OPTION] file...\n" options
data Flag
@@ -72,6 +73,7 @@ data Flag
| Flag_Verbose
deriving (Eq)
+options :: [OptDescr Flag]
options =
[
Option ['d'] ["docbook"] (NoArg Flag_DocBook)
@@ -107,14 +109,15 @@ options =
saved_flags :: IORef [Flag]
saved_flags = unsafePerformIO (newIORef (error "no flags yet"))
+run :: [Flag] -> [FilePath] -> IO ()
run flags files = do
let title = case [str | Flag_Heading str <- flags] of
[] -> ""
- (t:ts) -> t
+ (t:_) -> t
source_url = case [str | Flag_SourceURL str <- flags] of
[] -> Nothing
- (t:ts) -> Just t
+ (t:_) -> Just t
when (Flag_Verbose `elem` flags) $
hPutStrLn stderr
@@ -161,19 +164,19 @@ run flags files = do
-- modules to interfaces.
let
loop ifaces [] = return ifaces
- loop ifaces ((hsmod,file):mods) = do
- let ((mod,iface),msgs) = runWriter $
+ loop ifaces ((hsmod,file):mdls) = do
+ let ((mdl,iface),msgs) = runWriter $
mkInterface no_implicit_prelude ifaces file hsmod
- new_ifaces = addToFM ifaces mod iface
+ new_ifaces = addToFM ifaces mdl iface
mapM (hPutStrLn stderr) msgs
- loop new_ifaces mods
+ loop new_ifaces mdls
module_map <- loop (listToFM read_ifaces) sorted_mod_files
let mod_ifaces = fmToList module_map
- these_mod_ifaces = [ (mod, iface)
- | (mod, iface) <- mod_ifaces,
- mod `notElem` external_mods ]
+ these_mod_ifaces = [ (mdl, iface)
+ | (mdl, iface) <- mod_ifaces,
+ mdl `notElem` external_mods ]
-- when (Flag_DocBook `elem` flags) $
-- putStr (ppDocBook odir mod_ifaces)
@@ -181,9 +184,9 @@ run flags files = do
let inst_maps = collectInstances these_mod_ifaces
when (Flag_Debug `elem` flags) $ do
- mapM_ putStrLn (map show [ (mod, fmToList (iface_env i),
+ mapM_ putStrLn (map show [ (mdl, fmToList (iface_env i),
fmToList (iface_sub i))
- | (mod, i) <- these_mod_ifaces ])
+ | (mdl, i) <- these_mod_ifaces ])
when (Flag_Html `elem` flags) $
ppHtml title source_url these_mod_ifaces odir css_file
@@ -198,13 +201,13 @@ run flags files = do
writeBinMem bh fn
where
prepared_ifaces =
- [ (mod, fmToList (iface_env iface), fmToList (iface_sub iface))
- | (mod, iface) <- these_mod_ifaces ]
+ [ (mdl, fmToList (iface_env iface), fmToList (iface_sub iface))
+ | (mdl, iface) <- these_mod_ifaces ]
parseIfaceOption :: String -> (FilePath,FilePath)
parseIfaceOption s =
case break (==',') s of
- (path,',':file) -> (path,file)
+ (fpath,',':file) -> (fpath,file)
(_, file) -> ("", file)
readIface :: FilePath -> IO [(Module,Interface)]
@@ -213,8 +216,8 @@ readIface filename = do
stuff <- get bh
return (map to_interface stuff)
where
- to_interface (mod, env, sub) =
- (mod, Interface {
+ to_interface (mdl, env, sub) =
+ (mdl, Interface {
iface_filename = "",
iface_env = listToFM env,
iface_sub = listToFM sub,
@@ -233,19 +236,19 @@ updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO ()
updateHTMLXRefs paths ifaces_s =
writeIORef html_xrefs_ref (listToFM mapping)
where
- mapping = [ (mod,path)
- | (path, ifaces) <- zip paths ifaces_s,
- (mod, _iface) <- ifaces
+ mapping = [ (mdl,fpath)
+ | (fpath, ifaces) <- zip paths ifaces_s,
+ (mdl, _iface) <- ifaces
]
-
+parse_file :: FilePath -> IO HsModule
parse_file file = do
bracket
(openFile file ReadMode)
(\h -> hClose h)
(\h -> do stuff <- hGetContents h
case parse stuff (SrcLoc 1 1) 1 0 [] of
- Ok state e -> return e
+ Ok _ e -> return e
Failed err -> do hPutStrLn stderr (file ++ ':':err)
exitWith (ExitFailure 1)
)
@@ -273,10 +276,10 @@ mkInterface
)
mkInterface no_implicit_prelude mod_map filename
- (HsModule mod exps imps decls maybe_opts maybe_info maybe_doc) = do
+ (HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do
-- Process the options, if available
- options <- case maybe_opts of
+ opts <- case maybe_opts of
Just opt_str -> processOptions opt_str
Nothing -> return []
@@ -293,7 +296,7 @@ mkInterface no_implicit_prelude mod_map filename
-- now find the defined names
locally_defined_names = collectNames annotated_decls
- qual_local_names = map (Qual mod) locally_defined_names
+ qual_local_names = map (Qual mdl) locally_defined_names
unqual_local_names = map UnQual locally_defined_names
local_orig_env = listToFM (zip unqual_local_names qual_local_names ++
@@ -305,7 +308,7 @@ mkInterface no_implicit_prelude mod_map filename
| otherwise = HsImportDecl loc prelude_mod False Nothing Nothing : imps
where
loc = SrcLoc 0 0
- is_prel_import (HsImportDecl _ mod _ _ _ ) = mod == prelude_mod
+ is_prel_import (HsImportDecl _ mdl0 _ _ _ ) = mdl0 == prelude_mod
-- build the orig_env, which maps names to *original* names (so we can
-- find the original declarations & docs for things).
@@ -320,14 +323,14 @@ mkInterface no_implicit_prelude mod_map filename
-- gather up a list of entities that are exported (original names)
(exported_names, exported_visible_names)
- = exportedNames mod mod_map
+ = exportedNames mdl mod_map
locally_defined_names orig_env sub_map
- orig_exports options
+ orig_exports opts
-- build the import env, which maps original names to import names
local_import_env = listToFM (zip qual_local_names qual_local_names)
import_env = local_import_env `plusFM`
- buildImportEnv mod_map mod exported_visible_names
+ buildImportEnv mod_map mdl exported_visible_names
implicit_imps
-- trace (show (fmToList orig_env)) $ do
@@ -341,14 +344,14 @@ mkInterface no_implicit_prelude mod_map filename
instances = [ d | d@HsInstDecl{} <- final_decls ]
-- make the "export items", which will be converted into docs later
- orig_export_list <- mkExportItems mod_map mod orig_env decl_map sub_map
- final_decls options orig_exports
+ orig_export_list <- mkExportItems mod_map mdl orig_env decl_map sub_map
+ final_decls opts orig_exports
let
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
pruned_export_list
- | OptPrune `elem` options = pruneExportItems orig_export_list
+ | OptPrune `elem` opts = pruneExportItems orig_export_list
| otherwise = orig_export_list
-- rename names in the exported declarations to point to things that
@@ -372,12 +375,12 @@ mkInterface no_implicit_prelude mod_map filename
name_strings = nub (map show missing_names)
when (not (null name_strings)) $
- tell ["Warning: " ++ show mod ++
+ tell ["Warning: " ++ show mdl ++
": the following names could not be resolved:\n\
\ " ++ concat (map (' ':) name_strings)
]
- return (mod, Interface {
+ return (mdl, Interface {
iface_filename = filename,
iface_env = name_env,
iface_exports = renamed_export_list,
@@ -387,7 +390,7 @@ mkInterface no_implicit_prelude mod_map filename
iface_decls = decl_map,
iface_info = maybe_info,
iface_doc = final_module_doc,
- iface_options = options
+ iface_options = opts
}
)
@@ -408,10 +411,10 @@ mkExportItems
-> ErrMsgM [ExportItem]
mkExportItems mod_map this_mod orig_env decl_map sub_map decls
- options maybe_exps
- | Nothing <- maybe_exps = everything_local_exported
- | OptIgnoreExports `elem` options = everything_local_exported
- | Just specs <- maybe_exps = do
+ opts maybe_exps
+ | Nothing <- maybe_exps = everything_local_exported
+ | OptIgnoreExports `elem` opts = everything_local_exported
+ | Just specs <- maybe_exps = do
exps <- mapM lookupExport specs
return (concat exps)
where
@@ -434,10 +437,10 @@ mkExportItems mod_map this_mod orig_env decl_map sub_map decls
in_scope = eltsFM orig_env
declWith :: HsQName -> Maybe [HsQName] -> ErrMsgM [ ExportItem ]
- declWith (UnQual x) mb_subs = return []
- declWith t@(Qual mod x) mb_subs
+ declWith (UnQual _) _ = return []
+ declWith t@(Qual mdl x) mb_subs
| Just decl <- findDecl t
- = return [ ExportDecl t (restrictTo subs (extractDecl x mod decl)) ]
+ = return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) ]
| otherwise
= return []
where
@@ -449,9 +452,9 @@ mkExportItems mod_map this_mod orig_env decl_map sub_map decls
in_scope_subs = map nameOfQName in_scope_subs_qnames
in_scope_subs_qnames = filter (`elem` in_scope) all_subs_qnames
- all_subs_qnames = map (Qual mod) all_subs
+ all_subs_qnames = map (Qual mdl) all_subs
- all_subs | mod == this_mod = lookupWithDefaultFM sub_map [] x
+ all_subs | mdl == this_mod = lookupWithDefaultFM sub_map [] x
| otherwise = all_subs_of_qname mod_map t
fullContentsOf m
@@ -466,7 +469,7 @@ mkExportItems mod_map this_mod orig_env decl_map sub_map decls
return []
findDecl :: HsQName -> Maybe HsDecl
- findDecl (UnQual n)
+ findDecl (UnQual _)
= Nothing -- must be a name we couldn't resolve
findDecl (Qual m n)
| m == this_mod = lookupFM decl_map n
@@ -475,12 +478,14 @@ mkExportItems mod_map this_mod orig_env decl_map sub_map decls
Just iface -> lookupFM (iface_decls iface) n
Nothing -> Nothing
-fullContentsOfThisModule mod decls =
+fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem]
+fullContentsOfThisModule mdl decls =
map mkExportItem (filter keepDecl decls)
- where mkExportItem (HsDocGroup loc lev doc) = ExportGroup lev "" doc
- mkExportItem decl = ExportDecl (Qual mod x) decl
+ where mkExportItem (HsDocGroup _ lev doc) = ExportGroup lev "" doc
+ mkExportItem decl = ExportDecl (Qual mdl x) decl
where Just x = declMainBinder decl
+keepDecl :: HsDecl -> Bool
keepDecl HsTypeSig{} = True
keepDecl HsTypeDecl{} = True
keepDecl HsNewTypeDecl{} = True
@@ -496,51 +501,57 @@ keepDecl _ = False
-- together a type signature for it...)
extractDecl :: HsName -> Module -> HsDecl -> HsDecl
-extractDecl name mod decl
+extractDecl name mdl decl
| Just n <- declMainBinder decl, n == name = decl
| otherwise =
case decl of
- HsClassDecl loc ctxt n tvs fds decls mb_doc ->
+ HsClassDecl _ _ n tvs _ decls _ ->
case [ d | d@HsTypeSig{} <- decls,
declMainBinder d == Just name ] of
- [decl] -> extractClassDecl n mod tvs decl
+ [d0] -> extractClassDecl n mdl tvs d0
_ -> error "internal: extractDecl"
- HsDataDecl loc ctxt t tvs cons drvs mb_doc ->
- extractRecSel name mod t tvs cons
+ HsDataDecl _ _ t tvs cons _ _ ->
+ extractRecSel name mdl t tvs cons
- HsNewTypeDecl loc ctxt t tvs con drvs mb_doc ->
- extractRecSel name mod t tvs [con]
+ HsNewTypeDecl _ _ t tvs con _ _ ->
+ extractRecSel name mdl t tvs [con]
_ -> error ("extractDecl: " ++ show decl)
-
-extractClassDecl c mod tvs (HsTypeSig loc [n] ty doc)
+extractClassDecl :: HsName -> Module -> [HsName] -> HsDecl -> HsDecl
+extractClassDecl c mdl tvs0 (HsTypeSig loc [n] ty doc)
= case ty of
HsForAllType tvs ctxt' ty' ->
HsTypeSig loc [n] (HsForAllType tvs (ctxt ++ ctxt') ty') doc
- ty ->
+ _ ->
HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc
where
- ctxt = [(Qual mod c, map HsTyVar tvs)]
-
-extractRecSel nm mod t tvs [] = error "extractRecSel: selector not found"
-extractRecSel nm mod t tvs (HsRecDecl loc c _tvs ctxt fields _mb_doc : rest)
+ ctxt = [(Qual mdl c, map HsTyVar tvs0)]
+extractClassDecl _ _ _ d =
+ error $ "Main.extractClassDecl: unexpected decl: " ++ show d
+
+extractRecSel :: HsName -> Module -> HsName -> [HsName] -> [HsConDecl]
+ -> HsDecl
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ _ (d@(HsConDecl{}):_) =
+ error $ "Main.extractRecSel: unexpected (con)decl" ++ show d
+extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest)
| (HsFieldDecl ns ty mb_doc : _) <- matching_fields
= HsTypeSig loc [nm] (HsTyFun data_ty (unbang ty)) mb_doc
- | otherwise = extractRecSel nm mod t tvs rest
+ | otherwise = extractRecSel nm mdl t tvs rest
where
matching_fields = [ f | f@(HsFieldDecl ns ty mb_doc) <- fields,
nm `elem` ns ]
- data_ty = foldl HsTyApp (HsTyCon (Qual mod t)) (map HsTyVar tvs)
+ data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs)
-- -----------------------------------------------------------------------------
-- Pruning
pruneExportItems :: [ExportItem] -> [ExportItem]
pruneExportItems items = filter has_doc items
- where has_doc (ExportDecl x d) = isJust (declDoc d)
+ where has_doc (ExportDecl _ d) = isJust (declDoc d)
has_doc _ = True
-- -----------------------------------------------------------------------------
@@ -562,14 +573,14 @@ exportedNames :: Module -> ModuleMap -> [HsName]
-> [DocOption]
-> ([HsQName], [HsQName])
-exportedNames mod mod_map local_names orig_env sub_map maybe_exps options
+exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
| Nothing <- maybe_exps = all_local_names_pr
- | OptIgnoreExports `elem` options = all_local_names_pr
+ | OptIgnoreExports `elem` opts = all_local_names_pr
| Just expspecs <- maybe_exps =
(concat (map extract expspecs),
concat (map extract_vis expspecs))
where
- all_local_names = map (Qual mod) local_names
+ all_local_names = map (Qual mdl) local_names
all_local_names_pr = (all_local_names,all_local_names)
in_scope = eltsFM orig_env
@@ -581,12 +592,12 @@ exportedNames mod mod_map local_names orig_env sub_map maybe_exps options
HsEThingAll t@(Qual m x) ->
t : filter (`elem` in_scope) (map (Qual m) all_subs)
where
- all_subs | m == mod = lookupWithDefaultFM sub_map [] x
+ all_subs | m == mdl = lookupWithDefaultFM sub_map [] x
| otherwise = all_subs_of_qname mod_map t
HsEThingWith t cs -> t : cs
HsEModuleContents m
- | m == mod -> map (Qual mod) local_names
+ | m == mdl -> map (Qual mdl) local_names
| otherwise ->
case lookupFM mod_map m of
Just iface -> filter (`elem` in_scope) (eltsFM (iface_env iface))
@@ -599,7 +610,7 @@ exportedNames mod mod_map local_names orig_env sub_map maybe_exps options
extract_vis e =
case e of
HsEModuleContents m
- | m == mod -> map (Qual mod) local_names
+ | m == mdl -> map (Qual mdl) local_names
| otherwise ->
case lookupFM mod_map m of
Just iface
@@ -615,22 +626,24 @@ exportedNames mod mod_map local_names orig_env sub_map maybe_exps options
-- constructors and field names of a tycon, or all the methods of a
-- class).
all_subs_of_qname :: ModuleMap -> HsQName -> [HsName]
-all_subs_of_qname mod_map (Qual mod nm) =
- case lookupFM mod_map mod of
+all_subs_of_qname mod_map (Qual mdl nm) =
+ case lookupFM mod_map mdl of
Just iface -> lookupWithDefaultFM (iface_sub iface) [] nm
- Nothing -> []
+ Nothing -> []
+all_subs_of_qname _ n@(UnQual _) =
+ error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
-- Building name environments
buildOrigEnv :: ModuleMap -> [HsImportDecl] -> FiniteMap HsQName HsQName
buildOrigEnv mod_map imp_decls
= foldr plusFM emptyFM (map build imp_decls)
where
- build (HsImportDecl _ mod qual maybe_as spec)
- = case lookupFM mod_map mod of
+ build (HsImportDecl _ mdl qual maybe_as spec)
+ = case lookupFM mod_map mdl of
Nothing ->
- trace ("Warning: module not found: " ++ show mod) $ emptyFM
+ trace ("Warning: module not found: " ++ show mdl) $ emptyFM
Just iface ->
case spec of
-- no import specs
@@ -652,7 +665,7 @@ buildOrigEnv mod_map imp_decls
qual_module
| Just m <- maybe_as = m
- | otherwise = mod
+ | otherwise = mdl
env = iface_env iface
@@ -675,7 +688,7 @@ buildOrigEnv mod_map imp_decls
one_name :: HsName -> [(HsQName,HsQName)]
one_name nm =
case lookupFM env nm of
- Nothing -> trace ("Warning: " ++ show mod
+ Nothing -> trace ("Warning: " ++ show mdl
++ " does not export " ++ show nm) []
Just qnm -> orig_map (nm,qnm)
@@ -685,14 +698,14 @@ buildImportEnv :: ModuleMap -> Module -> [HsQName] -> [HsImportDecl]
buildImportEnv mod_map this_mod exported_names imp_decls
= foldr plusFM emptyFM (map build imp_decls)
where
- build (HsImportDecl _ mod qual maybe_as _)
- = case lookupFM mod_map mod of
+ build (HsImportDecl _ mdl _ _ _)
+ = case lookupFM mod_map mdl of
Nothing -> emptyFM
Just iface -> listToFM (map import_map (fmToList (iface_env iface)))
where
import_map (nm,qnm) = (qnm, maps_to)
where maps_to | qnm `elem` exported_names = Qual this_mod nm
- | otherwise = Qual mod nm
+ | otherwise = Qual mdl nm
-- -----------------------------------------------------------------------------
-- Expand multiple type signatures
@@ -709,26 +722,29 @@ expandDecl d = [ d ]
collectDoc :: [HsDecl] -> [HsDecl]
collectDoc decls = collect Nothing DocEmpty decls
+collect :: Maybe HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
collect d doc_so_far [] =
case d of
Nothing -> []
- Just d -> finishedDoc d doc_so_far []
+ Just d0 -> finishedDoc d0 doc_so_far []
collect d doc_so_far (decl:ds) =
case decl of
- HsDocCommentNext loc str ->
+ HsDocCommentNext _ str ->
case d of
Nothing -> collect d (docAppend doc_so_far str) ds
- Just d -> finishedDoc d doc_so_far (collect Nothing str ds)
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str ds)
- HsDocCommentPrev loc str -> collect d (docAppend doc_so_far str) ds
+ HsDocCommentPrev _ str -> collect d (docAppend doc_so_far str) ds
_other ->
let decl' = collectInDecl decl in
case d of
Nothing -> collect (Just decl') doc_so_far ds
- Just d -> finishedDoc d doc_so_far (collect (Just decl') DocEmpty ds)
+ Just d0 -> finishedDoc d0 doc_so_far
+ (collect (Just decl') DocEmpty ds)
+finishedDoc :: HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
finishedDoc d DocEmpty rest = d : rest
finishedDoc d doc rest = d' : rest
where d' =
@@ -747,6 +763,7 @@ finishedDoc d doc rest = d' : rest
HsForeignImport loc cc sf str n ty (Just doc)
_other -> d
+collectInDecl :: HsDecl -> HsDecl
collectInDecl (HsClassDecl loc ctxt n tvs fds meths doc)
= HsClassDecl loc ctxt n tvs fds (collect Nothing DocEmpty meths) doc
collectInDecl decl
@@ -760,7 +777,7 @@ findNamedDoc name decls = search decls
where search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (HsDocCommentNamed loc name' doc : rest)
+ search (HsDocCommentNamed _ name' doc : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
@@ -789,18 +806,18 @@ parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
-- Topologically sort the modules
sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)]
-sortModules mods = mapM for_each_scc sccs
+sortModules mdls = mapM for_each_scc sccs
where
sccs = stronglyConnComp edges
edges :: [((HsModule,FilePath), Module, [Module])]
- edges = [ ((hsmod,file), mod, get_imps impdecls)
- | (hsmod@(HsModule mod _ impdecls _ _ _ _), file) <- mods
+ edges = [ ((hsmod,file), mdl, get_imps impdecls)
+ | (hsmod@(HsModule mdl _ impdecls _ _ _ _), file) <- mdls
]
get_imps impdecls = [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]
- get_mods hsmodules = [ mod | HsModule mod _ _ _ _ _ _ <- hsmodules ]
+ get_mods hsmodules = [ mdl | HsModule mdl _ _ _ _ _ _ <- hsmodules ]
for_each_scc (AcyclicSCC hsmodule) = return hsmodule
for_each_scc (CyclicSCC hsmodules) =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 16:36:08 +0000