aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/Hidden.hs1
-rw-r--r--examples/Test.hs76
-rw-r--r--examples/Visible.hs1
-rw-r--r--haddock.cabal14
-rw-r--r--src/Binary.hs687
-rw-r--r--src/Digraph.lhs416
-rw-r--r--src/FastMutInt.hs63
-rw-r--r--src/HaddockDB.hs2
-rw-r--r--src/HaddockDevHelp.hs2
-rw-r--r--src/HaddockHH.hs2
-rw-r--r--src/HaddockHH2.hs2
-rw-r--r--src/HaddockHoogle.hs2
-rw-r--r--src/HaddockHtml.hs4
-rw-r--r--src/HaddockLex.x168
-rw-r--r--src/HaddockModuleTree.hs2
-rw-r--r--src/HaddockParse.y96
-rw-r--r--src/HaddockRename.hs2
-rw-r--r--src/HaddockTypes.hs20
-rw-r--r--src/HaddockUtil.hs46
-rw-r--r--src/HsLexer.lhs2
-rw-r--r--src/HsParseMonad.lhs2
-rw-r--r--src/HsParseUtils.lhs2
-rw-r--r--src/HsParser.ly6
-rw-r--r--src/HsSyn.lhs542
-rw-r--r--src/Main.hs267
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