diff options
| -rw-r--r-- | haddock.cabal | 5 | ||||
| -rw-r--r-- | src/Haddock/Backends/DevHelp.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Backends/Html.hs | 22 | ||||
| -rw-r--r-- | src/Haddock/GHC/Typecheck.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Interface.hs | 15 | ||||
| -rw-r--r-- | src/Haddock/Packages.hs | 4 | ||||
| -rw-r--r-- | src/Haddock/Syntax/Rename.hs | 333 | ||||
| -rw-r--r-- | src/Haddock/Types.hs | 4 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 4 |
10 files changed, 31 insertions, 362 deletions
diff --git a/haddock.cabal b/haddock.cabal index e97da9c0..d2653179 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -22,9 +22,9 @@ extensions: CPP, PatternGuards ghc-options: -fglasgow-exts hs-source-dirs: src exposed-modules: - Distribution.Haddock - Haddock.Types + Distribution.Haddock other-modules: + Haddock.Types Haddock.InterfaceFile Haddock.Exception data-files: @@ -78,6 +78,7 @@ ghc-options: -fglasgow-exts other-modules: Haddock.Interface.Rename Haddock.Interface.Create + Haddock.Interface.AttachInstances Haddock.Utils.FastMutInt2 Haddock.Utils.BlockTable Haddock.Utils.Html diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs index 9441d4a9..e92037f1 100644 --- a/src/Haddock/Backends/DevHelp.hs +++ b/src/Haddock/Backends/DevHelp.hs @@ -18,7 +18,7 @@ import Data.Maybe ( fromMaybe ) import qualified Data.Map as Map import Text.PrettyPrint -ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO () +ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO () ppDevHelpFile odir doctitle maybe_package modules = do let devHelpFile = package++".devhelp" tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ] diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index b49bf213..02a2e5c1 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -21,8 +21,8 @@ import Haddock.ModuleTree import Haddock.Types import Haddock.Version import Haddock.Utils -import Haddock.Utils.GHC import Haddock.Utils.Html +import Haddock.GHC.Utils import qualified Haddock.Utils.Html as Html import Control.Exception ( bracket ) @@ -55,7 +55,7 @@ type WikiURLs = (Maybe String, Maybe String, Maybe String) ppHtml :: String -> Maybe String -- package - -> [HaddockModule] + -> [Interface] -> FilePath -- destination directory -> Maybe (GHC.HsDoc GHC.RdrName) -- prologue text, maybe -> Maybe String -- the Html Help format (--html-help) @@ -93,7 +93,7 @@ ppHtml doctitle maybe_package hmods odir prologue maybe_html_help_format ppHtmlHelpFiles :: String -- doctitle -> Maybe String -- package - -> [HaddockModule] + -> [Interface] -> FilePath -- destination directory -> Maybe String -- the Html Help format (--html-help) -> [FilePath] -- external packages paths @@ -150,7 +150,7 @@ footer = toHtml ("version " ++ projectVersion) ) -srcButton :: SourceURLs -> Maybe HaddockModule -> HtmlTable +srcButton :: SourceURLs -> Maybe Interface -> HtmlTable srcButton (Just src_base_url, _, _) Nothing = topButBox (anchor ! [href src_base_url] << toHtml "Source code") @@ -232,7 +232,7 @@ simpleHeader doctitle maybe_contents_url maybe_index_url contentsButton maybe_contents_url <-> indexButton maybe_index_url )) -pageHeader :: String -> HaddockModule -> String +pageHeader :: String -> Interface -> String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> HtmlTable pageHeader mdl hmod doctitle @@ -257,7 +257,7 @@ pageHeader mdl hmod doctitle ) ) -moduleInfo :: HaddockModule -> HtmlTable +moduleInfo :: Interface -> HtmlTable moduleInfo hmod = let info = hmod_info hmod @@ -291,7 +291,7 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [HaddockModule] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) + -> [Interface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) -> IO () ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url @@ -392,7 +392,7 @@ mkNode ss (Node s leaf pkg short ts) depth id = htmlNode (u,id') = mkNode (s:ss) x (depth+1) id -- The URL for source and wiki links, and the current module -type LinksInfo = (SourceURLs, WikiURLs, HaddockModule) +type LinksInfo = (SourceURLs, WikiURLs, Interface) -- --------------------------------------------------------------------------- @@ -405,7 +405,7 @@ ppHtmlIndex :: FilePath -> Maybe String -> SourceURLs -> WikiURLs - -> [HaddockModule] + -> [Interface] -> IO () ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url maybe_source_url maybe_wiki_url modules = do @@ -524,7 +524,7 @@ ppHtmlModule :: FilePath -> String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String - -> HaddockModule -> IO () + -> Interface -> IO () ppHtmlModule odir doctitle maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url hmod = do @@ -545,7 +545,7 @@ ppHtmlModule odir doctitle ) writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html) -hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable +hmodToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable hmodToHtml maybe_source_url maybe_wiki_url hmod = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) where diff --git a/src/Haddock/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs index e8e291ad..59422fe0 100644 --- a/src/Haddock/GHC/Typecheck.hs +++ b/src/Haddock/GHC/Typecheck.hs @@ -11,8 +11,8 @@ module Haddock.GHC.Typecheck ( import Haddock.Exception -import Haddock.Utils.GHC import Haddock.Types +import Haddock.GHC.Utils import Data.Maybe import Control.Monad diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index aed4af34..41a73480 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -2,10 +2,10 @@ -- Haddock.Interface -- -- Here we build the actual module interfaces. By interface we mean the --- information which is used to render a Haddock page for a module. Parts of +-- information that is used to render a Haddock page for a module. Parts of -- this information is also stored in the interface files. -- --- The HaddockModule structure holds the interface data as well as +-- The Interface structure holds the interface data as well as -- intermediate information needed during its creation. ------------------------------------------------------------------------------- @@ -35,7 +35,7 @@ import Name -- return the home link environment created in the process, and any error -- messages. createInterfaces :: [GhcModule] -> LinkEnv -> [Flag] -> - ([HaddockModule], LinkEnv, [ErrMsg]) + ([Interface], LinkEnv, [ErrMsg]) createInterfaces modules extLinks flags = (interfaces, homeLinks, messages) where ((interfaces, homeLinks), messages) = runWriter $ do @@ -47,7 +47,7 @@ createInterfaces modules extLinks flags = (interfaces, homeLinks, messages) renameInterfaces interfaces' extLinks -createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [HaddockModule] +createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [Interface] createInterfaces' modules flags = do resultMap <- foldM addInterface Map.empty modules return (Map.elems resultMap) @@ -58,14 +58,15 @@ createInterfaces' modules flags = do return $ Map.insert (hmod_mod interface) interface map -renameInterfaces :: [HaddockModule] -> LinkEnv -> - ErrMsgM ([HaddockModule], LinkEnv) +renameInterfaces :: [Interface] -> LinkEnv -> + ErrMsgM ([Interface], LinkEnv) renameInterfaces interfaces externalLinks = do let homeLinks = buildHomeLinks interfaces let links = homeLinks `Map.union` externalLinks interfaces' <- mapM (renameInterface links) interfaces return (interfaces', homeLinks) + -- | Build a mapping which for each original name, points to the "best" -- place to link to in the documentation. For the definition of -- "best", we use "the module nearest the bottom of the dependency @@ -74,7 +75,7 @@ renameInterfaces interfaces externalLinks = do -- -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. -buildHomeLinks :: [HaddockModule] -> LinkEnv +buildHomeLinks :: [Interface] -> LinkEnv buildHomeLinks modules = foldl upd Map.empty (reverse modules) where upd old_env mod diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs index c2de11b4..d722bdfe 100644 --- a/src/Haddock/Packages.hs +++ b/src/Haddock/Packages.hs @@ -28,8 +28,8 @@ import Module import Packages --- | Represents the installed Haddock information for a package. --- This is basically the contents of the .haddock file, the path +-- | This structure represents the installed Haddock information for a +-- package. This is basically the contents of the .haddock file, the path -- to the html files and the list of modules in the package data HaddockPackage = HaddockPackage { pdModules :: [Module], diff --git a/src/Haddock/Syntax/Rename.hs b/src/Haddock/Syntax/Rename.hs deleted file mode 100644 index 81dfb1cc..00000000 --- a/src/Haddock/Syntax/Rename.hs +++ /dev/null @@ -1,333 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Haddock.Syntax.Rename ( - runRnFM, -- the monad (instance of Monad) - renameDoc, renameMaybeDoc, renameExportItems, -) where - - -import Haddock.Types - -import GHC hiding ( NoLink ) -import Name -import BasicTypes -import SrcLoc -import Bag ( emptyBag ) - -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Prelude hiding ( mapM ) -import Data.Traversable ( mapM ) -import Control.Arrow - - --- ----------------------------------------------------------------------------- --- Monad for renaming - --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. - -newtype GenRnM n a = - RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function - -> (a,[n]) - } - -type RnM a = GenRnM Name a - -instance Monad (GenRnM n) where - (>>=) = thenRn - return = returnRn - -returnRn :: a -> GenRnM n a -returnRn a = RnM (\_ -> (a,[])) -thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) -outRn :: Name -> RnM () -outRn name = RnM (\_ -> ((),[name])) - -lookupRn :: (DocName -> a) -> Name -> RnM a -lookupRn and_then name = do - lkp <- getLookupRn - case lkp name of - (False,maps_to) -> do outRn name; return (and_then maps_to) - (True, maps_to) -> return (and_then maps_to) - -newtype OrdName = MkOrdName Name - -instance Eq OrdName where - (MkOrdName a) == (MkOrdName b) = a == b - -instance Ord OrdName where - (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b - -runRnFM :: Map Name Name -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp - where - lkp n = case Map.lookup (MkOrdName n) ordEnv of - Nothing -> (False, NoLink n) - Just (MkOrdName q) -> (True, Link q) - - ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env - --- ----------------------------------------------------------------------------- --- Renaming - -keep n = NoLink n -keepL (L loc n) = L loc (NoLink n) - -rename = lookupRn id -renameL (L loc name) = return . L loc =<< rename name - -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] -renameExportItems items = mapM renameExportItem items - -renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) -renameMaybeDoc mbDoc = mapM renameDoc mbDoc - -renameLDoc (L loc doc) = return . L loc =<< renameDoc doc - -renameDoc :: HsDoc Name -> RnM (HsDoc DocName) -renameDoc doc = case doc of - DocEmpty -> return DocEmpty - DocAppend a b -> do - a' <- renameDoc a - b' <- renameDoc b - return (DocAppend a' b') - DocString str -> return (DocString str) - DocParagraph doc -> do - doc' <- renameDoc doc - return (DocParagraph doc') - DocIdentifier ids -> do - lkp <- getLookupRn - case [ n | (True, n) <- map lkp ids ] of - ids'@(_:_) -> return (DocIdentifier ids') - [] -> return (DocIdentifier (map NoLink ids)) - DocModule str -> return (DocModule str) - DocEmphasis doc -> do - doc' <- renameDoc doc - return (DocEmphasis doc') - DocMonospaced doc -> do - doc' <- renameDoc doc - return (DocMonospaced doc') - DocUnorderedList docs -> do - docs' <- mapM renameDoc docs - return (DocUnorderedList docs') - DocOrderedList docs -> do - docs' <- mapM renameDoc docs - return (DocOrderedList docs') - DocDefList docs -> do - docs' <- mapM (\(a,b) -> do - a' <- renameDoc a - b' <- renameDoc b - return (a',b')) docs - return (DocDefList docs') - DocCodeBlock doc -> do - doc' <- renameDoc doc - return (DocCodeBlock doc') - DocURL str -> return (DocURL str) - DocAName str -> return (DocAName str) - -renameLPred (L loc p) = return . L loc =<< renamePred p - -renamePred :: HsPred Name -> RnM (HsPred DocName) -renamePred (HsClassP name types) = do - name' <- rename name - types' <- mapM renameLType types - return (HsClassP name' types') -renamePred (HsIParam (IPName name) t) = do - name' <- rename name - t' <- renameLType t - return (HsIParam (IPName name') t') - -renameLType (L loc t) = return . L loc =<< renameType t - -renameType t = case t of - HsForAllTy expl tyvars lcontext ltype -> do - tyvars' <- mapM renameLTyVarBndr tyvars - lcontext' <- renameLContext lcontext - ltype' <- renameLType ltype - return (HsForAllTy expl tyvars' lcontext' ltype') - - HsTyVar n -> return . HsTyVar =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype - - HsAppTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsAppTy a' b') - - HsFunTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsFunTy a' b') - - HsListTy t -> return . HsListTy =<< renameLType t - HsPArrTy t -> return . HsPArrTy =<< renameLType t - - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - - HsOpTy a (L loc op) b -> do - op' <- rename op - a' <- renameLType a - b' <- renameLType b - return (HsOpTy a' (L loc op') b') - - HsParTy t -> return . HsParTy =<< renameLType t - - HsNumTy n -> return (HsNumTy n) - - HsPredTy p -> return . HsPredTy =<< renamePred p - - HsKindSig t k -> do - t' <- renameLType t - return (HsKindSig t' k) - - HsDocTy t doc -> do - t' <- renameLType t - doc' <- renameLDoc doc - return (HsDocTy t' doc') - - _ -> error "renameType" - -renameLTyVarBndr (L loc tv) = do - name' <- rename (hsTyVarName tv) - return $ L loc (replaceTyVarName tv name') - -renameLContext (L loc context) = do - context' <- mapM renameLPred context - return (L loc context') - -renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (preds, className, types) = do - preds' <- mapM renamePred preds - className' <- rename className - types' <- mapM renameType types - return (preds', className', types') - -renameLDecl (L loc d) = return . L loc =<< renameDecl d - -renameDecl d = case d of - TyClD d -> do - d' <- renameTyClD d - return (TyClD d') - SigD s -> do - s' <- renameSig s - return (SigD s') - ForD d -> do - d' <- renameForD d - return (ForD d') - _ -> error "renameDecl" - -renameTyClD d = case d of - ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported - -- ForeignType name a b -> do - -- name' <- renameL name - -- return (ForeignType name' a b) - - TyData x lcontext lname ltyvars _ k cons _ -> do - lcontext' <- renameLContext lcontext - ltyvars' <- mapM renameLTyVarBndr ltyvars - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - -- We skip the type patterns too. TODO: find out what they are :-) - return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) - - TySynonym lname ltyvars typat ltype -> do - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - -- We skip type patterns here as well. - return (TySynonym (keepL lname) ltyvars' Nothing ltype') - - ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do - lcontext' <- renameLContext lcontext - ltyvars' <- mapM renameLTyVarBndr ltyvars - lfundeps' <- mapM renameLFunDep lfundeps - lsigs' <- mapM renameLSig lsigs - -- we don't need the default methods or the already collected doc entities - -- we skip the ATs for now. - return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] []) - - where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do - ltyvars' <- mapM renameLTyVarBndr ltyvars - lcontext' <- renameLContext lcontext - details' <- renameDetails details - restype' <- renameResType restype - mbldoc' <- mapM renameLDoc mbldoc - return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') - - renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - - renameField (ConDeclField name t doc) = do - t' <- renameLType t - doc' <- mapM renameLDoc doc - return (ConDeclField (keepL name) t' doc') - - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - - renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys)) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - -renameSig sig = case sig of - TypeSig (L loc name) ltype -> do - ltype' <- renameLType ltype - return (TypeSig (L loc (keep name)) ltype') -{- SpecSig lname ltype x -> do - lname' <- renameL lname - ltype' <- renameLType ltype - return (SpecSig lname' ltype' x) - InlineSig lname x -> do - lname' <- renameL lname - return (InlineSig lname' x) - SpecInstSig t -> return . SpecInstSig =<< renameLType t - FixSig fsig -> return . FixSig =<< renameFixitySig fsig - where - renameFixitySig (FixitySig lname x) = do - lname' <- renameL lname - return (FixitySig lname' x) --} - -renameForD (ForeignImport lname ltype x) = do - ltype' <- renameLType ltype - return (ForeignImport (keepL lname) ltype' x) -renameForD (ForeignExport lname ltype x) = do - ltype' <- renameLType ltype - return (ForeignExport (keepL lname) ltype' x) - -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -renameExportItem item = case item of - ExportModule mod -> return (ExportModule mod) - ExportGroup lev id doc -> do - doc' <- renameDoc doc - return (ExportGroup lev id doc') - ExportDecl x decl doc instances -> do - decl' <- renameLDecl decl - doc' <- mapM renameDoc doc - instances' <- mapM renameInstHead instances - return (ExportDecl x decl' doc' instances') - ExportNoDecl x y subs -> do - y' <- lookupRn id y - subs' <- mapM (lookupRn id) subs - return (ExportNoDecl x y' subs') - ExportDoc doc -> do - doc' <- renameDoc doc - return (ExportDoc doc') diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 44e8d7fd..8b2cfa34 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -75,7 +75,7 @@ data ExportItem name type InstHead name = ([HsPred name], name, [HsType name]) -type ModuleMap = Map Module HaddockModule +type ModuleMap = Map Module Interface type DocMap = Map Name (HsDoc DocName) type LinkEnv = Map Name Name @@ -108,7 +108,7 @@ data GhcModule = GhcModule { -- structure (see Haddock.Interface). -- -- The structure also holds intermediate data needed during its creation. -data HaddockModule = HM { +data Interface = Interface { -- | A value to identify the module hmod_mod :: Module, diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 52618c30..81549c90 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -61,7 +61,7 @@ import System.IO.Unsafe ( unsafePerformIO ) -- Some Utilities -- | extract a module's short description. -toDescription :: HaddockModule -> Maybe (HsDoc Name) +toDescription :: Interface -> Maybe (HsDoc Name) toDescription = hmi_description . hmod_info -- --------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index c127f773..b12c7850 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -92,7 +92,7 @@ handleGhcExceptions inner = ------------------------------------------------------------------------------- --- Top-level +-- Top level ------------------------------------------------------------------------------- @@ -142,7 +142,7 @@ main = handleTopExceptions $ do -- | Render the interfaces with whatever backend is specified in the flags -render :: [Flag] -> [HaddockModule] -> IO () +render :: [Flag] -> [Interface] -> IO () render flags interfaces = do let title = case [str | Flag_Heading str <- flags] of |