diff options
| -rw-r--r-- | examples/Hidden.hs | 1 | ||||
| -rw-r--r-- | examples/Test.hs | 76 | ||||
| -rw-r--r-- | examples/Visible.hs | 1 | ||||
| -rw-r--r-- | haddock.cabal | 14 | ||||
| -rw-r--r-- | src/Binary.hs | 687 | ||||
| -rw-r--r-- | src/Digraph.lhs | 416 | ||||
| -rw-r--r-- | src/FastMutInt.hs | 63 | ||||
| -rw-r--r-- | src/HaddockDB.hs | 2 | ||||
| -rw-r--r-- | src/HaddockDevHelp.hs | 2 | ||||
| -rw-r--r-- | src/HaddockHH.hs | 2 | ||||
| -rw-r--r-- | src/HaddockHH2.hs | 2 | ||||
| -rw-r--r-- | src/HaddockHoogle.hs | 2 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 4 | ||||
| -rw-r--r-- | src/HaddockLex.x | 168 | ||||
| -rw-r--r-- | src/HaddockModuleTree.hs | 2 | ||||
| -rw-r--r-- | src/HaddockParse.y | 96 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 2 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 20 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 46 | ||||
| -rw-r--r-- | src/HsLexer.lhs | 2 | ||||
| -rw-r--r-- | src/HsParseMonad.lhs | 2 | ||||
| -rw-r--r-- | src/HsParseUtils.lhs | 2 | ||||
| -rw-r--r-- | src/HsParser.ly | 6 | ||||
| -rw-r--r-- | src/HsSyn.lhs | 542 | ||||
| -rw-r--r-- | src/Main.hs | 267 |
25 files changed, 375 insertions, 2052 deletions
diff --git a/examples/Hidden.hs b/examples/Hidden.hs index dce05043..d30925b1 100644 --- a/examples/Hidden.hs +++ b/examples/Hidden.hs @@ -1,3 +1,4 @@ -- #hide module Hidden where hidden :: Int -> Int +hidden a = a diff --git a/examples/Test.hs b/examples/Test.hs index ebf7d505..0e34dd7a 100644 --- a/examples/Test.hs +++ b/examples/Test.hs @@ -84,7 +84,7 @@ module Test ( Ex(..), -- * Type signatures with argument docs - k, l, m, n, o, + k, l, m, o, -- * A section -- and without an intervening comma: @@ -96,7 +96,6 @@ module Test ( $ a non /literal/ line $ -} - p, f', ) where @@ -135,7 +134,7 @@ data T6 C4 -- | A newtype -newtype N1 a b = N1 (a b) +newtype N1 a = N1 a -- | A newtype with a fieldname newtype N2 a b = N2 {n :: a b} @@ -163,10 +162,10 @@ newtype N7 a b = N7 {n7 :: a b class (D a) => C a where -- |this is a description of the 'a' method - a :: Int - b :: Float + a :: IO a + b :: [a] -- ^ this is a description of the 'b' method - c :: Double -- c is hidden in the export list + c :: a -- c is hidden in the export list -- ^ This comment applies to the /previous/ declaration (the 'C' class) @@ -175,18 +174,22 @@ class D a where e :: (a,a) -- ^ This is a class declaration with no separate docs for the methods -instance D Int +instance D Int where + d = undefined + e = undefined -- instance with a qualified class name -instance Test.D Float +instance Test.D Float where + d = undefined + e = undefined class E a where - ee :: Int + ee :: a -- ^ This is a class declaration with no methods (or no methods exported) -- This is a class declaration with no documentation at all class F a where - ff :: Float + ff :: a -- | This is the documentation for the 'R' record, which has four fields, -- 'p', 'q', 'r', and 's'. @@ -197,7 +200,7 @@ data R = , -- | This comment applies to both 'r' and 's' r,s :: Int } - | C2 { t :: T1 -> T2 -> T3 -> T4 -> T5, + | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), u,v :: Int } -- ^ This is the 'C2' record constructor, also with some fields: @@ -210,7 +213,8 @@ data R1 s1 :: Int -- | The 's2' record selector , s2 :: Int - , s3 :: Int, + , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. + -- Since GHC doesn't allow that, I have removed it in this file. -- ^ The 's3' record selector } @@ -246,8 +250,7 @@ using double quotes: "Foo". We can add emphasis /like this/. We can also include URLs in documentation: <http://www.haskell.org/>. -} -f :: C a => Int -> Int - +f :: C a => a -> Int -- | we can export foreign declarations too foreign import ccall g :: Int -> IO CInt @@ -346,17 +349,17 @@ test2 data Ex a = forall b . C b => Ex1 b | forall b . Ex2 b - | C a => Ex3 b + | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file | Ex4 (forall a . a -> a) -- | This is a function with documentation for each argument -k :: T -- ^ This argument has type 'T' - -> T2 -- ^ This argument has type 'T2' - -> (T3 -> T4) -- ^ This argument has type @T3 -> T4@ - -> T5 -- ^ This argument has a very long description that should - -- hopefully cause some wrapping to happen when it is finally - -- rendered by Haddock in the generated HTML page. - -> IO () -- ^ This is the result type +k :: T () () -- ^ This argument has type 'T' + -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' + -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ + -> T5 () () -- ^ This argument has a very long description that should + -- hopefully cause some wrapping to happen when it is finally + -- rendered by Haddock in the generated HTML page. + -> IO () -- ^ This is the result type -- This function has arg docs but no docs for the function itself l :: (Int, Int, Float) -- ^ takes a triple @@ -364,13 +367,17 @@ l :: (Int, Int, Float) -- ^ takes a triple -- | This function has some arg docs m :: R - -> N1 -- ^ one of the arguments + -> N1 () -- ^ one of the arguments -> IO Int -- ^ and the return value -- | This function has some arg docs but not a return value doc -n :: R -- ^ one of the arguments, an 'R' - -> N1 -- ^ one of the arguments - -> IO Int + +-- can't use the original name ('n') with GHC +newn :: R -- ^ one of the arguments, an 'R' + -> N1 () -- ^ one of the arguments + -> IO Int +newn = undefined + -- | A foreign import with argument docs foreign import ccall unsafe @@ -378,8 +385,23 @@ foreign import ccall unsafe -> IO Float -- ^ The output float -- | We should be able to escape this: \#\#\# -p :: Int + +-- p :: Int +-- can't use the above original definition with GHC +newp :: Int +newp = undefined -- | a function with a prime can be referred to as 'f'' -- but f' doesn't get link'd 'f\'' f' :: Int + + +-- Add some definitions here so that this file can be compiled with GHC + +data T1 +f = undefined +f' = undefined +type CInt = Int +k = undefined +l = undefined +m = undefined diff --git a/examples/Visible.hs b/examples/Visible.hs index 33987c46..cad71931 100644 --- a/examples/Visible.hs +++ b/examples/Visible.hs @@ -1,2 +1,3 @@ module Visible where visible :: Int -> Int +visible a = a diff --git a/haddock.cabal b/haddock.cabal index 344bb0e4..3beb5d7c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -9,7 +9,7 @@ maintainer: Simon Marlow <simonmar@microsoft.com> stability: stable homepage: http://www.haskell.org/haddock/ synopsis: Haddock is a documentation-generation tool for Haskell libraries -build-depends: base>=1.0, haskell98>=1.0, mtl>=1.0, network>=1.0 +build-depends: base>=1.0, haskell98>=1.0, mtl>=1.0, network>=1.0, ghc data-files: html/haddock-DEBUG.css html/haddock.css @@ -58,19 +58,19 @@ hs-source-dirs: src main-is: Main.hs extensions: CPP other-modules: - Binary + Binary2 BlockTable - Digraph - FastMutInt + Digraph2 + FastMutInt2 HaddockDB HaddockDevHelp HaddockHH HaddockHH2 HaddockHoogle HaddockHtml - HaddockLex + HaddockLex2 HaddockModuleTree - HaddockParse + HaddockParse2 HaddockRename HaddockTypes HaddockUtil @@ -79,7 +79,7 @@ other-modules: HsParseMonad HsParseUtils HsParser - HsSyn + HsSyn2 Html Main Map diff --git a/src/Binary.hs b/src/Binary.hs deleted file mode 100644 index f1c98620..00000000 --- a/src/Binary.hs +++ /dev/null @@ -1,687 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} --- --- (c) The University of Glasgow 2002 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - -module Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - - openBinIO, - openBinIO_, - openBinMem, --- closeBin, - --- getUserData, - - seekBin, - tellBin, - castBin, - - writeBinMem, - readBinMem, - - isEOFBin, - - -- for writing instances: - putByte, - getByte, - - putString, - getString, - - -- lazy Bin I/O - lazyGet, - lazyPut, - - -- GHC only: - ByteArray(..), - getByteArray, - putByteArray, - --- getBinFileWithDict, -- :: Binary a => FilePath -> IO a --- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () - - -- re-export for the benefit of other modules. - openBinaryFile, - - FormatVersion, - nullFormatVersion, - mkFormatVersion, - ) where - -#include "MachDeps.h" - -import FastMutInt - -import Char -import Monad - -#if __GLASGOW_HASKELL__ < 503 -import IOExts -import Bits -import Int -import Word -import Char -import Monad -import Exception -import GlaExts hiding (ByteArray, newByteArray, freezeByteArray) -import Array -import IO -import PrelIOBase ( IOError(..), IOErrorType(..) -#if __GLASGOW_HASKELL__ > 411 - , IOException(..) -#endif - ) -import PrelReal ( Ratio(..) ) -import PrelIOBase ( IO(..) ) -#else -import Data.Array.IO -import Data.Array -import Data.Bits -import Data.Int -import Data.Word -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Array.Base ( unsafeRead, unsafeWrite ) -import Control.Monad ( when ) -import Control.Exception ( throwDyn ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Exts -import GHC.IOBase ( IO(..) ) -import GHC.Word ( Word8(..) ) -#if __GLASGOW_HASKELL__ < 601 --- openFileEx is available from the lang package, but we want to --- be independent of hslibs libraries. -import GHC.Handle ( openFileEx, IOModeEx(..) ) -#endif -#endif - -import IO - -#if __GLASGOW_HASKELL__ < 601 -openBinaryFile f mode = openFileEx f (BinaryMode mode) -#endif - -#if __GLASGOW_HASKELL__ < 503 -type BinArray = MutableByteArray RealWorld Int -newArray_ bounds = stToIO (newCharArray bounds) -unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e) -unsafeRead arr ix = stToIO (readWord8Array arr ix) -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif -hPutArray h arr sz = hPutBufBAFull h arr sz -hGetArray h sz = hGetBufBAFull h sz - -mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception -mkIOError t location maybe_hdl maybe_filename - = IOException (IOError maybe_hdl t location "" -#if __GLASGOW_HASKELL__ > 411 - maybe_filename -#endif - ) - -eofErrorType = EOF - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - -#ifndef SIZEOF_HSWORD -#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES -#endif - -#else -type BinArray = IOUArray Int Word8 -#endif - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - state :: Int, -- sigh, need parameterized modules :-) - off_r :: !FastMutInt, -- the current offset - sz_r :: !FastMutInt, -- size of the array (cached) - arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - - | BinIO { -- binary data stored in a file - state :: Int, - off_r :: !FastMutInt, -- the current offset (cached) - hdl :: !IO.Handle -- the file handle (must be seekable) - } - -- cache the file ptr in BinIO; using hTell is too expensive - -- to call repeatedly. If anyone else is modifying this Handle - -- at the same time, we'll be screwed. - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinIO_ :: IO.Handle -> IO BinHandle -openBinIO_ h = openBinIO h - -openBinIO :: IO.Handle -> IO BinHandle -openBinIO h = do - r <- newFastMutInt - writeFastMutInt r 0 - return (BinIO undefined r h) - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- newArray_ (0,size-1) - arr_r0 <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r0 <- newFastMutInt - writeFastMutInt sz_r0 size - return (BinMem undefined ix_r sz_r0 arr_r0) - ---noBinHandleUserData :: a ---noBinHandleUserData = error "Binary.BinHandle: no user data" - ---getUserData :: BinHandle -> BinHandleState ---getUserData bh = state bh - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -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_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_r0 _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - return (ix >= sz) -isEOFBin (BinIO _ _ h) = hIsEOF h - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" -writeBinMem (BinMem _ ix_r _ arr_r0) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r0 - ix <- readFastMutInt ix_r - hPutArray h arr ix - hClose h - -readBinMem :: FilePath -> IO BinHandle -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- newArray_ (0,filesize-1) - count <- hGetArray h arr filesize - when (count /= filesize) - (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) - hClose h - arr_r0 <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - 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 _ _ sz_r0 arr_r0) off = do - sz <- readFastMutInt sz_r0 - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) - arr <- readIORef arr_r0 - arr' <- newArray_ (0,sz'-1) - sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i - | i <- [ 0 .. sz-1 ] ] - writeFastMutInt sz_r0 sz' - writeIORef arr_r0 arr' - hPutStrLn stderr ("expanding to size: " ++ show sz') - return () -expandBin (BinIO _ _ _) _ = return () - -- no need to expand a file, we'll assume they expand by themselves. - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h@(BinMem _ ix_r sz_r0 arr_r0) w = do - ix <- readFastMutInt ix_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_r0 - unsafeWrite arr ix w - writeFastMutInt ix_r (ix+1) - return () -putWord8 (BinIO _ ix_r h) w = do - ix <- readFastMutInt ix_r - hPutChar h (chr (fromIntegral w)) -- XXX not really correct - writeFastMutInt ix_r (ix+1) - return () - -getWord8 :: BinHandle -> IO Word8 -getWord8 (BinMem _ ix_r sz_r0 arr_r0) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - when (ix >= sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) - arr <- readIORef arr_r0 - w <- unsafeRead arr ix - writeFastMutInt ix_r (ix+1) - return w -getWord8 (BinIO _ ix_r h) = do - ix <- readFastMutInt ix_r - c <- hGetChar h - writeFastMutInt ix_r (ix+1) - return $! (fromIntegral (ord c)) -- XXX not really correct - --- | Get the next byte, but don't change the pointer. -peekWord8 :: BinHandle -> IO Word8 -peekWord8 (BinMem _ ix_r sz_r0 arr_r0) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - when (ix >= sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) - arr <- readIORef arr_r0 - w <- unsafeRead arr ix - return w -peekWord8 (BinIO _ ix_r h) = do - c <- hLookAhead h - return $! (fromIntegral (ord c)) -- XXX not really correct - -putByte :: BinHandle -> Word8 -> IO () -putByte bh w = put_ bh w - -getByte :: BinHandle -> IO Word8 -getByte = getWord8 - --- ----------------------------------------------------------------------------- --- Primitve Word writes - -instance Binary Word8 where - put_ = putWord8 - get = getWord8 - -instance Binary Word16 where - put_ h w = do -- XXX too slow.. inline putWord8? - putByte h (fromIntegral (w `shiftR` 8)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) - - -instance Binary Word32 where - put_ h w = do - putByte h (fromIntegral (w `shiftR` 24)) - putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 24) .|. - (fromIntegral w2 `shiftL` 16) .|. - (fromIntegral w3 `shiftL` 8) .|. - (fromIntegral w4)) - - -instance Binary Word64 where - put_ h w = do - putByte h (fromIntegral (w `shiftR` 56)) - putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - w5 <- getWord8 h - w6 <- getWord8 h - w7 <- getWord8 h - w8 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 56) .|. - (fromIntegral w2 `shiftL` 48) .|. - (fromIntegral w3 `shiftL` 40) .|. - (fromIntegral w4 `shiftL` 32) .|. - (fromIntegral w5 `shiftL` 24) .|. - (fromIntegral w6 `shiftL` 16) .|. - (fromIntegral w7 `shiftL` 8) .|. - (fromIntegral w8)) - --- ----------------------------------------------------------------------------- --- Primitve Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ h w = put_ h (fromIntegral w :: Word16) - get h = do w <- get h; return $! (fromIntegral (w::Word16)) - -instance Binary Int32 where - put_ h w = put_ h (fromIntegral w :: Word32) - get h = do w <- get h; return $! (fromIntegral (w::Word32)) - -instance Binary Int64 where - put_ h w = put_ h (fromIntegral w :: Word64) - get h = do w <- get h; return $! (fromIntegral (w::Word64)) - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () --- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) --- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) --- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) - -instance Binary Int where -#if SIZEOF_HSINT == 4 - put_ bh i = put_ bh (fromIntegral i :: Int32) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int32)) -#elif SIZEOF_HSINT == 8 - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) -#else -#error "unsupported sizeof(HsInt)" -#endif --- getF bh = getBitsF bh 32 - -{- -instance Binary a => Binary [a] where - put_ bh [] = putByte bh 0 - put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs - get bh = do h <- getWord8 bh - case h of - 0 -> return [] - _ -> do x <- get bh - xs <- get bh - return (x:xs) --} -instance Binary a => Binary [a] where - put_ bh l = - do put_ bh (length l) - mapM (put_ bh) l - return () - get bh = - do len <- get bh - mapM (\_ -> get bh) [1..(len::Int)] - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where - put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f,Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary Integer where - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - p <- putByte bh 1; - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - - -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s0 -> - case newByteArray# sz s0 of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -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 $ \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 - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - -instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh i - get bh = do i <- get bh; return (BinPtr i) - --- ----------------------------------------------------------------------------- --- Strings - --- should put a string in UTF-8 (just throws away top 24 bits at the moment) -putString :: BinHandle -> String -> IO () -putString bh str = put_ bh word8s - where - word8s :: [Word8] - word8s = map (fromIntegral.ord) str - -getString :: BinHandle -> IO String -getString bh = do - word8s <- get bh - return (map (chr.fromIntegral) (word8s :: [Word8])) - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO (getAt bh p_a) - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- FormatVersion's. --- The FormatVersion is always non-negative. Furthermore, if the --- FormatVersion is 0, nothing is output. --- --- FormatVersion should only be encoded before something we KNOW to have --- an encoding which never begins with a negative byte, such as a non-negative --- integer or a list. --- --- The advantage of this is that we can read a FormatVersion (which will --- be the nullFormatVersion) even when we didn't write one in the first --- place, such as from earlier versions of this program, just so long --- as we did at any rate write a list. - -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) - -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion i = FormatVersion i - -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - w8 <- peekWord8 bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion diff --git a/src/Digraph.lhs b/src/Digraph.lhs deleted file mode 100644 index a7a04d49..00000000 --- a/src/Digraph.lhs +++ /dev/null @@ -1,416 +0,0 @@ --- --- Taken from ghc/compiler/utils/Digraph.lhs v1.15 --- (c) The University of Glasgow, 2002 --- - -\begin{code} -{-# OPTIONS -cpp #-} -module Digraph( - - -- At present the only one with a "nice" external interface - stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, - - Graph, Vertex, - graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree, - - Tree(..), Forest, - showTree, showForest, - - dfs, dff, - topSort, - components, - scc, - back, cross, forward, - reachable, path, - bcc - - ) where - ------------------------------------------------------------------------------- --- A version of the graph algorithms described in: --- --- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell'' --- by David King and John Launchbury --- --- Also included is some additional code for printing tree structures ... ------------------------------------------------------------------------------- - - -#define ARR_ELT (COMMA) - --- Extensions -#if __GLASGOW_HASKELL__ < 503 -import ST -#else -import Control.Monad.ST -import Data.Array.ST hiding (indices,bounds) -#endif - --- std interfaces -import Maybe -import Array -import List -\end{code} - - -%************************************************************************ -%* * -%* External interface -%* * -%************************************************************************ - -\begin{code} -data SCC vertex = AcyclicSCC vertex - | CyclicSCC [vertex] - -flattenSCCs :: [SCC a] -> [a] -flattenSCCs = concatMap flattenSCC - -flattenSCC :: SCC vertex -> [vertex] -flattenSCC (AcyclicSCC v) = [v] -flattenSCC (CyclicSCC vs) = vs -\end{code} - -\begin{code} -stronglyConnComp - :: Ord key - => [(node, key, [key])] -- The graph; its ok for the - -- out-list to contain keys which arent - -- a vertex key, they are ignored - -> [SCC node] - -stronglyConnComp edges0 - = map get_node (stronglyConnCompR edges0) - where - get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n - get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples] - --- The "R" interface is used when you expect to apply SCC to --- the (some of) the result of SCC, so you dont want to lose the dependency info -stronglyConnCompR - :: Ord key - => [(node, key, [key])] -- The graph; its ok for the - -- out-list to contain keys which arent - -- a vertex key, they are ignored - -> [SCC (node, key, [key])] - -stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF -stronglyConnCompR edges0 - = map decode forest - where - (graph, vertex_fn) = graphFromEdges edges0 - forest = scc graph - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where - dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) -\end{code} - -%************************************************************************ -%* * -%* Graphs -%* * -%************************************************************************ - - -\begin{code} -type Vertex = Int -type Table a = Array Vertex a -type Graph = Table [Vertex] -type Bounds = (Vertex, Vertex) -type Edge = (Vertex, Vertex) -\end{code} - -\begin{code} -vertices :: Graph -> [Vertex] -vertices = indices - -edges :: Graph -> [Edge] -edges g = [ (v, w) | v <- vertices g, w <- g!v ] - -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 bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0 - -transposeG :: Graph -> Graph -transposeG g = buildG (bounds g) (reverseE g) - -reverseE :: Graph -> [Edge] -reverseE g = [ (w, v) | (v, w) <- edges g ] - -outdegree :: Graph -> Table Int -outdegree = mapT numEdges - where numEdges _ ws = length ws - -indegree :: Graph -> Table Int -indegree = outdegree . transposeG -\end{code} - - -\begin{code} -graphFromEdges - :: Ord key - => [(node, key, [key])] - -> (Graph, Vertex -> (node, key, [key])) -graphFromEdges edges0 - = (graph, \v -> vertex_map ! v) - where - max_v = length edges0 - 1 - bounds0 = (0,max_v) :: (Vertex, Vertex) - sorted_edges = sortBy lt edges0 - edges1 = zipWith (,) [0..] sorted_edges - - 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 = findVertex 0 max_v - where - findVertex a b | a > b - = Nothing - findVertex a b = case compare k (key_map ! mid) of - LT -> findVertex a (mid-1) - EQ -> Just mid - GT -> findVertex (mid+1) b - where - mid = (a + b) `div` 2 -\end{code} - -%************************************************************************ -%* * -%* Trees and forests -%* * -%************************************************************************ - -\begin{code} -data Tree a = Node a (Forest a) -type Forest a = [Tree a] - -mapTree :: (a -> b) -> (Tree a -> Tree b) -mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) -\end{code} - -\begin{code} -instance Show a => Show (Tree a) where - showsPrec _ t s = showTree t ++ s - -showTree :: Show a => Tree a -> String -showTree = drawTree . mapTree show - -showForest :: Show a => Forest a -> String -showForest = unlines . map showTree - -drawTree :: Tree String -> String -drawTree = unlines . draw - -draw :: Tree String -> [String] -draw (Node x ts0) = grp this (space (length this)) (stLoop ts0) - where this = s1 ++ x ++ " " - - space n = replicate n ' ' - - stLoop [] = [""] - 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 fst0 rst = zipWith (++) (fst0:repeat rst) - - [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"] -\end{code} - - -%************************************************************************ -%* * -%* Depth first search -%* * -%************************************************************************ - -\begin{code} -#if __GLASGOW_HASKELL__ >= 504 -newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) -newSTArray = newArray - -readSTArray :: Ix i => STArray s i e -> i -> ST s e -readSTArray = readArray - -writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () -writeSTArray = writeArray -#endif - -type Set s = STArray s Vertex Bool - -mkEmpty :: Bounds -> ST s (Set s) -mkEmpty bnds = newSTArray bnds False - -contains :: Set s -> Vertex -> ST s Bool -contains m v = readSTArray m v - -include :: Set s -> Vertex -> ST s () -include m v = writeSTArray m v True -\end{code} - -\begin{code} -dff :: Graph -> Forest Vertex -dff g = dfs g (vertices g) - -dfs :: Graph -> [Vertex] -> Forest Vertex -dfs g vs = prune (bounds g) (map (generate g) vs) - -generate :: Graph -> Vertex -> Tree Vertex -generate g v = Node v (map (generate g) (g!v)) - -prune :: Bounds -> Forest Vertex -> Forest Vertex -prune bnds ts = runST (mkEmpty bnds >>= \m -> - chop m ts) - -chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) -chop _ [] = return [] -chop m (Node v ts : us) - = contains m v >>= \visited -> - if visited then - chop m us - else - include m v >>= \_ -> - chop m ts >>= \as -> - chop m us >>= \bs -> - return (Node v as : bs) -\end{code} - - -%************************************************************************ -%* * -%* Algorithms -%* * -%************************************************************************ - ------------------------------------------------------------- --- Algorithm 1: depth first search numbering ------------------------------------------------------------- - -\begin{code} -preorder :: Tree a -> [a] -preorder (Node a ts) = a : preorderF ts - -preorderF :: Forest a -> [a] -preorderF ts = concat (map preorder ts) - -tabulate :: Bounds -> [Vertex] -> Table Int -tabulate bnds vs = array bnds (zipWith (,) vs [1..]) - -preArr :: Bounds -> Forest Vertex -> Table Int -preArr bnds = tabulate bnds . preorderF -\end{code} - - ------------------------------------------------------------- --- Algorithm 2: topological sorting ------------------------------------------------------------- - -\begin{code} -postorder :: Tree a -> [a] -postorder (Node a ts) = postorderF ts ++ [a] - -postorderF :: Forest a -> [a] -postorderF ts = concat (map postorder ts) - -postOrd :: Graph -> [Vertex] -postOrd = postorderF . dff - -topSort :: Graph -> [Vertex] -topSort = reverse . postOrd -\end{code} - - ------------------------------------------------------------- --- Algorithm 3: connected components ------------------------------------------------------------- - -\begin{code} -components :: Graph -> Forest Vertex -components = dff . undirected - -undirected :: Graph -> Graph -undirected g = buildG (bounds g) (edges g ++ reverseE g) -\end{code} - - --- Algorithm 4: strongly connected components - -\begin{code} -scc :: Graph -> Forest Vertex -scc g = dfs g (reverse (postOrd (transposeG g))) -\end{code} - - ------------------------------------------------------------- --- Algorithm 5: Classifying edges ------------------------------------------------------------- - -\begin{code} -back :: Graph -> Table Int -> Graph -back g post = mapT select g - where select v ws = [ w | w <- ws, post!v < post!w ] - -cross :: Graph -> Table Int -> Table Int -> Graph -cross g pre post = mapT select g - where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ] - -forward :: Graph -> Graph -> Table Int -> Graph -forward g tree pre = mapT select g - where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v -\end{code} - - ------------------------------------------------------------- --- Algorithm 6: Finding reachable vertices ------------------------------------------------------------- - -\begin{code} -reachable :: Graph -> Vertex -> [Vertex] -reachable g v = preorderF (dfs g [v]) - -path :: Graph -> Vertex -> Vertex -> Bool -path g v w = w `elem` (reachable g v) -\end{code} - - ------------------------------------------------------------- --- Algorithm 7: Biconnected components ------------------------------------------------------------- - -\begin{code} -bcc :: Graph -> Forest [Vertex] -bcc g = (concat . map bicomps . map (do_label g dnum)) forest - where forest = dff g - dnum = preArr (bounds g) forest - -do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) -do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us - where us = map (do_label g dnum) ts - lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] - ++ [lu | Node (u,du,lu) xs <- us]) - -bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] -bicomps (Node (v,_,_) ts) - = [ Node (v:vs) us | (l,Node vs us) <- map collect ts] - -collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex]) -collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) - where collected = map collect ts - vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv] - cs = concat [ if lw<dv then us else [Node (v:ws) us] - | (lw, Node ws us) <- collected ] -\end{code} - diff --git a/src/FastMutInt.hs b/src/FastMutInt.hs deleted file mode 100644 index 23001c1f..00000000 --- a/src/FastMutInt.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} --- --- (c) The University of Glasgow 2002 --- --- Unboxed mutable Ints - -module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - incFastMutInt, incFastMutIntBy - ) where - -#include "MachDeps.h" - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - - -#if __GLASGOW_HASKELL__ < 503 -import GlaExts -import PrelIOBase -#else -import GHC.Base -import GHC.IOBase -#endif - -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif - -#ifdef __GLASGOW_HASKELL__ -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt :: IO FastMutInt -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 $ \s0 -> - case readIntArray# arr 0# s0 of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt :: FastMutInt -> Int -> IO () -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 $ \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 $ \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/HaddockDB.hs b/src/HaddockDB.hs index a56ebada..bc6af5a6 100644 --- a/src/HaddockDB.hs +++ b/src/HaddockDB.hs @@ -9,7 +9,7 @@ module HaddockDB (ppDocBook) where {- import HaddockTypes import HaddockUtil -import HsSyn +import HsSyn2 import Text.PrettyPrint -} diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs index 390fb6f3..c16e474c 100644 --- a/src/HaddockDevHelp.hs +++ b/src/HaddockDevHelp.hs @@ -3,7 +3,7 @@ module HaddockDevHelp(ppDevHelpFile) where import HaddockModuleTree import HaddockTypes import HaddockUtil -import HsSyn hiding(Doc) +import HsSyn2 hiding(Doc) import qualified Map import Data.Maybe ( fromMaybe ) diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index 59953575..937d382f 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -3,7 +3,7 @@ module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where import HaddockModuleTree import HaddockTypes import HaddockUtil -import HsSyn hiding(Doc) +import HsSyn2 hiding(Doc) import qualified Map import Data.Char ( toUpper ) diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs index 6d4ce5c0..c4804190 100644 --- a/src/HaddockHH2.hs +++ b/src/HaddockHH2.hs @@ -3,7 +3,7 @@ module HaddockHH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where import HaddockModuleTree import HaddockTypes import HaddockUtil -import HsSyn hiding(Doc) +import HsSyn2 hiding(Doc) import qualified Map import Data.Char ( toUpper ) diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs index a846f58c..3b624cd6 100644 --- a/src/HaddockHoogle.hs +++ b/src/HaddockHoogle.hs @@ -13,7 +13,7 @@ module HaddockHoogle ( import HaddockTypes import HaddockUtil -import HsSyn +import HsSyn2 import Data.List ( intersperse ) diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 5c6bd892..a383c85c 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -12,7 +12,7 @@ module HaddockHtml ( import Prelude hiding (div) -import Binary ( openBinaryFile ) +import Binary2 ( openBinaryFile ) import HaddockDevHelp import HaddockHH import HaddockHH2 @@ -20,7 +20,7 @@ import HaddockModuleTree import HaddockTypes import HaddockUtil import HaddockVersion -import HsSyn +import HsSyn2 import Html import qualified Html import Map ( Map ) diff --git a/src/HaddockLex.x b/src/HaddockLex.x deleted file mode 100644 index f5e40942..00000000 --- a/src/HaddockLex.x +++ /dev/null @@ -1,168 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2002 --- - -{ -module HaddockLex ( - Token(..), - tokenise - ) where - -import Char -import Numeric -import HsSyn -import HsLexer hiding (Token) -import HsParseMonad ---import Debug.Trace -} - -$ws = $white # \n -$digit = [0-9] -$hexdigit = [0-9a-fA-F] -$special = [\"\@\/] -$alphanum = [A-Za-z0-9] -$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] - -:- - --- beginning of a paragraph -<0,para> { - $ws* \n ; - $ws* \> { begin birdtrack } - $ws* [\*\-] { token TokBullet `andBegin` string } - $ws* \[ { token TokDefStart `andBegin` def } - $ws* \( $digit+ \) { token TokNumber `andBegin` string } - $ws* { begin string } -} - --- beginning of a line -<line> { - $ws* \> { begin birdtrack } - $ws* \n { token TokPara `andBegin` para } - -- Here, we really want to be able to say - -- $ws* (\n | <eof>) { token TokPara `andBegin` para} - -- because otherwise a trailing line of whitespace will result in - -- a spurious TokString at the end of a docstring. We don't have <eof>, - -- though (NOW I realise what it was for :-). To get around this, we always - -- append \n to the end of a docstring. - () { begin string } -} - -<birdtrack> .* \n? { strtoken TokBirdTrack `andBegin` line } - -<string,def> { - $special { strtoken $ \s -> TokSpecial (head s) } - \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } - \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } - [\'\`] $ident+ [\'\`] { ident } - \\ . { strtoken (TokString . tail) } - "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] } - "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] } - -- allow special characters through if they don't fit one of the previous - -- patterns. - [\'\`\<\#\&\\] { strtoken TokString } - [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line } - [^ $special \< \# \n \'\` \& \\ \]]+ { strtoken TokString } -} - -<def> { - \] { token TokDefEnd `andBegin` string } -} - --- ']' doesn't have any special meaning outside of the [...] at the beginning --- of a definition paragraph. -<string> { - \] { strtoken TokString } -} - -{ -data Token - = TokPara - | TokNumber - | TokBullet - | TokDefStart - | TokDefEnd - | TokSpecial Char - | TokIdent [HsQName] - | TokString String - | TokURL String - | TokAName String - | TokBirdTrack String - deriving Show - --- ----------------------------------------------------------------------------- --- Alex support stuff - -type StartCode = Int -type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) - -alexInputPrevChar (c,_) = c - -tokenise :: String -> [Token] -tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks - where go inp@(_,str) sc = - case alexScan inp sc of - AlexEOF -> [] - AlexError _ -> error "lexical error" - AlexSkip inp' len -> go inp' sc - AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) - --- NB. we add a final \n to the string, (see comment in the beginning of line --- production above). -eofHack str = str++"\n" - -andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \str sc cont -> act str new_sc cont - -token :: Token -> Action -token t = \str sc cont -> t : cont sc - -strtoken :: (String -> Token) -> Action -strtoken t = \str sc cont -> t str : cont sc - -begin :: StartCode -> Action -begin sc = \str _ cont -> cont sc - --- ----------------------------------------------------------------------------- --- Lex a string as a Haskell identifier - -ident :: Action -ident str sc cont = - case strToHsQNames id of - Just names -> TokIdent names : cont sc - Nothing -> TokString str : cont sc - where id = init (tail str) - -strToHsQNames :: String -> Maybe [HsQName] -strToHsQNames str0 - = case lexer (\t -> returnP t) str0 (SrcLoc 1 1 "") 1 1 "" [] of - Ok _ (VarId str) - -> Just [ UnQual (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 (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 (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 bd877bf4..51c0fa17 100644 --- a/src/HaddockModuleTree.hs +++ b/src/HaddockModuleTree.hs @@ -1,6 +1,6 @@ module HaddockModuleTree(ModuleTree(..), mkModuleTree) where -import HsSyn +import HsSyn2 data ModuleTree = Node String Bool (Maybe String) (Maybe Doc) [ModuleTree] diff --git a/src/HaddockParse.y b/src/HaddockParse.y deleted file mode 100644 index dbc97446..00000000 --- a/src/HaddockParse.y +++ /dev/null @@ -1,96 +0,0 @@ -{ -module HaddockParse (parseParas, parseString) where - -import HaddockLex -import HsSyn -} - -%tokentype { Token } - -%token '/' { TokSpecial '/' } - '@' { TokSpecial '@' } - '[' { TokDefStart } - ']' { TokDefEnd } - DQUO { TokSpecial '\"' } - URL { TokURL $$ } - ANAME { TokAName $$ } - '-' { TokBullet } - '(n)' { TokNumber } - '>..' { TokBirdTrack $$ } - IDENT { TokIdent $$ } - PARA { TokPara } - STRING { TokString $$ } - -%monad { Either String } - -%name parseParas doc -%name parseString seq - -%% - -doc :: { Doc } - : apara PARA doc { docAppend $1 $3 } - | PARA doc { $2 } - | apara { $1 } - | {- empty -} { DocEmpty } - -apara :: { Doc } - : ulpara { DocUnorderedList [$1] } - | olpara { DocOrderedList [$1] } - | defpara { DocDefList [$1] } - | para { $1 } - -ulpara :: { Doc } - : '-' para { $2 } - -olpara :: { Doc } - : '(n)' para { $2 } - -defpara :: { (Doc,Doc) } - : '[' seq ']' seq { ($2, $4) } - -para :: { Doc } - : seq { docParagraph $1 } - | codepara { DocCodeBlock $1 } - -codepara :: { Doc } - : '>..' codepara { docAppend (DocString $1) $2 } - | '>..' { DocString $1 } - -seq :: { Doc } - : elem seq { docAppend $1 $2 } - | elem { $1 } - -elem :: { Doc } - : elem1 { $1 } - | '@' seq1 '@' { DocMonospaced $2 } - -seq1 :: { Doc } - : elem1 seq1 { docAppend $1 $2 } - | elem1 { $1 } - -elem1 :: { Doc } - : STRING { DocString $1 } - | '/' strings '/' { DocEmphasis (DocString $2) } - | URL { DocURL $1 } - | ANAME { DocAName $1 } - | IDENT { DocIdentifier $1 } - | DQUO strings DQUO { DocModule $2 } - -strings :: { String } - : STRING { $1 } - | STRING strings { $1 ++ $2 } - -{ -happyError :: [Token] -> Either String a -happyError toks = - Left ("parse error in doc string: " ++ show (take 3 toks)) - --- Either monad (we can't use MonadError because GHC < 5.00 has --- an older incompatible version). -instance Monad (Either String) where - return = Right - Left l >>= _ = Left l - Right r >>= k = k r - fail msg = Left msg -} diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index aff9fbcd..d3667d6b 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -15,7 +15,7 @@ module HaddockRename ( import HaddockTypes import HaddockUtil ( unQual ) -import HsSyn +import HsSyn2 import Map ( Map ) import qualified Map hiding ( Map ) diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 990d2408..e81bf11d 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -12,8 +12,11 @@ module HaddockTypes ( DocOption(..), InstHead, ) where -import HsSyn -import Map +import HsSyn2 + +import qualified GHC as GHC + +import Data.Map -- --------------------------------------------------------------------------- -- Describing a module interface @@ -84,8 +87,8 @@ data DocOption data ExportItem = ExportDecl - HsQName -- the original name - HsDecl -- a declaration (with doc annotations) + GHC.Name -- the original name + GHC.HsDecl -- a declaration (with doc annotations) [InstHead] -- instances relevant to this declaration | ExportNoDecl -- an exported entity for which we have no documentation @@ -105,6 +108,13 @@ data ExportItem | ExportModule -- a cross-reference to another module Module +type InstHead = (HsContext,HsAsst) + type ModuleMap = Map Module Interface +type ModuleMap2 = Map GHC.Module HaddockModule -type InstHead = (HsContext,HsAsst) +data HaddockModule = HM { + hmod_options :: [DocOption], + hmod_decls :: Map Name GHC.HsDecl, + hmod_orig_exports :: [ExportItem] +} diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 0c458049..d4c495a3 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -25,11 +25,11 @@ module HaddockUtil ( html_xrefs_ref, ) where -import Binary -import HaddockLex -import HaddockParse +import Binary2 +import HaddockLex2 +import HaddockParse2 import HaddockTypes -import HsSyn +import HsSyn2 import Map ( Map ) import qualified Map hiding ( Map ) @@ -142,6 +142,42 @@ addConDocs (x:xs) doc = addConDoc x doc : xs -- --------------------------------------------------------------------------- -- Making abstract declarations +restrictTo :: [GHC.Name] -> (GHC.HsDecl GHC.Name) -> (GHC.HsDecl GHC.Name) +restrictTo names decl = case decl of + TyClD d | isDataDecl d && tcdND d == DataType -> + TyClD (d { tcdCons = restrictCons names (tcdCons d) } + TyClD d | isDataDecl d && tcdND d == NewType -> + case restrictCons names (tcdCons d) of + [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) + [con] -> TyClD (d { tcdCons = con }) + TyClD d | isClassDecl d -> + TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) }) + _ -> decl + +restrictCons :: [GHC.Name] -> [GHC.LConDecl GHC.Name] -> [GHC.LConDecl GHC.Name] +restrictCons names decls = [ d | Just d <- map keep decls ] + where keep d | con_name (unLoc d) `elem` names = + case con_details d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail fields -> Just d + | otherwise = Just (d { con_details = PrefixCon field_types }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + where + field_avail (HsRecField n _ _) = (unLoc n) `elem` names + field_types = [ ty | HsRecField n ty _ <- fields] + keep d | otherwise = Nothing + +restrictDecls :: [GHC.Name] -> [GHC.LSig GHC.Name] -> [GHC.LSig GHC.Name] +restrictDecls names decls = filter keep decls + where keep d = sigName d `elem` names + + -- ToDo: not really correct + +{- restrictTo :: [HsName] -> HsDecl -> HsDecl restrictTo names decl = case decl of HsDataDecl loc ctxt n xs cons drv doc -> @@ -177,7 +213,7 @@ restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl] restrictDecls names decls = filter keep decls where keep d = not (null (declBinders d `intersect` names)) -- ToDo: not really correct - +-} -- ----------------------------------------------------------------------------- -- Extract documentation from a declaration diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs index d7cd62a6..93baa6aa 100644 --- a/src/HsLexer.lhs +++ b/src/HsLexer.lhs @@ -17,7 +17,7 @@ module HsLexer (Token(..), lexer, parseError,isSymbol) where import HsParseMonad import HsParseUtils -import HsSyn +import HsSyn2 import Numeric ( readHex, readOct ) import Char diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs index f1423f6f..27032c37 100644 --- a/src/HsParseMonad.lhs +++ b/src/HsParseMonad.lhs @@ -10,7 +10,7 @@ \begin{code} module HsParseMonad where -import HsSyn +import HsSyn2 \end{code} \begin{code} diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs index 58f7f763..29999588 100644 --- a/src/HsParseUtils.lhs +++ b/src/HsParseUtils.lhs @@ -33,7 +33,7 @@ module HsParseUtils ( , toTyClsHsName -- HsName -> HsName ) where -import HsSyn +import HsSyn2 import HsParseMonad import Char(isDigit,isOctDigit,isHexDigit,digitToInt) diff --git a/src/HsParser.ly b/src/HsParser.ly index b62f1cae..c3edd3ce 100644 --- a/src/HsParser.ly +++ b/src/HsParser.ly @@ -17,12 +17,12 @@ ToDo: Differentiate between record updates and labeled construction. > module HsParser (parse) where > > import Monad -> import HsSyn +> import HsSyn2 > import HsParseMonad > import HsLexer > import HsParseUtils -> import HaddockLex hiding (Token) -> import HaddockParse +> import HaddockLex2 hiding (Token) +> import HaddockParse2 > import HaddockUtil hiding (splitTyConApp) > import Char ( isSpace ) > } diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs deleted file mode 100644 index cb5ec11e..00000000 --- a/src/HsSyn.lhs +++ /dev/null @@ -1,542 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: HsSyn.lhs,v 1.22 2004/08/09 11:55:07 simonmar Exp $ -% -% (c) The GHC Team, 1997-2002 -% -% A suite of datatypes describing the abstract syntax of Haskell 98. -% -% ----------------------------------------------------------------------------- - -\begin{code} -module HsSyn ( - SrcLoc(..), Module(..), HsQName(..), HsName(..), HsIdentifier(..), - HsModule(..), HsExportSpec(..), ModuleInfo(..), - HsImportDecl(..), HsImportSpec(..), HsAssoc(..), - HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..), - HsBangType(..), HsRhs(..), - HsGuardedRhs(..), HsType(..), HsContext, HsAsst, HsIPContext, HsCtxt(..), - HsLiteral(..), HsExp(..), HsPat(..), HsPatField(..), HsStmt(..), - HsFieldUpdate(..), HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..), - HsCallConv(..), HsFISafety(..), HsFunDep, - - mkHsForAllType, - - prelude_mod, main_mod, - unit_con_name, tuple_con_name, nil_con_name, - as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name, - forall_name, unsafe_name, safe_name, threadsafe_name, export_name, - stdcall_name, ccall_name, dotnet_name, - unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, - unit_tycon_qname, fun_tycon_qname, list_tycon_qname, tuple_tycon_qname, - unit_tycon, fun_tycon, list_tycon, tuple_tycon, - - emptyModuleInfo, - - hsIdentifierStr, hsAnchorNameStr, hsNameStr, - - GenDoc(..), Doc, DocMarkup(..), - markup, mapIdent, idMarkup, - docAppend, docParagraph, - ) where - -import Char (isSpace) - -data SrcLoc = SrcLoc !Int !Int FilePath -- (Line, Indentation, FileName) - deriving (Eq,Ord,Show) - -newtype Module = Module String - deriving (Eq,Ord) - -instance Show Module where - showsPrec _ (Module m) = showString m - -data HsQName - = Qual Module HsName - | UnQual HsName - deriving (Eq,Ord) - -instance Show HsQName where - showsPrec _ (Qual (Module m) s) = - showString m . showString "." . shows s - showsPrec _ (UnQual s) = shows s - -data HsName - = HsTyClsName HsIdentifier - | HsVarName HsIdentifier - deriving (Eq,Ord) - -instance Show HsName where - showsPrec p (HsTyClsName i) = showsPrec p i - showsPrec p (HsVarName i) = showsPrec p i - -data HsIdentifier - = HsIdent String - | HsSymbol String - | HsSpecial String - deriving (Eq,Ord) - -instance Show HsIdentifier where - showsPrec _ (HsIdent s) = showString s - showsPrec _ (HsSymbol s) = showString s - showsPrec _ (HsSpecial s) = showString s - -data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec]) - [HsImportDecl] [HsDecl] - (Maybe String) -- the doc options - ModuleInfo -- the info (portability etc.) - (Maybe Doc) -- the module doc. - deriving Show - -data ModuleInfo = ModuleInfo - { description :: Maybe Doc, - portability :: Maybe String, - stability :: Maybe String, - maintainer :: Maybe String - } - deriving Show - -emptyModuleInfo :: ModuleInfo -emptyModuleInfo = ModuleInfo { - description = Nothing, - portability = Nothing, - stability = Nothing, - maintainer = Nothing - } - --- Export/Import Specifications - -data HsExportSpec - = HsEVar HsQName -- variable - | HsEAbs HsQName -- T - | HsEThingAll HsQName -- T(..) - | HsEThingWith HsQName [HsQName] -- T(C_1,...,C_n) - | HsEModuleContents Module -- module M (not for imports) - | HsEGroup Int Doc -- a doc section heading - | HsEDoc Doc -- some documentation - | HsEDocNamed String -- a reference to named doc - deriving (Eq,Show) - -data HsImportDecl - = HsImportDecl SrcLoc Module Bool (Maybe Module) - (Maybe (Bool,[HsImportSpec])) - deriving (Eq,Show) - -data HsImportSpec - = HsIVar HsName -- variable - | HsIAbs HsName -- T - | HsIThingAll HsName -- T(..) - | HsIThingWith HsName [HsName] -- T(C_1,...,C_n) - deriving (Eq,Show) - -data HsAssoc - = HsAssocNone - | HsAssocLeft - | HsAssocRight - deriving (Eq,Show) - -data HsFISafety - = HsFIUnsafe - | HsFISafe - | HsFIThreadSafe - deriving (Eq,Show) - -data HsCallConv - = HsCCall - | HsStdCall - | HsDotNetCall - deriving (Eq,Show) - -data HsDecl - = HsTypeDecl SrcLoc HsName [HsName] HsType (Maybe Doc) - - | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName] - (Maybe Doc) - - | HsInfixDecl SrcLoc HsAssoc Int [HsName] - - | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName] - (Maybe Doc) - - | HsClassDecl SrcLoc HsContext HsName [HsName] [HsFunDep] [HsDecl] (Maybe Doc) - - | HsInstDecl SrcLoc HsContext HsAsst [HsDecl] - - | HsDefaultDecl SrcLoc [HsType] - - | HsTypeSig SrcLoc [HsName] HsType (Maybe Doc) - - | HsFunBind [HsMatch] - - | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] - - | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType - (Maybe Doc) - - | HsForeignExport SrcLoc HsCallConv String HsName HsType - - | HsDocCommentNext SrcLoc Doc -- a documentation annotation - | HsDocCommentPrev SrcLoc Doc -- a documentation annotation - | HsDocCommentNamed SrcLoc String Doc -- a documentation annotation - | HsDocGroup SrcLoc Int Doc -- a documentation group - deriving (Eq,Show) - -data HsMatch - = HsMatch SrcLoc HsQName [HsPat] HsRhs {-where-} [HsDecl] - deriving (Eq,Show) - -data HsConDecl - = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe Doc) - | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe Doc) - deriving (Eq,Show) - -data HsFieldDecl - = HsFieldDecl [HsName] HsBangType (Maybe Doc) - deriving (Eq,Show) - -data HsBangType - = HsBangedTy HsType - | HsUnBangedTy HsType - deriving (Eq,Show) - -data HsRhs - = HsUnGuardedRhs HsExp - | HsGuardedRhss [HsGuardedRhs] - deriving (Eq,Show) - -data HsGuardedRhs - = HsGuardedRhs SrcLoc [HsStmt] HsExp - deriving (Eq,Show) - -data HsType - = HsForAllType (Maybe [HsName]) HsIPContext HsType - | HsTyFun HsType HsType - | HsTyTuple Bool{-boxed-} [HsType] - | HsTyApp HsType HsType - | HsTyVar HsName - | HsTyCon HsQName - | HsTyDoc HsType Doc - | HsTyIP HsName HsType - deriving (Eq,Show) - -type HsFunDep = ([HsName], [HsName]) -type HsContext = [HsAsst] -type HsIPContext = [HsCtxt] - -data HsCtxt - = HsAssump HsAsst -- for multi-parameter type classes - | HsIP HsName HsType - deriving (Eq,Show) - -type HsAsst = (HsQName,[HsType]) - -data HsLiteral - = HsInt Integer - | HsChar Char - | HsString String - | HsFrac Rational - -- GHC unboxed literals: - | HsCharPrim Char - | HsStringPrim String - | HsIntPrim Integer - | HsFloatPrim Rational - | HsDoublePrim Rational - deriving (Eq, Show) - -data HsExp - = HsIPVar HsQName - | HsVar HsQName - | HsCon HsQName - | HsLit HsLiteral - | HsInfixApp HsExp HsExp HsExp - | HsApp HsExp HsExp - | HsNegApp HsExp - | HsLambda [HsPat] HsExp - | HsLet [HsDecl] HsExp - | HsIf HsExp HsExp HsExp - | HsCase HsExp [HsAlt] - | HsDo [HsStmt] - | HsTuple Bool{-boxed-} [HsExp] - | HsList [HsExp] - | HsParen HsExp - | HsLeftSection HsExp HsExp - | HsRightSection HsExp HsExp - | HsRecConstr HsQName [HsFieldUpdate] - | HsRecUpdate HsExp [HsFieldUpdate] - | HsEnumFrom HsExp - | HsEnumFromTo HsExp HsExp - | HsEnumFromThen HsExp HsExp - | HsEnumFromThenTo HsExp HsExp HsExp - | HsListComp HsExp [HsStmt] - | HsExpTypeSig SrcLoc HsExp HsType - | HsAsPat HsName HsExp -- pattern only - | HsWildCard -- ditto - | HsIrrPat HsExp -- ditto - -- HsCCall (ghc extension) - -- HsSCC (ghc extension) - deriving (Eq,Show) - -data HsPat - = HsPVar HsName - | HsPLit HsLiteral - | HsPNeg HsPat - | HsPInfixApp HsPat HsQName HsPat - | HsPApp HsQName [HsPat] - | HsPTuple Bool{-boxed-} [HsPat] - | HsPList [HsPat] - | HsPParen HsPat - | HsPRec HsQName [HsPatField] - | HsPAsPat HsName HsPat - | HsPWildCard - | HsPIrrPat HsPat - | HsPTypeSig HsPat HsType - deriving (Eq,Show) - -data HsPatField - = HsPFieldPat HsQName HsPat - deriving (Eq,Show) - -data HsStmt - = HsGenerator HsPat HsExp - | HsParStmt [HsStmt] - | HsQualifier HsExp - | HsLetStmt [HsDecl] - deriving (Eq,Show) - -data HsFieldUpdate - = HsFieldUpdate HsQName HsExp - deriving (Eq,Show) - -data HsAlt - = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] - deriving (Eq,Show) - -data HsGuardedAlts - = HsUnGuardedAlt HsExp - | HsGuardedAlts [HsGuardedAlt] - deriving (Eq,Show) - -data HsGuardedAlt - = HsGuardedAlt SrcLoc [HsStmt] HsExp - deriving (Eq,Show) - ------------------------------------------------------------------------------ --- Smart constructors - --- pinched from GHC -mkHsForAllType :: Maybe [HsName] -> HsIPContext -> 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 - 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 "()" -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) -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") -unsafe_name = HsVarName (HsIdent "unsafe") -safe_name = HsVarName (HsIdent "safe") -forall_name = HsVarName (HsIdent "forall") -threadsafe_name = HsVarName (HsIdent "threadsafe") -export_name = HsVarName (HsIdent "export") -ccall_name = HsVarName (HsIdent "ccall") -stdcall_name = HsVarName (HsIdent "stdcall") -dotnet_name = HsVarName (HsIdent "dotnet") -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) - -hsIdentifierStr :: HsIdentifier -> String -hsIdentifierStr (HsIdent str) = str -hsIdentifierStr (HsSymbol str) = str -hsIdentifierStr (HsSpecial str) = str - -hsAnchorNameStr :: HsName -> String -hsAnchorNameStr (HsTyClsName id0) = "t:" ++ hsIdentifierStr id0 -hsAnchorNameStr (HsVarName id0) = "v:" ++ hsIdentifierStr id0 - -hsNameStr :: HsName -> String -hsNameStr (HsTyClsName id0) = hsIdentifierStr id0 -hsNameStr (HsVarName id0) = hsIdentifierStr id0 - --- ----------------------------------------------------------------------------- --- Doc strings and formatting - -data GenDoc id - = DocEmpty - | DocAppend (GenDoc id) (GenDoc id) - | DocString String - | DocParagraph (GenDoc id) - | DocIdentifier id - | DocModule String - | DocEmphasis (GenDoc id) - | DocMonospaced (GenDoc id) - | DocUnorderedList [GenDoc id] - | DocOrderedList [GenDoc id] - | DocDefList [(GenDoc id, GenDoc id)] - | DocCodeBlock (GenDoc id) - | DocURL String - | DocAName String - deriving (Eq, Show) - -type Doc = GenDoc [HsQName] - --- | DocMarkup is a set of instructions for marking up documentation. --- In fact, it's really just a mapping from 'GenDoc' to some other --- type [a], where [a] is usually the type of the output (HTML, say). - -data DocMarkup id a = Markup { - markupEmpty :: a, - markupString :: String -> a, - markupParagraph :: a -> a, - markupAppend :: a -> a -> a, - markupIdentifier :: id -> a, - markupModule :: String -> a, - markupEmphasis :: a -> a, - markupMonospaced :: a -> a, - markupUnorderedList :: [a] -> a, - markupOrderedList :: [a] -> a, - markupDefList :: [(a,a)] -> a, - markupCodeBlock :: a -> a, - markupURL :: String -> a, - markupAName :: String -> a - } - -markup :: DocMarkup id a -> GenDoc id -> a -markup m DocEmpty = markupEmpty m -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 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) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocURL url) = markupURL m url -markup m (DocAName ref) = markupAName m ref - -markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - --- | The identity markup -idMarkup :: DocMarkup a (GenDoc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupModule = DocModule, - markupEmphasis = DocEmphasis, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupURL = DocURL, - markupAName = DocAName - } - --- | 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 = idMarkup{ markupIdentifier = f } - --- ----------------------------------------------------------------------------- --- ** 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) - = DocAppend (DocUnorderedList (ds1++ds2)) d -docAppend (DocOrderedList ds1) (DocOrderedList ds2) - = DocOrderedList (ds1++ds2) -docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) - = DocAppend (DocOrderedList (ds1++ds2)) d -docAppend (DocDefList ds1) (DocDefList ds2) - = DocDefList (ds1++ds2) -docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) - = DocAppend (DocDefList (ds1++ds2)) d -docAppend DocEmpty d = d -docAppend d DocEmpty = d -docAppend d1 d2 - = 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)) - | all isSpace s1 - = DocCodeBlock p -docParagraph (DocAppend (DocString s1) - (DocAppend (DocMonospaced p) (DocString s2))) - | all isSpace s1 && all isSpace s2 - = DocCodeBlock p -docParagraph (DocAppend (DocMonospaced p) (DocString s2)) - | all isSpace s2 - = DocCodeBlock p -docParagraph p - = DocParagraph p -\end{code} diff --git a/src/Main.hs b/src/Main.hs index b2ea7709..dfc5ee99 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,24 +7,19 @@ module Main (main) where -import Binary -import Digraph ---import HaddockDB -- not compiling +import HsSyn2 import HaddockHtml import HaddockHoogle -import HaddockLex -import HaddockParse import HaddockRename import HaddockTypes import HaddockUtil import HaddockVersion -import HsParseMonad -import HsParser -import HsSyn -import Map ( Map ) -import qualified Map hiding ( Map ) import Set import Paths_haddock ( getDataDir ) +import Binary2 +import Digraph2 +import HsParser +import HsParseMonad import Control.Exception ( bracket ) import Control.Monad ( when ) @@ -41,6 +36,10 @@ import System.IO ( stderr, IOMode(..), openFile, hClose, hGetContents, hPutStrLn import Foreign import Foreign.C #endif +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe + #if __GLASGOW_HASKELL__ >= 603 import System.Process @@ -51,6 +50,10 @@ import System.Directory ( doesDirectoryExist, doesFileExist ) import Control.Concurrent #endif +import qualified GHC as GHC +import Outputable +import SrcLoc + ----------------------------------------------------------------------------- -- Top-level stuff main :: IO () @@ -96,6 +99,7 @@ data Flag | Flag_IgnoreAllExports | Flag_HideModule String | Flag_UsePackage String + | Flag_GHCFlag String deriving (Eq) options :: Bool -> [OptDescr Flag] @@ -161,17 +165,21 @@ options backwardsCompat = Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE") - "the modules being processed depend on PACKAGE" + "the modules being processed depend on PACKAGE", + Option [] ["ghc-flag"] (ReqArg Flag_GHCFlag "FLAG") + "send a one-word FLAG to the Glasgow Haskell Compiler" ] run :: [Flag] -> [FilePath] -> IO () run flags files = do - when (Flag_Help `elem` flags) $ do + + whenFlag Flag_Help $ do prog <- getProgramName bye (usageInfo (usageHeader prog) (options False)) - when (Flag_Version `elem` flags) $ - bye ("Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2003\n") + whenFlag Flag_Version $ + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") let title = case [str | Flag_Heading str <- flags] of [] -> "" @@ -249,12 +257,12 @@ run flags files = do && Flag_Html `elem` flags) $ die ("-h cannot be used with --gen-index or --gen-contents") - when (Flag_GenContents `elem` flags) $ do +{- when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title package maybe_html_help_format maybe_index_url maybe_source_urls maybe_wiki_urls visible_read_ifaces prologue copyHtmlBits odir libdir css_file - +-} when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls @@ -264,7 +272,41 @@ run flags files = do when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths - parsed_mods <- mapM parse_file files + GHC.init (Just "/home/davve/dev/lib/ghc-6.5.20060608") + let ghcMode = GHC.JustTypecheck + session <- GHC.newSession ghcMode + ghcFlags <- GHC.getSessionDynFlags session + ghcFlags' <- GHC.initPackages ghcFlags + + let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] + (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags + when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") + + GHC.defaultErrorHandler ghcFlags'' $ do + GHC.setSessionDynFlags session ghcFlags'' + targets <- mapM (\s -> GHC.guessTarget s Nothing) files + GHC.setTargets session targets + + -- find out the module names of the targets, and topologically sort those modules + maybe_module_graph <- GHC.depanal session [] True + module_graph <- case maybe_module_graph of + Just module_graph -> return module_graph + Nothing -> die "Failed to load modules" + let sorted_modules = flattenSCC (topSortModuleGraph False module_graph Nothing) + let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules, GHC.ms_hspp_file modsum `elem` files ] + mb_checked_modules <- mapM (GHC.checkModule session) modules + let checked_modules = catMaybes mb_checked_modules + +{- let parsed_source = unLoc $ GHC.parsedSource (head checked_modules) + printSDoc (ppr parsed_source) defaultUserStyle +-} + + return () + -- case successFlag of + -- GHC.Succeeded -> bye "Succeeded" + -- GHC.Failed -> bye "Could not load all targets" + +{- parsed_mods <- mapM parse_file files sorted_mod_files <- sortModules (zip parsed_mods files) -- emits an error message if there are recursive modules @@ -330,7 +372,15 @@ run flags files = do -- dump an interface if requested case dump_iface of Nothing -> return () - Just fn -> dumpInterfaces these_ifaces this_doc_env fn + Just fn -> dumpInterfaces these_ifaces this_doc_env fn -} + where + whenFlag flag action = when (flag `elem` flags) action + + pprList [] = [] + pprList [x] = show x + pprList (x:xs) = show x ++ ", " ++ pprList xs + +--moduleFromFilename filename = parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = @@ -359,6 +409,7 @@ parse_file file = do Failed err -> die (file ++ ':':err ++ "\n") ) +{- getPrologue :: [Flag] -> IO (Maybe Doc) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of @@ -369,6 +420,18 @@ getPrologue flags Left err -> dieMsg err Right doc -> return (Just doc) _otherwise -> dieMsg "multiple -p/--prologue options" +-} + +getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName)) +getPrologue flags + = case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> do + str <- readFile filename + case GHC.parseHaddockComment str of + Left err -> dieMsg err + Right doc -> return (Just doc) + _otherwise -> dieMsg "multiple -p/--prologue options" -- --------------------------------------------------------------------------- -- External packages @@ -437,7 +500,7 @@ getPackageIfaces flags verbose = -- -- 2. Convert all the entity references to "doc names". These are -- the names we want to link to in the documentation. - +{- mkInterfacePhase1 :: [Flag] -> Bool -- verbose @@ -598,6 +661,7 @@ mkInterfacePhase2 verbose iface gbl_doc_env = iface_doc = orig_module_doc } -> let + -- [ The export list from the renamed output (sort of) ] exported_visible_names = [orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ] @@ -719,12 +783,113 @@ derivedInstances mdl decl = case decl of unknownConstraint :: HsQName unknownConstraint = UnQual (HsTyClsName (HsIdent "???")) +-} -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names. mkExportItems + :: ModuleMap2 + -> GHC.Module -- this module + -> GHC.NameSet -- exported names (orig) + -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps local names to declarations + -> Map GHC.Name [GHC.Name] -- sub-map for this module + -> [GHC.HsDecl GHC.Name] -- decls in the current module + -> [DocOption] + -> Maybe [GHC.IE Name] + -> Bool -- --ignore-all-exports flag + -> ErrMsgM [ExportItem] + +mkExportItems mod_map this_mod exported_names decl_map sub_map decls + opts maybe_exps ignore_all_exports + | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts + = everything_local_exported + | Just specs <- maybe_exps = do + exps <- mapM lookupExport specs + return (concat exps) + where + everything_local_exported = -- everything exported + return (fullContentsOfThisModule this_mod decls) + + lookupExport (GHC.IEVar x) = declWith x + lookupExport (GHC.IEThingAbs t) = declWith t + lookupExport (GHC.IEThingAll t) = declWith t + lookupExport (GHC.IEThingWith t cs) = declWith t + lookupExport (GHC.IEModuleContents m) = fullContentsOf m + lookupExport (GHC.IEGroup lev doc) = return [ ExportGroup lev "" doc ] + lookupExport (GHC.IEDoc doc) = return [ ExportDoc doc ] + lookupExport (GHC.IEDocNamed str) + = do r <- findNamedDoc str decls + case r of + Nothing -> return [] + Just found -> return [ ExportDoc found ] + + -- NOTE: I'm unsure about this. Currently only "External" names are considered. + declWith :: GHC.Name -> ErrMsgM [ ExportItem ] + declWith t | not (isExternalName t) = return [] + declWith t + | Just decl <- findDecl t + = return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ] + | otherwise + = return [ ExportNoDecl t t (map (Qual mdl) subs) ] + -- can't find the decl (it might be from another package), but let's + -- list the entity anyway. Later on, the renamer will change the + -- orig name into the import name, so we get a proper link to + -- the doc for this entity. + where + Just mdl = nameModule t + x = nameOccName + subs = map nameOfQName subs_qnames + subs_qnames = filter (`elem` exported_names) all_subs_qnames + + all_subs_qnames = map (Qual mdl) all_subs + + all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map + | otherwise = all_subs_of_qname mod_map t + + fullContentsOf m + | m == this_mod = return (fullContentsOfThisModule this_mod decls) + | otherwise = + case Map.lookup m mod_map of + Just hmod + | OptHide `elem` hmod_options hmod + -> return (hmod_orig_exports hmod) + | otherwise -> return [ ExportModule m ] + Nothing -> return [] -- already emitted a warning in exportedNames + + findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name) + findDecl n | not (isExternalName n) = Nothing + findDecl n = + | m == this_mod = Map.lookup n decl_map + | otherwise = + case Map.lookup m mod_map of + Just hmod -> Map.lookup n (hmod_decls hmod) + Nothing -> Nothing + where + m = nameModule n + +fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem] +fullContentsOfThisModule mdl decls = + map mkExportItem (filter keepDecl decls) + where mkExportItem (DocD (DocGroup lev doc)) = ExportGroup lev "" doc + mkExportItem decl = ExportDecl x decl [] -- NOTE: will this work? is x qualified correctly? + where Just x = GHC.getDeclMainBinder decl + +keepDecl :: GHC.HsDecl -> Bool +keepDecl (GHC.SigD _) = True +keepDecl (GHC.TyClD _) = True +keepDecl (GHC.DocD _) = True +keepDecl (GHC.ForD (GHC.ForeignImport _ _ _ _)) = True +keepDecl _ = False + +{- +--< ----------------------------------------------------------------------------- +-- Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. + +mkExportItems :: ModuleMap -> Module -- this module -> [HsQName] -- exported names (orig) @@ -803,6 +968,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls Just iface -> Map.lookup n (iface_decls iface) Nothing -> Nothing + fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem] fullContentsOfThisModule mdl decls = map mkExportItem (filter keepDecl decls) @@ -820,11 +986,70 @@ keepDecl HsDocGroup{} = True keepDecl HsForeignImport{} = True keepDecl _ = False +-} + -- Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...) +-- We put noSrcLoc everywhere in the cobbled together type signatures since +-- they aren't actually located in the soure code. + +extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name +extractDecl name mdl decl + | Just n <- getDeclMainBinder decl, n == name = decl + | otherwise = + case decl of + GHC.TyClD d | GHC.isClassDecl d -> + let matching_sigs = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] + in case matching_sigs of + [s0] -> let (n, tyvar_names) = name_and_tyvars d + in SigD (extractClassDecl n mdl tyvar_names s0) + _ -> error "internal: extractDecl" + GHC.TyClD d | GHC.isDataDecl d -> + let (n, tyvar_names) = name_and_tyvars d + in SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d)) + _ -> error "internal: extractDecl" + where + name_and_tyvars d = (GHC.unLoc (GHC.tcdLName d), hsLTyVarLocNames (GHC.tcdTyVars d)) + +toTypeNoLoc :: Located GHC.Name -> LHsType GHC.Name +toTypeNoLoc lname = mkNoLoc (GHC.HsTyVar (unLoc lname)) +mkNoLoc :: a -> Located a +mkNoLoc a = Located noSrcLoc a + +-- originally expected unqualified 1:st name, now it doesn't +extractClassDecl :: GHC.Name -> GHC.Module -> [GHC.Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name +extractClassDecl c mdl tvs0 (GHC.Located p (GHC.TypeSig lname ltype)) = case ltype of + GHC.Located _ (GHC.HsForAllTy exp tvs (GHC.Located p'' preds) ty) -> + GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs lctxt ty)) + _ -> GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp [] lctxt ltype)) + where + lctxt = mkNoLoc ctxt + ctxt = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds + +extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl" + +extractRecSel :: GHC.Located GHC.Name -> GHC.Module -> GHC.Name -> [GHC.Located GHC.Name] -> [GHC.LConDecl GHC.Name] + -> GHC.Sig Ghc.Name +extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" + +-- originally expected unqualified 3:rd name, now it doesn't +extractRecSel nm mdl t tvs (Located _ con : rest) = + case GHC.con_details con of + GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields -> + GHC.TypeSig nm (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))) + _ -> extractRecSel nm mdl t tvs rest + where + matching_fields flds = [ f | HsRecField n _ _ <- flds, n == nm ] + data_ty = mkNoLoc (foldl HsAppTy (mkNoLoc (HsTyVar t)) (map toTypeNoLoc tvs)) + +-- Sometimes the declaration we want to export is not the "main" declaration: +-- it might be an individual record selector or a class method. In these +-- cases we have to extract the required declaration (and somehow cobble +-- together a type signature for it...) +{- extractDecl :: HsName -> Module -> HsDecl -> HsDecl extractDecl name mdl decl | Just n <- declMainBinder decl, n == name = decl @@ -870,7 +1095,7 @@ extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest) nm `elem` ns ] data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs) - +-} -- ----------------------------------------------------------------------------- -- Pruning @@ -1170,7 +1395,7 @@ findNamedDoc name decls = search decls where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (HsDocCommentNamed _ name' doc : rest) + search ((DocD (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest |