diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Binary.hs | 84 | ||||
| -rw-r--r-- | src/BlockTable.hs | 16 | ||||
| -rw-r--r-- | src/Digraph.lhs | 53 | ||||
| -rw-r--r-- | src/FastMutInt.hs | 24 | ||||
| -rw-r--r-- | src/HaddockHH.hs | 16 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 359 | ||||
| -rw-r--r-- | src/HaddockLex.hs | 70 | ||||
| -rw-r--r-- | src/HaddockModuleTree.hs | 7 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 142 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 56 | ||||
| -rw-r--r-- | src/HaddockVersion.hs | 2 | ||||
| -rw-r--r-- | src/HsLexer.lhs | 194 | ||||
| -rw-r--r-- | src/HsParseMonad.lhs | 22 | ||||
| -rw-r--r-- | src/HsParseUtils.lhs | 136 | ||||
| -rw-r--r-- | src/HsSyn.lhs | 41 | ||||
| -rw-r--r-- | src/Html.hs | 95 | ||||
| -rw-r--r-- | src/Main.hs | 207 |
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) = |