(this causes -- ugly extra whitespace with some browsers). -docToHtml :: GHC.HsDoc DocName -> Html +docToHtml :: HsDoc DocName -> Html docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) -origDocToHtml :: GHC.HsDoc GHC.Name -> Html +origDocToHtml :: HsDoc Name -> Html origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) +rdrDocToHtml :: HsDoc RdrName -> Html rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) -- If there is a single paragraph, then surrounding it with
..
@@ -1637,6 +1747,7 @@ -- we have multiple paragraphs, then we want the extra whitespace to -- separate them. So we catch the single paragraph case and transform it -- here. +unParagraph :: HsDoc a -> HsDoc a unParagraph (GHC.DocParagraph d) = d --NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) --unParagraph (DocCodeBlock d) = (DocMonospaced d) @@ -1680,7 +1791,7 @@ quote h = char '`' +++ h +++ '`' -parens, brackets, braces :: Html -> Html +parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" @@ -1742,7 +1853,7 @@ case maybe_wiki_url of Nothing -> Html.emptyTable Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just mod) + let url' = spliceURL (Just fname) (Just mdl) (Just n) (Just loc) url in anchor ! [href url'] << toHtml "Comments" @@ -1753,7 +1864,7 @@ origMod = nameModule n -- Name must be documented, otherwise we wouldn't get here - Documented n mod = name + Documented n mdl = name fname = unpackFS (srcSpanFile loc) @@ -1790,30 +1901,35 @@ -- a vanilla table has width 100%, no border, no padding, no spacing -- a narrow table is the same but without width 100%. -vanillaTable, narrowTable :: Html -> Html -vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] +vanillaTable, vanillaTable2, narrowTable :: Html -> Html +vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] -narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] +narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] spacedTable1, spacedTable5 :: Html -> Html spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] -constrHdr, methHdr :: HtmlTable +constrHdr, methHdr, atHdr :: HtmlTable constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" methHdr = tda [ theclass "section4" ] << toHtml "Methods" atHdr = tda [ theclass "section4" ] << toHtml "Associated Types" instHdr :: String -> HtmlTable -instHdr id = - tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances") +instHdr id_ = + tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances") -dcolon, arrow, darrow :: Html -dcolon = toHtml "::" -arrow = toHtml "->" -darrow = toHtml "=>" -dot = toHtml "." +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + +dot :: Html +dot = toHtml "." + + s8, s15 :: HtmlTable s8 = tda [ theclass "s8" ] << noHtml s15 = tda [ theclass "s15" ] << noHtml @@ -1826,7 +1942,7 @@ -- versions) needs the name to be unescaped, while IE 7 needs it to be escaped. -- namedAnchor :: String -> Html -> Html -namedAnchor n = (anchor ! [name n]) . (anchor ! [name (escapeStr n)]) +namedAnchor n = (anchor ! [Html.name n]) . (anchor ! [Html.name (escapeStr n)]) -- @@ -1838,12 +1954,12 @@ -- use cookies from JavaScript to have a more persistent state. collapsebutton :: String -> Html -collapsebutton id = - image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ] +collapsebutton id_ = + image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html -collapsed fn id html = - fn ! [identifier id, thestyle "display:block;"] << html +collapsed fn id_ html = + fn ! [identifier id_, thestyle "display:block;"] << html -- A quote is a valid part of a Haskell identifier, but it would interfere with -- the ECMA script string delimiter used in collapsebutton above. @@ -1851,9 +1967,9 @@ collapseId nm = "i:" ++ escapeStr (getOccString nm) linkedAnchor :: String -> Html -> Html -linkedAnchor frag = anchor ! [href hr] - where hr | null frag = "" - | otherwise = '#': escapeStr frag +linkedAnchor frag = anchor ! [href hr_] + where hr_ | null frag = "" + | otherwise = '#': escapeStr frag documentCharacterEncoding :: Html documentCharacterEncoding = diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs deleted file mode 100644 --- a/src/Haddock/DocName.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Haddock.DocName where - - -import GHC -import Name -import Binary - - -data DocName = Documented Name Module | Undocumented Name - deriving Eq - - --- TODO: remove docNameOrig in favour of the NamedThing instance - -instance NamedThing DocName where - getName (Documented name _) = name - getName (Undocumented name) = name - - --- | The 'OccName' belonging to this name -docNameOcc :: DocName -> OccName -docNameOcc = nameOccName . docNameOrig - - --- | The original definition site of this name -docNameOrig :: DocName -> Name -docNameOrig (Documented name _) = name -docNameOrig (Undocumented name) = name - - -instance Binary DocName where - put_ bh (Documented name modu) = do - putByte bh 0 - put_ bh name - put_ bh modu - put_ bh (Undocumented name) = do - putByte bh 1 - put_ bh name - - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - modu <- get bh - return (Documented name modu) - 1 -> do - name <- get bh - return (Undocumented name) - _ -> error "get DocName: Bad h" diff --git a/src/Haddock/Exception.hs b/src/Haddock/Exception.hs deleted file mode 100644 --- a/src/Haddock/Exception.hs +++ /dev/null @@ -1,34 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -{-# LANGUAGE DeriveDataTypeable #-} - - -module Haddock.Exception ( - HaddockException, - throwE -) where - - -import Data.Typeable -import Control.Exception - - -data HaddockException = HaddockException String deriving Typeable - - -instance Show HaddockException where - show (HaddockException str) = str - - -throwE :: String -> a -#if __GLASGOW_HASKELL__ >= 609 -instance Exception HaddockException -throwE str = throw (HaddockException str) -#else -throwE str = throwDyn (HaddockException str) -#endif diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs deleted file mode 100644 --- a/src/Haddock/GHC.hs +++ /dev/null @@ -1,119 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Haddock.GHC ( - startGhc, - module Haddock.GHC.Typecheck, - module Haddock.GHC.Utils -) where - - -import Haddock.GHC.Typecheck -import Haddock.GHC.Utils -import Haddock.Exception -import Haddock.Options - -import Data.Foldable (foldlM) -import Data.Maybe -import Control.Monad - -import GHC -import DynFlags hiding (Option) -import Packages hiding (package) -import StaticFlags -import SrcLoc - - --- | Start a GHC session with the -haddock flag set. Also turn off --- compilation and linking. -#if __GLASGOW_HASKELL__ >= 609 -startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -startGhc libDir flags ghcActs = do - -- TODO: handle warnings? - (restFlags, _) <- parseStaticFlags (map noLoc flags) - runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags -#else -startGhc :: String -> [String] -> IO (Session, DynFlags) -startGhc libDir flags = do - restFlags <- parseStaticFlags flags - session <- newSession (Just libDir) - dynflags <- getSessionDynFlags session - do -#endif - let dynflags' = dopt_set dynflags Opt_Haddock - let dynflags'' = dynflags' { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - dynflags''' <- parseGhcFlags dynflags'' restFlags flags - defaultCleanupHandler dynflags''' $ do -#if __GLASGOW_HASKELL__ >= 609 - setSessionDynFlags dynflags''' - ghcActs dynflags''' -#else - setSessionDynFlags session dynflags''' - return (session, dynflags''') -#endif - - --- | Expose the list of packages to GHC. Then initialize GHC's package state --- and get the name of the actually loaded packages matching the supplied --- list of packages. The matching packages might be newer versions of the --- supplied ones. For each matching package, return its InstalledPackageInfo. - --- Commented out, since it is unused and doesn't build with GHC >= 6.9 -{- -loadPackages :: Session -> [String] -> IO [InstalledPackageInfo] - --- It would be better to try to get the "in scope" packages from GHC instead. --- This would make the -use-package flag unnecessary. But currently it --- seems all you can get from the GHC api is all packages that are linked in --- (i.e the closure of the "in scope" packages). - -loadPackages session pkgStrs = do - - -- expose the packages - - dfs <- getSessionDynFlags session - let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs } - setSessionDynFlags session dfs' - - -- try to parse the packages and get their names, without versions - pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs - - -- init GHC's package state - (dfs'', depPackages) <- initPackages dfs' - - -- compute the pkgIds of the loaded packages matching the - -- supplied ones - - let depPkgs = map (fromJust . unpackPackageId) depPackages - matchingPackages = [ mkPackageId pkg | pkg <- depPkgs, - pkgName pkg `elem` pkgNames ] - - -- get InstalledPackageInfos for each package - let pkgInfos = map (getPackageDetails (pkgState dfs'')) matchingPackages - - return pkgInfos - where - handleParse (Just pkg) = return (pkgName pkg) - handleParse Nothing = throwE "Could not parse package identifier" --} - --- | Try to parse dynamic GHC flags -parseGhcFlags dynflags flags origFlags = do - -- TODO: handle warnings? -#if __GLASGOW_HASKELL__ >= 609 - (dynflags', rest, _) <- parseDynamicFlags dynflags flags -#else - (dynflags', rest) <- parseDynamicFlags dynflags flags -#endif - if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags)) - else return dynflags' diff --git a/src/Haddock/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs deleted file mode 100644 --- a/src/Haddock/GHC/Typecheck.hs +++ /dev/null @@ -1,53 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Haddock.GHC.Typecheck ( - mkGhcModule -) where - - -import Haddock.Types - -import Data.Maybe -import GHC -import SrcLoc - -import Data.List - - -type CheckedMod = (Module, FilePath, FullyCheckedMod) - - -type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo) - - --- | Dig out what we want from the typechecker output -mkGhcModule :: CheckedMod -> DynFlags -> GhcModule -mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { - ghcModule = mdl, - ghcFilename = file, - ghcMbDocOpts = mbOpts, - ghcHaddockModInfo = info, - ghcMbDoc = mbDoc, - ghcGroup = group_, - ghcMbExports = mbExports, - ghcExportedNames = modInfoExports modInfo, - ghcDefinedNames = map getName $ modInfoTyThings modInfo, - ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, - ghcInstances = modInfoInstances modInfo -} - where -#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2 - HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed -#else - mbOpts = haddockOptions dynflags -#endif - (group_, _, mbExports, mbDoc, info) = renamed - (parsed, renamed, _, modInfo) = checkedMod diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs deleted file mode 100644 --- a/src/Haddock/GHC/Utils.hs +++ /dev/null @@ -1,180 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK hide #-} - - -module Haddock.GHC.Utils where - - -import Data.Char -import Data.Version -import qualified Data.Map as Map -import Control.Arrow - -import HsSyn -import SrcLoc -import Outputable -import Name -import Packages -import Module - - -unL :: Located a -> a -unL (L _ x) = x - - -reL :: a -> Located a -reL = L undefined - - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - - --- return the name of the package, with version info -modulePackageString :: Module -> String -modulePackageString = packageIdString . modulePackageId - - --- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageId pkg of - Nothing -> (packageIdString pkg, "") -#if __GLASGOW_HASKELL__ >= 609 - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) -#else - Just x -> (pkgName x, showVersion (pkgVersion x)) -#endif - where pkg = modulePackageId modu - - -mkModuleNoPackage :: String -> Module -mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str) - - -instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where - ppr m = ppr (Map.toList m) - - -isNameSym :: Name -> Bool -isNameSym = isSymOcc . nameOccName - - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - - -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing - (name:_) -> Just (unLoc name) -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing -getMainDeclBinder _ = Nothing - - -isTyClD :: HsDecl a -> Bool -isTyClD (TyClD _) = True -isTyClD _ = False - - -isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d -isClassD _ = False - - -isDocD :: HsDecl a -> Bool -isDocD (DocD _) = True -isDocD _ = False - - -isInstD :: HsDecl a -> Bool -isInstD (InstD _) = True -isInstD (TyClD d) = isFamInstDecl d -isInstD _ = False - - -declATs :: HsDecl a -> [a] -declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d -declATs _ = [] - - -pretty :: Outputable a => a -> String -pretty x = showSDoc (ppr x) - - -trace_ppr :: Outputable a => a -> b -> b -trace_ppr x y = trace (pretty x) y - - -------------------------------------------------------------------------------- --- NamedThing instances -------------------------------------------------------------------------------- - - -instance NamedThing (TyClDecl Name) where - getName = tcdName - - -instance NamedThing (ConDecl Name) where - getName = unL . con_name - - -------------------------------------------------------------------------------- --- Subordinates -------------------------------------------------------------------------------- - - -class Parent a where - children :: a -> [Name] - - -instance Parent (ConDecl Name) where - children con = - case con_details con of - RecCon fields -> map (unL . cd_fld_name) fields - _ -> [] - - -instance Parent (TyClDecl Name) where - children d - | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d - | isClassDecl d = - map (tcdName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig n _) <- tcdSigs d ] - | otherwise = [] - - --- | A parent and its children -family :: (NamedThing a, Parent a) => a -> (Name, [Name]) -family = getName &&& children - - --- | A mapping from the parent (main-binder) to its children and from each --- child to its grand-children, recursively. -families :: TyClDecl Name -> [(Name, [Name])] -families d - | isDataDecl d = family d : map (family . unL) (tcdCons d) - | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) - | otherwise = [] - - --- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] -parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] - - --- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] -parents _ _ = [] diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/GhcUtils.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.GhcUtils +-- Copyright : (c) David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Utils for dealing with types from the GHC API +----------------------------------------------------------------------------- + +module Haddock.GhcUtils where + + +import Data.Version +import qualified Data.Map as Map +import Control.Arrow +import Data.Foldable hiding (concatMap) +import Data.Traversable + +import HsSyn +import SrcLoc +import Outputable +import Name +import Packages +import Module + + +moduleString :: Module -> String +moduleString = moduleNameString . moduleName + + +-- return the name of the package, with version info +modulePackageString :: Module -> String +modulePackageString = packageIdString . modulePackageId + + +-- return the (name,version) of the package +modulePackageInfo :: Module -> (String, [Char]) +modulePackageInfo modu = case unpackPackageId pkg of + Nothing -> (packageIdString pkg, "") +#if __GLASGOW_HASKELL__ >= 609 + Just x -> (display $ pkgName x, showVersion (pkgVersion x)) +#else + Just x -> (pkgName x, showVersion (pkgVersion x)) +#endif + where pkg = modulePackageId modu + + +mkModuleNoPackage :: String -> Module +mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str) + + +instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where + ppr m = ppr (Map.toList m) + + +isNameSym :: Name -> Bool +isNameSym = isSymOcc . nameOccName + + +isVarSym :: OccName -> Bool +isVarSym = isLexVarSym . occNameFS + + +getMainDeclBinder :: HsDecl name -> Maybe name +getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder (ValD d) + = case collectAcc d [] of + [] -> Nothing + (name:_) -> Just (unLoc name) +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) +getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing +getMainDeclBinder _ = Nothing + + +isTyClD :: HsDecl a -> Bool +isTyClD (TyClD _) = True +isTyClD _ = False + + +isClassD :: HsDecl a -> Bool +isClassD (TyClD d) = isClassDecl d +isClassD _ = False + + +isDocD :: HsDecl a -> Bool +isDocD (DocD _) = True +isDocD _ = False + + +isInstD :: HsDecl a -> Bool +isInstD (InstD _) = True +isInstD (TyClD d) = isFamInstDecl d +isInstD _ = False + + +declATs :: HsDecl a -> [a] +declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d +declATs _ = [] + + +pretty :: Outputable a => a -> String +pretty x = showSDoc (ppr x) + + +trace_ppr :: Outputable a => a -> b -> b +trace_ppr x y = trace (pretty x) y + + +------------------------------------------------------------------------------- +-- Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + + +instance Foldable Located where + foldMap f (L _ x) = f x + + +instance Traversable Located where + mapM f (L l x) = (return . L l) =<< f x + + +------------------------------------------------------------------------------- +-- NamedThing instances +------------------------------------------------------------------------------- + + +instance NamedThing (TyClDecl Name) where + getName = tcdName + + +instance NamedThing (ConDecl Name) where + getName = unL . con_name + + +------------------------------------------------------------------------------- +-- Subordinates +------------------------------------------------------------------------------- + + +class Parent a where + children :: a -> [Name] + + +instance Parent (ConDecl Name) where + children con = + case con_details con of + RecCon fields -> map (unL . cd_fld_name) fields + _ -> [] + + +instance Parent (TyClDecl Name) where + children d + | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d + | isClassDecl d = + map (tcdName . unL) (tcdATs d) ++ + [ unL n | L _ (TypeSig n _) <- tcdSigs d ] + | otherwise = [] + + +-- | A parent and its children +family :: (NamedThing a, Parent a) => a -> (Name, [Name]) +family = getName &&& children + + +-- | A mapping from the parent (main-binder) to its children and from each +-- child to its grand-children, recursively. +families :: TyClDecl Name -> [(Name, [Name])] +families d + | isDataDecl d = family d : map (family . unL) (tcdCons d) + | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) + | otherwise = [] + + +-- | A mapping from child to parent +parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] + + +-- | The parents of a subordinate in a declaration +parents :: Name -> HsDecl Name -> [Name] +parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents _ _ = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -1,66 +1,68 @@ --- --- Haddock - A Haskell Documentation Tool +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- --- (c) Simon Marlow 2003 +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable -- - --- Here we build the actual module interfaces. By interface we mean the --- information that is used to render a Haddock page for a module. Parts of --- this information is also stored in the interface files. - +-- Here we build the actual module interfaces. By interface we mean the +-- information that is used to render a Haddock page for a module. Parts of +-- this information are also stored in the .haddock files. +----------------------------------------------------------------------------- module Haddock.Interface ( createInterfaces ) where -import Haddock.DocName import Haddock.Interface.Create import Haddock.Interface.AttachInstances import Haddock.Interface.Rename import Haddock.Types import Haddock.Options -import Haddock.GHC.Utils -import Haddock.GHC.Typecheck -import Haddock.Exception +import Haddock.GhcUtils import Haddock.Utils import Haddock.InterfaceFile import qualified Data.Map as Map -import Data.Map (Map) import Data.List +import Data.Maybe import Control.Monad import Control.Exception ( evaluate ) +import Distribution.Verbosity -import GHC -import Name -import HscTypes ( msHsFilePath ) +import GHC hiding (verbosity, flags) import Digraph -import BasicTypes -import SrcLoc import HscTypes -- | Turn a topologically sorted list of module names/filenames into interfaces. Also -- return the home link environment created in the process. #if __GLASGOW_HASKELL__ >= 609 -createInterfaces :: [String] -> [Flag] -> [InterfaceFile] +createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile] -> Ghc ([Interface], LinkEnv) -createInterfaces modules flags extIfaces = do +createInterfaces verbosity modules flags extIfaces = do -- part 1, create interfaces let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - interfaces <- createInterfaces' modules flags instIfaceMap + out verbosity verbose "Creating interfaces..." + interfaces <- createInterfaces' verbosity modules flags instIfaceMap #else -createInterfaces :: Session -> [String] -> [Flag] +createInterfaces :: Verbosity -> Session -> [String] -> [Flag] -> [InterfaceFile] -> IO ([Interface], LinkEnv) -createInterfaces session modules flags extIfaces = do +createInterfaces verbosity session modules flags extIfaces = do -- part 1, create interfaces let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - interfaces <- createInterfaces' session modules flags instIfaceMap + out verbosity verbose "Creating interfaces..." + interfaces <- createInterfaces' verbosity session modules flags instIfaceMap #endif -- part 2, build link environment + out verbosity verbose "Building link environment..." -- combine the link envs of the external packages into one let extLinks = Map.unions (map ifLinkEnv extIfaces) homeLinks = buildHomeLinks interfaces -- build the environment for the home @@ -69,9 +71,11 @@ allNames = Map.keys links -- part 3, attach instances + out verbosity verbose "Attaching instances..." let interfaces' = attachInstances interfaces allNames -- part 4, rename interfaces + out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags let (interfaces'', msgs) = runWriter $ mapM (renameInterface links warnings) interfaces' @@ -81,8 +85,8 @@ #if __GLASGOW_HASKELL__ >= 609 -createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -createInterfaces' modules flags instIfaceMap = do +createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createInterfaces' verbosity modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets targets modgraph <- depanal [] False @@ -97,10 +101,10 @@ modgraph' <- if needsTemplateHaskell modgraph then do dflags <- getSessionDynFlags - setSessionDynFlags dflags { hscTarget = HscC } - -- we need to set HscC on all the ModSummaries as well - let addHscC m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscC } } - return (map addHscC modgraph) + _ <- setSessionDynFlags dflags { hscTarget = HscAsm } + -- we need to set HscAsm on all the ModSummaries as well + let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } } + return (map addHscAsm modgraph) else return modgraph #else let modgraph' = modgraph @@ -108,10 +112,10 @@ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - x <- processModule modsum flags modMap instIfaceMap + x <- processModule verbosity modsum flags modMap instIfaceMap #else -createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface] -createInterfaces' session modules flags instIfaceMap = do +createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface] +createInterfaces' verbosity session modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets session targets mbGraph <- depanal session [] False @@ -120,7 +124,7 @@ Nothing -> throwE "Failed to create dependency graph" let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - x <- processModule session modsum flags modMap instIfaceMap + x <- processModule verbosity session modsum flags modMap instIfaceMap #endif case x of Just interface -> @@ -162,8 +166,9 @@ -} #if __GLASGOW_HASKELL__ >= 609 -processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface) -processModule modsum flags modMap instIfaceMap = do +processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface) +processModule verbosity modsum flags modMap instIfaceMap = do + out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum if not $ isBootSummary modsum then do @@ -177,15 +182,17 @@ typecheckedSource tc_mod, moduleInfo tc_mod)) dynflags + out verbosity verbose "Creating interface..." let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap liftIO $ mapM_ putStrLn msg - liftIO $ evaluate interface - return (Just interface) + interface' <- liftIO $ evaluate interface + return (Just interface') else return Nothing #else -processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface) -processModule session modsum flags modMap instIfaceMap = do +processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface) +processModule verbosity session modsum flags modMap instIfaceMap = do + out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." let filename = msHsFilePath modsum mbMod <- checkAndLoadModule session modsum False if not $ isBootSummary modsum @@ -201,6 +208,41 @@ return Nothing #endif + +type CheckedMod = (Module, FilePath, FullyCheckedMod) + + +type FullyCheckedMod = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo) + + +-- | Dig out what we want from the typechecker output +mkGhcModule :: CheckedMod -> DynFlags -> GhcModule +mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { + ghcModule = mdl, + ghcFilename = file, + ghcMbDocOpts = mbOpts, + ghcHaddockModInfo = info, + ghcMbDoc = mbDoc, + ghcGroup = group_, + ghcMbExports = mbExports, + ghcExportedNames = modInfoExports modInfo, + ghcDefinedNames = map getName $ modInfoTyThings modInfo, + ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, + ghcInstances = modInfoInstances modInfo +} + where +#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2 + HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed +#else + mbOpts = haddockOptions dynflags +#endif + (group_, _, mbExports, mbDoc, info) = renamed + (_, renamed, _, modInfo) = checkedMod + + -- | 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 @@ -219,6 +261,6 @@ | otherwise = foldl' keep_new old_env exported_names where exported_names = ifaceVisibleExports iface - mod = ifaceMod iface - keep_old env n = Map.insertWith (\new old -> old) n mod env - keep_new env n = Map.insert n mod env + mdl = ifaceMod iface + keep_old env n = Map.insertWith (\_ old -> old) n mdl env + keep_new env n = Map.insert n mdl env diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,18 +1,19 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - {-# LANGUAGE MagicHash #-} - +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.AttachInstances +-- Copyright : (c) David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types -import Haddock.GHC.Utils import qualified Data.Map as Map import Data.Map (Map) @@ -20,7 +21,6 @@ import GHC import Name -import SrcLoc import InstEnv import Class @@ -33,21 +33,20 @@ import Var hiding (varName) import TyCon import PrelNames -import HscTypes import FastString #define FSLIT(x) (mkFastString# (x#)) attachInstances :: [Interface] -> [Name] -> [Interface] -attachInstances modules filterNames = map attach modules +attachInstances ifaces filterNames = map attach ifaces where instMap = fmap (map toHsInstHead . sortImage instHead) $ - collectInstances modules filterNames + collectInstances ifaces filterNames - attach mod = mod { ifaceExportItems = newItems } + attach iface = iface { ifaceExportItems = newItems } where - newItems = map attachExport (ifaceExportItems mod) + newItems = map attachExport (ifaceExportItems iface) attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) | isClassDecl d || isDataDecl d || isFamilyDecl d = @@ -72,13 +71,15 @@ -> [Name] -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances -collectInstances modules filterNames +collectInstances ifaces _ -- filterNames = Map.fromListWith (flip (++)) tyInstPairs `Map.union` Map.fromListWith (flip (++)) classInstPairs where - allInstances = concat (map ifaceInstances modules) + allInstances = concatMap ifaceInstances ifaces classInstPairs = [ (is_cls inst, [instanceHead inst]) | - inst <- allInstances, Just n <- nub (is_tcs inst) ] + inst <- allInstances ] + -- unfinished filtering of internal instances + -- Just n <- nub (is_tcs inst) ] -- n `elem` filterNames ] tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] @@ -98,8 +99,8 @@ simplify (ForAllTy _ t) = simplify t simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] - simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2]) - where (SimpleType s args) = simplify t1 + simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) + where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) simplify _ = error "simplify" @@ -111,6 +112,7 @@ where cmp_fst (x,_) (y,_) = compare x y +funTyConName :: Name funTyConName = mkWiredInName gHC_PRIM (mkOccNameFS tcName FSLIT("(->)")) funTyConKey @@ -133,6 +135,7 @@ toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2) +toLHsType :: Type -> Located (HsType Name) toLHsType = noLoc . toHsType @@ -148,11 +151,11 @@ _ -> app (tycon tc) ts FunTy a b -> HsFunTy (toLHsType a) (toLHsType b) - ForAllTy v t -> cvForAll [v] t + ForAllTy v ty -> cvForAll [v] ty PredTy p -> HsPredTy (toHsPred p) where - tycon tc = HsTyVar (tyConName tc) - app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts) - cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t - cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) - tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs + tycon = HsTyVar . tyConName + app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType + cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty + cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty) + tyvarbinders = map (noLoc . UserTyVar . tyVarName) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,40 +1,33 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Create +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- - +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where import Haddock.Types import Haddock.Options -import Haddock.GHC.Utils +import Haddock.GhcUtils import Haddock.Utils import qualified Data.Map as Map import Data.Map (Map) import Data.List import Data.Maybe -import Data.Char import Data.Ord import Control.Monad -import Control.Arrow -import GHC -import Outputable -import SrcLoc +import GHC hiding (flags) import Name -import Module -import InstEnv -import Class -import TypeRep -import Var hiding (varName) -import TyCon -import PrelNames import Bag -import HscTypes -- | Process the data in the GhcModule to produce an interface. @@ -44,26 +37,26 @@ -> ErrMsgM Interface createInterface ghcMod flags modMap instIfaceMap = do - let mod = ghcModule ghcMod + let mdl = ghcModule ghcMod - opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mod + opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - let group = ghcGroup ghcMod + let group_ = ghcGroup ghcMod exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) localNames = ghcDefinedNames ghcMod - decls0 = declInfos . topDecls $ group + decls0 = declInfos . topDecls $ group_ decls = filterOutInstances decls0 declMap = mkDeclMap decls ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod instances = ghcInstances ghcMod - warnAboutFilteredDecls mod decls0 + warnAboutFilteredDecls mdl decls0 - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap + exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap opts exports ignoreExps instances instIfaceMap let visibleNames = mkVisibleNames exportItems opts @@ -76,7 +69,7 @@ | otherwise = exportItems return Interface { - ifaceMod = mod, + ifaceMod = mdl, ifaceOrigFilename = ghcFilename ghcMod, ifaceInfo = ghcHaddockModInfo ghcMod, ifaceDoc = ghcMbDoc ghcMod, @@ -102,13 +95,13 @@ mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] -mkDocOpts mbOpts flags mod = do +mkDocOpts mbOpts flags mdl = do opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] - if Flag_HideModule (moduleString mod) `elem` flags + if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts @@ -150,6 +143,7 @@ | (parent@(L _ d), doc) <- decls] +subordinates :: HsDecl Name -> [(Name, Maybe Doc)] subordinates (TyClD d) = classDataSubs d subordinates _ = [] @@ -172,21 +166,25 @@ -- All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. +classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)] classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass +declsFromClass :: TyClDecl a -> [Located (HsDecl a)] declsFromClass class_ = docs ++ defs ++ sigs ++ ats where - docs = decls tcdDocs DocD class_ - defs = decls (bagToList . tcdMeths) ValD class_ - sigs = decls tcdSigs SigD class_ - ats = decls tcdATs TyClD class_ + docs = mkDecls tcdDocs DocD class_ + defs = mkDecls (bagToList . tcdMeths) ValD class_ + sigs = mkDecls tcdSigs SigD class_ + ats = mkDecls tcdATs TyClD class_ +declName :: HsDecl a -> a declName (TyClD d) = tcdName d declName (ForD (ForeignImport n _ _)) = unLoc n -- we have normal sigs only (since they are taken from ValBindsOut) declName (SigD sig) = fromJust $ sigNameNoLoc sig +declName _ = error "unexpected argument to declName" -- | The top-level declarations of a module that we care about, @@ -195,39 +193,44 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup +filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)] filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) -- | Take all declarations except pragmas, infix decls, rules and value -- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl] -declsFromGroup group = - decls hs_tyclds TyClD group ++ - decls hs_derivds DerivD group ++ - decls hs_defds DefD group ++ - decls hs_fords ForD group ++ - decls hs_docs DocD group ++ - decls hs_instds InstD group ++ - decls (typesigs . hs_valds) SigD group +declsFromGroup group_ = + mkDecls hs_tyclds TyClD group_ ++ + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + mkDecls hs_docs DocD group_ ++ + mkDecls hs_instds InstD group_ ++ + mkDecls (typesigs . hs_valds) SigD group_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs _ = error "expected ValBindsOut" -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor -decls field con struct = [ L loc (con decl) | L loc decl <- field struct ] +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] -- | Sort by source location +sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls mod decls = do - let modStr = moduleString mod +warnAboutFilteredDecls :: Module -> [(LHsDecl Name, b, c)] -> ErrMsgM () +warnAboutFilteredDecls mdl decls = do + let modStr = moduleString mdl let typeInstances = nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] - when (not $null typeInstances) $ + unless (null typeInstances) $ tell $ nub [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families " @@ -237,9 +240,8 @@ let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls , not (null ats) ] - when (not $ null instances) $ - - tell $ nub $ [ + unless (null instances) $ + tell $ nub [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " ++ "These instances are affected:\n" ++ (concat $ intersperse ", " instances) ] @@ -271,6 +273,7 @@ where filterClass (TyClD c) = TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c } + filterClass _ = error "expected TyClD" -------------------------------------------------------------------------------- @@ -284,7 +287,7 @@ -- | Collect the docs and attach them to the right declaration. collectDocs :: [Decl] -> [(Decl, (Maybe Doc))] -collectDocs decls = collect Nothing DocEmpty decls +collectDocs = collect Nothing DocEmpty collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))] collect d doc_so_far [] = @@ -343,15 +346,17 @@ -> ErrMsgM [ExportItem Name] mkExportItems modMap this_mod exported_names decls declMap - opts maybe_exps ignore_all_exports instances instIfaceMap + opts maybe_exps ignore_all_exports _ instIfaceMap | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported - | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs + | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) where - instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] +-- creating export items for intsances (unfinished experiment) +-- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] + everything_local_exported = -- everything exported - return (fullContentsOfThisModule this_mod decls) + return (fullContentsOfThisModule decls) lookupExport (IEVar x) = declWith x @@ -363,7 +368,7 @@ -- absFam (Nothing, instances) = lookupExport (IEThingAll t) = declWith t - lookupExport (IEThingWith t cs) = declWith t + lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = fullContentsOf m lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] @@ -377,9 +382,9 @@ declWith t = case findDecl t of Just x@(decl,_,_) -> - let declName = + let declName_ = case getMainDeclBinder (unL decl) of - Just declName -> declName + Just n -> n Nothing -> error "declWith: should not happen" in case () of _ @@ -390,7 +395,7 @@ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. - | t /= declName, + | t /= declName_, Just p <- find isExported (parents t $ unL decl) -> do tell [ "Warning: " ++ moduleString this_mod ++ ": " ++ @@ -425,7 +430,7 @@ isExported n = n `elem` exported_names fullContentsOf modname - | m == this_mod = return (fullContentsOfThisModule this_mod decls) + | m == this_mod = return (fullContentsOfThisModule decls) | otherwise = case Map.lookup m modMap of Just iface @@ -473,8 +478,8 @@ -- (For more information, see Trac #69) -fullContentsOfThisModule :: Module -> [DeclInfo] -> [ExportItem Name] -fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls) +fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name] +fullContentsOfThisModule decls = catMaybes (map mkExportItem decls) where mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc @@ -498,7 +503,7 @@ -- let assocMathes = [ tyDecl | at <- tcdATs d, ] in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractClassDecl n mdl tyvar_names s0 + L pos sig = extractClassDecl n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> @@ -511,23 +516,18 @@ toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname)) - - -rmLoc :: Located a -> Located a -rmLoc a = noLoc (unLoc a) +toTypeNoLoc = noLoc . HsTyVar . unLoc -extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of - L _ (HsForAllTy exp tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty))) +extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name +extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of + L _ (HsForAllTy expl tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where - lctxt preds = noLoc (ctxt preds) - ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds - -extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl" + lctxt = noLoc . ctxt + ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name] @@ -540,7 +540,7 @@ L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ] + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) @@ -561,31 +561,9 @@ Just n -> n : subs Nothing -> subs where subs = map fst (expItemSubDocs e) - exportName e@ExportNoDecl {} = [] -- we don't count these as visible, since - -- we don't want links to go to them. + exportName ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. exportName _ = [] - - -exportModuleMissingErr this mdl - = ["Warning: in export list of " ++ show (moduleString this) - ++ ": module not found: " ++ show (moduleString mdl)] - - --- | For a given entity, find all the names it "owns" (ie. all the --- constructors and field names of a tycon, or all the methods of a --- class). -allSubsOfName :: Map Module Interface -> Name -> [Name] -allSubsOfName ifaces name = - case Map.lookup (nameModule name) ifaces of - Just iface -> subsOfName name (ifaceDeclMap iface) - Nothing -> [] - - -subsOfName :: Name -> Map Name DeclInfo -> [Name] -subsOfName n declMap = - case Map.lookup n declMap of - Just (_, _, subs) -> map fst subs - Nothing -> [] -- | Find a stand-alone documentation comment by its name diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,93 +1,92 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 +---------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Rename +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- - +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.Interface.Rename (renameInterface) where -import Haddock.DocName import Haddock.Types -import Haddock.GHC.Utils +import Haddock.GhcUtils import GHC hiding (NoLink) import Name import BasicTypes -import SrcLoc import Bag (emptyBag) -import Outputable -import Util (thenCmp) import Data.List -import Data.Map (Map) import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import Data.Traversable (mapM) -import Control.Arrow import Control.Monad hiding (mapM) renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface renamingEnv warnings mod = +renameInterface renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming -- env - let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod) - where fn env name = Map.insert name (ifaceMod mod) env - - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap mod) + let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) + where fn env name = Map.insert name (ifaceMod iface) env + + docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ] - renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') + renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- rename names in the exported declarations to point to things that -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) - = runRnFM localEnv (renameExportItems (ifaceExportItems mod)) + = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - (rnDocMap, missingNames2) + (rnDocMap, missingNames2) = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) (finalModuleDoc, missingNames3) - = runRnFM localEnv (renameMaybeDoc (ifaceDoc mod)) + = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would - -- otherwise allways be missing. + -- otherwise allways be missing. missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2 ++ missingNames3) - -- filter out certain built in type constructors using their string + -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. --- strings = filter (`notElem` ["()", "[]", "(->)"]) +-- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty missingNames) strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames - + in do -- report things that we couldn't link to. Only do this for non-hidden -- modules. - unless (OptHide `elem` ifaceOptions mod || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod mod) ++ + unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ + tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++ - " " ++ concat (map (' ':) strings) ] + unwords (" " : strings) ] - return $ mod { ifaceRnDoc = finalModuleDoc, - ifaceRnDocMap = rnDocMap, - ifaceRnExportItems = renamedExportItems } + return $ iface { ifaceRnDoc = finalModuleDoc, + ifaceRnDocMap = rnDocMap, + ifaceRnExportItems = renamedExportItems } -------------------------------------------------------------------------------- -- 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 +-- 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 +newtype GenRnM n a = + RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function -> (a,[n]) } @@ -95,34 +94,34 @@ instance Monad (GenRnM n) where (>>=) = thenRn - return = returnRn + return = returnRn returnRn :: a -> GenRnM n a -returnRn a = RnM (\_ -> (a,[])) +returnRn a = RnM (const (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)) +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])) +outRn name = RnM (const ((),[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) + (False,maps_to) -> do outRn name; return (and_then maps_to) + (True, maps_to) -> return (and_then maps_to) runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp - where +runRnFM env rn = unRn rn lkp + where lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mod -> (True, Documented n mod) + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- @@ -130,23 +129,28 @@ -------------------------------------------------------------------------------- -rename = lookupRn id -renameL (L loc name) = return . L loc =<< rename name +rename :: Name -> RnM DocName +rename = lookupRn id +renameL :: Located Name -> RnM (Located DocName) +renameL = mapM rename + + renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] -renameExportItems items = mapM renameExportItem items +renameExportItems = mapM renameExportItem renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) -renameMaybeDoc mbDoc = mapM renameDoc mbDoc +renameMaybeDoc = mapM renameDoc -renameLDoc (L loc doc) = return . L loc =<< renameDoc doc +renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName) +renameLDoc = mapM renameDoc renameDoc :: HsDoc Name -> RnM (HsDoc DocName) -renameDoc doc = case doc of +renameDoc d = case d of DocEmpty -> return DocEmpty DocAppend a b -> do a' <- renameDoc a @@ -179,21 +183,22 @@ a' <- renameDoc a b' <- renameDoc b return (a',b')) docs - return (DocDefList docs') + return (DocDefList docs') DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc') - DocURL str -> return (DocURL str) + DocURL str -> return (DocURL str) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) -renameLPred (L loc p) = return . L loc =<< renamePred p +renameLPred :: LHsPred Name -> RnM (LHsPred DocName) +renameLPred = mapM renamePred renamePred :: HsPred Name -> RnM (HsPred DocName) renamePred (HsClassP name types) = do - name' <- rename name + name' <- rename name types' <- mapM renameLType types return (HsClassP name' types') renamePred (HsEqualP type1 type2) = do @@ -206,31 +211,33 @@ return (HsIParam (IPName name') t') -renameLType (L loc t) = return . L loc =<< renameType t +renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType = mapM renameType -renameType t = case t of +renameType :: HsType Name -> RnM (HsType DocName) +renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do tyvars' <- mapM renameLTyVarBndr tyvars - lcontext' <- renameLContext lcontext + 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 + 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 + HsListTy ty -> return . HsListTy =<< renameLType ty + HsPArrTy ty -> return . HsPArrTy =<< renameLType ty HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts @@ -240,29 +247,31 @@ b' <- renameLType b return (HsOpTy a' (L loc op') b') - HsParTy t -> return . HsParTy =<< renameLType t + HsParTy ty -> return . HsParTy =<< renameLType ty HsNumTy n -> return (HsNumTy n) HsPredTy p -> return . HsPredTy =<< renamePred p - HsKindSig t k -> do - t' <- renameLType t - return (HsKindSig t' k) + HsKindSig ty k -> do + ty' <- renameLType ty + return (HsKindSig ty' k) - HsDocTy t doc -> do - t' <- renameLType t + HsDocTy ty doc -> do + ty' <- renameLType ty doc' <- renameLDoc doc - return (HsDocTy t' doc') + return (HsDocTy ty' doc') _ -> error "renameType" +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc tv) = do name' <- rename (hsTyVarName tv) return $ L loc (replaceTyVarName tv name') - + +renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName]) renameLContext (L loc context) = do context' <- mapM renameLPred context return (L loc context') @@ -276,10 +285,12 @@ return (preds', className', types') +renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl d = case d of +renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d return (TyClD d') @@ -295,13 +306,21 @@ _ -> error "renameDecl" -renameLTyClD (L loc d) = return . L loc =<< renameTyClD d +renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName) +renameLTyClD (L loc d) = return . L loc =<< renameTyClD d +renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of +#if __GLASGOW_HASKELL__ >= 611 + ForeignType lname b -> do + lname' <- renameL lname + return (ForeignType lname' b) +#else ForeignType lname a b -> do lname' <- renameL lname return (ForeignType lname' a b) +#endif TyFamily flav lname ltyvars kind -> do lname' <- renameL lname @@ -315,8 +334,8 @@ typats' <- mapM (mapM renameLType) typats cons' <- mapM renameLCon cons -- I don't think we need the derivings, so we return Nothing - return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing) - + return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing) + TySynonym lname ltyvars typats ltype -> do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars @@ -328,22 +347,25 @@ lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars - lfundeps' <- mapM renameLFunDep lfundeps + lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats -- we don't need the default methods or the already collected doc entities return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' []) - + where renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do + renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDoc mbldoc - return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_res = restype', con_doc = mbldoc' }) renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps @@ -365,18 +387,21 @@ xs' <- mapM rename xs ys' <- mapM rename ys return (L loc (xs', ys')) - + renameLSig (L loc sig) = return . L loc =<< renameSig sig - -renameSig sig = case sig of - TypeSig lname ltype -> do + +renameSig :: Sig Name -> RnM (Sig DocName) +renameSig sig = case sig of + TypeSig lname ltype -> do lname' <- renameL lname ltype' <- renameLType ltype return (TypeSig lname' ltype') -- we have filtered out all other kinds of signatures in Interface.Create + _ -> error "expected TypeSig" +renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype x) = do lname' <- renameL lname ltype' <- renameLType ltype @@ -387,18 +412,19 @@ return (ForeignExport lname' ltype' x) +renameInstD :: InstDecl Name -> RnM (InstDecl DocName) renameInstD (InstDecl ltype _ _ lATs) = do - ltype <- renameLType ltype + ltype' <- renameLType ltype lATs' <- mapM renameLTyClD lATs - return (InstDecl ltype emptyBag [] lATs') + return (InstDecl ltype' emptyBag [] lATs') renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -renameExportItem item = case item of - ExportModule mod -> return (ExportModule mod) - ExportGroup lev id doc -> do +renameExportItem item = case item of + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do doc' <- renameDoc doc - return (ExportGroup lev id doc') + return (ExportGroup lev id_ doc') ExportDecl decl doc subs instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc @@ -414,6 +440,7 @@ return (ExportDoc doc') +renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName)) renameSub (n,doc) = do n' <- rename n doc' <- mapM renameDoc doc diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,11 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} - --- --- Haddock - A Haskell Documentation Tool +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.InterfaceFile +-- Copyright : (c) David Waern 2006-2009 +-- License : BSD-like -- --- (c) Simon Marlow 2003 +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable -- - +-- Reading and writing the .haddock interface file +----------------------------------------------------------------------------- module Haddock.InterfaceFile ( InterfaceFile(..), @@ -14,29 +19,23 @@ ) where -import Haddock.DocName () import Haddock.Types -import Haddock.Utils +import Haddock.Utils hiding (out) import Data.List import Data.Word import Data.Array import Data.IORef import qualified Data.Map as Map -import System.IO -import Control.Monad import GHC hiding (NoLink) -import SrcLoc (noSrcSpan) -- tmp, GHC now exports this import Binary import Name import UniqSupply import UniqFM import IfaceEnv -import Module import HscTypes import FastMutInt -import HsDoc #if __GLASGOW_HASKELL__ >= 609 import FastString import Unique @@ -52,26 +51,13 @@ binaryInterfaceMagic = 0xD0Cface --- Since datatypes in GHC might change between patchlevel versions, --- and because we store GHC datatypes in our interface files, --- we need to make sure we version our interface files accordingly. --- --- Instead of adding one, we add five to all version numbers --- when one of our own (stored) datatypes is changed. +-- Since datatypes in the GHC API might change between major versions, and +-- because we store GHC datatypes in our interface files, we need to make sure +-- we version our interface files accordingly. binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2 -binaryInterfaceVersion = 9 -#endif -#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3 -binaryInterfaceVersion = 10 -#endif -#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 1 -binaryInterfaceVersion = 11 -#endif -#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 2 +#if __GLASGOW_HASKELL__ == 610 binaryInterfaceVersion = 12 -#endif -#if __GLASGOW_HASKELL__ == 611 +#elif __GLASGOW_HASKELL__ == 611 binaryInterfaceVersion = 13 #endif @@ -515,3 +501,26 @@ stabi <- get bh maint <- get bh return (HaddockModInfo descr porta stabi maint) + + +instance Binary DocName where + put_ bh (Documented name modu) = do + putByte bh 0 + put_ bh name + put_ bh modu + put_ bh (Undocumented name) = do + putByte bh 1 + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + modu <- get bh + return (Documented name modu) + 1 -> do + name <- get bh + return (Undocumented name) + _ -> error "get DocName: Bad h" + diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -1,8 +1,14 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.ModuleTree +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006 +-- License : BSD-like -- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -1,8 +1,16 @@ --- --- Haddock - A Haskell Documentation Tool +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Options +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- --- (c) Simon Marlow 2003 +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable -- +-- Definition of the command line interface of Haddock +----------------------------------------------------------------------------- module Haddock.Options ( @@ -15,7 +23,7 @@ import Haddock.Utils -import Haddock.Exception +import Haddock.Types import System.Console.GetOpt @@ -72,7 +80,7 @@ | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_Help - | Flag_Verbose + | Flag_Verbosity String | Flag_Version | Flag_UseContents String | Flag_GenContents @@ -84,6 +92,7 @@ | Flag_GhcLibDir String | Flag_GhcVersion | Flag_NoWarnings + | Flag_UseUnicode deriving (Eq) @@ -104,6 +113,7 @@ -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) "output in HTML", + Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle", Option [] ["html-help"] (ReqArg Flag_HtmlHelp "format") @@ -133,8 +143,8 @@ "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) "output version information and exit", - Option ['v'] ["verbose"] (NoArg Flag_Verbose) - "increase verbosity", + Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") + "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") "use a separately-generated HTML contents page", Option [] ["gen-contents"] (NoArg Flag_GenContents) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,18 +1,26 @@ {-# OPTIONS_HADDOCK hide #-} - --- --- Haddock - A Haskell Documentation Tool +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- --- (c) Simon Marlow 2003 +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable -- - +-- Types that are commonly used through-out Haddock. Some of the most +-- important types are defined here, like 'Interface' and 'DocName'. +----------------------------------------------------------------------------- module Haddock.Types where -import Haddock.DocName +import Control.Exception +import Data.Typeable import Data.Map (Map) -import qualified Data.Map as Map import GHC hiding (NoLink) import Name @@ -27,6 +35,22 @@ type DeclInfo = (Decl, Maybe Doc, [(Name, Maybe Doc)]) +-- | A 'DocName' is an identifier that may be documented. The 'Module' +-- component specifies the place which we want to link to in the documentation. +data DocName = Documented Name Module | Undocumented Name + deriving Eq + + +-- | The 'OccName' belonging to this name +docNameOcc :: DocName -> OccName +docNameOcc = nameOccName . getName + + +instance NamedThing DocName where + getName (Documented name _) = name + getName (Undocumented name) = name + + {-! for DocOption derive: Binary !-} data DocOption = OptHide -- ^ This module should not appear in the docs @@ -113,7 +137,7 @@ -- data needed during its creation. data Interface = Interface { - -- | The documented module + -- | The module represented by this interface ifaceMod :: Module, -- | The original filename for this module @@ -131,24 +155,33 @@ -- | The Haddock options for this module (prune, ignore-exports, etc) ifaceOptions :: ![DocOption], + -- | The declarations of the module. Excludes declarations that don't + -- have names (instances and stand-alone documentation comments). Includes + -- subordinate names, but they are mapped to their parent declarations. ifaceDeclMap :: Map Name DeclInfo, + + -- | Everything declared in the module (including subordinates) that has docs ifaceRnDocMap :: Map Name (HsDoc DocName), + ifaceSubMap :: Map Name [Name], ifaceExportItems :: ![ExportItem Name], ifaceRnExportItems :: [ExportItem DocName], - -- | All the names that are defined in this module + -- | All names defined in this module ifaceLocals :: ![Name], - -- | All the names that are exported by this module + -- | All names exported by this module ifaceExports :: ![Name], -- | All the visible names exported by this module -- For a name to be visible, it has to: - -- - be exported normally, and not via a full module re-exportation. - -- - have a declaration in this module or any of it's imports, with the - -- exception that it can't be from another package. + -- + -- * be exported normally, and not via a full module re-exportation. + -- + -- * have a declaration in this module or any of it's imports, with the + -- exception that it can't be from another package. + -- -- Basically, a visible name is a name that will show up in the documentation -- for this module. ifaceVisibleExports :: ![Name], @@ -161,12 +194,34 @@ -- | A smaller version of 'Interface' that we can get from the Haddock -- interface files. data InstalledInterface = InstalledInterface { + + -- | The module represented by this interface instMod :: Module, + + -- | Textual information about the module instInfo :: HaddockModInfo Name, + + -- | Everything declared in the module (including subordinates) that has docs instDocMap :: Map Name (HsDoc DocName), + + -- | All names exported by this module instExports :: [Name], + + -- | All the visible names exported by this module + -- For a name to be visible, it has to: + -- + -- * be exported normally, and not via a full module re-exportation. + -- + -- * have a declaration in this module or any of it's imports, with the + -- exception that it can't be from another package. + -- + -- Basically, a visible name is a name that will show up in the documentation + -- for this module. instVisibleExports :: [Name], + + -- | The Haddock options for this module (prune, ignore-exports, etc) instOptions :: [DocOption], + instSubMap :: Map Name [Name] } @@ -218,3 +273,22 @@ tell :: [ErrMsg] -> ErrMsgM () tell w = Writer ((), w) + + +-- Exceptions + +-- | Haddock's own exception type +data HaddockException = HaddockException String deriving Typeable + + +instance Show HaddockException where + show (HaddockException str) = str + + +throwE :: String -> a +#if __GLASGOW_HASKELL__ >= 609 +instance Exception HaddockException +throwE str = throw (HaddockException str) +#else +throwE str = throwDyn (HaddockException str) +#endif diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE PatternSignatures #-} - --- --- Haddock - A Haskell Documentation Tool --- --- (c) The University of Glasgow 2001-2002 --- (c) Simon Marlow 2003 +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Utils +-- Copyright : (c) The University of Glasgow 2001-2002, +-- Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.Utils ( @@ -15,7 +19,6 @@ toDescription, toInstalledDescription, -- * Filename utilities - basename, dirname, splitFilename3, moduleHtmlFile, nameHtmlRef, contentsHtmlFile, indexHtmlFile, frameIndexHtmlFile, @@ -41,18 +44,19 @@ -- FormatVersion, mkFormatVersion -- * MTL stuff - MonadIO(..) + MonadIO(..), + + -- * Logging + parseVerbosity, + out ) where import Haddock.Types -import Haddock.GHC.Utils +import Haddock.GhcUtils import GHC -import SrcLoc import Name -import OccName import Binary -import Module import Control.Monad ( liftM ) import Data.Char ( isAlpha, ord, chr ) @@ -68,6 +72,9 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) +import System.FilePath +import Distribution.Verbosity +import Distribution.ReadE #if __GLASGOW_HASKELL__ >= 609 import MonadUtils ( MonadIO(..) ) @@ -77,7 +84,26 @@ instance MonadIO IO where liftIO = id #endif + -- ----------------------------------------------------------------------------- +-- Logging + + +parseVerbosity :: String -> Either String Verbosity +parseVerbosity = runReadE flagToVerbosity + + +-- | Print a message to stdout, if it is not too verbose +out :: MonadIO m + => Verbosity -- ^ program verbosity + -> Verbosity -- ^ message verbosity + -> String -> m () +out progVerbosity msgVerbosity msg + | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg + | otherwise = return () + + +-- ----------------------------------------------------------------------------- -- Some Utilities @@ -122,7 +148,7 @@ -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (ConDeclField n _ _) = (unLoc n) `elem` names + field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ | otherwise = Nothing @@ -140,48 +166,6 @@ -- ----------------------------------------------------------------------------- -- Filename mangling functions stolen from s main/DriverUtil.lhs. -type Suffix = String - -splitFilename :: String -> (String,Suffix) -splitFilename f = split_longest_prefix f (=='.') - -basename :: String -> String -basename f = base where (_dir, base, _suff) = splitFilename3 f - -dirname :: String -> String -dirname f = dir where (dir, _base, _suff) = splitFilename3 f - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") -splitFilename3 :: String -> (String,String,Suffix) -splitFilename3 str - = let (dir, rest) = split_longest_prefix str isPathSeparator - (name, ext) = splitFilename rest - real_dir | null dir = "." - | otherwise = dir - in (real_dir, name, ext) - -split_longest_prefix :: String -> (Char -> Bool) -> (String,String) -split_longest_prefix s pred0 - = case pre0 of - [] -> ([], reverse suf) - (_:pre) -> (reverse pre, reverse suf) - where (suf,pre0) = break pred0 (reverse s) - -pathSeparator :: Char -#ifdef __WIN32__ -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif - moduleHtmlFile :: Module -> FilePath moduleHtmlFile mdl = case Map.lookup mdl html_xrefs of @@ -265,7 +249,7 @@ mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = f a >>= return . Just +mapMaybeM f (Just a) = liftM Just (f a) escapeStr :: String -> String escapeStr = escapeURIString isUnreserved @@ -281,7 +265,7 @@ | otherwise = '%' : myShowHex (ord c) "" where myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 (toChrHex) n r of + myShowHex n r = case showIntAtBase 16 toChrHex n r of [] -> "00" [a] -> ['0',a] cs -> cs @@ -290,7 +274,7 @@ | otherwise = chr (ord 'A' + fromIntegral (d - 10)) escapeURIString :: (Char -> Bool) -> String -> String -escapeURIString p s = concatMap (escapeURIChar p) s +escapeURIString = concatMap . escapeURIChar isUnreserved :: Char -> Bool isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") @@ -298,7 +282,7 @@ isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') -isDigitChar c = (c >= '0' && c <= '9') +isDigitChar c = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c @@ -327,7 +311,7 @@ replace :: Eq a => a -> a -> [a] -> [a] -replace a b xs = map (\x -> if x == a then b else x) xs +replace a b = map (\x -> if x == a then b else x) ----------------------------------------------------------------------------- @@ -383,7 +367,7 @@ nullFormatVersion = mkFormatVersion 0 mkFormatVersion :: Int -> FormatVersion -mkFormatVersion i = FormatVersion i +mkFormatVersion = FormatVersion instance Binary FormatVersion where put_ bh (FormatVersion i) = diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs --- a/src/Haddock/Utils/FastMutInt2.hs +++ b/src/Haddock/Utils/FastMutInt2.hs @@ -22,7 +22,6 @@ import PrelIOBase #else import GHC.Base -import GHC.IOBase #endif #if __GLASGOW_HASKELL__ < 411 @@ -36,7 +35,7 @@ newFastMutInt = IO $ \s0 -> case newByteArray# size s0 of { (# s, arr #) -> (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSINT + where !(I# size) = SIZEOF_HSINT readFastMutInt :: FastMutInt -> IO Int readFastMutInt (FastMutInt arr) = IO $ \s0 -> diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs --- a/src/Haddock/Version.hs +++ b/src/Haddock/Version.hs @@ -1,8 +1,13 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Version +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like -- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- module Haddock.Version ( projectName, projectVersion, projectUrl diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,13 +1,20 @@ -{-# LANGUAGE ForeignFunctionInterface, PatternSignatures #-} - +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like -- --- Haddock - A Haskell Documentation Tool +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable -- --- (c) Simon Marlow 2003 --- --- Ported to use the GHC API by David Waern during "Summer of Code" 2006 +-- Haddock - A Haskell Documentation Tool -- - +-- Program entry point and top-level code. +----------------------------------------------------------------------------- module Main (main) where @@ -18,10 +25,9 @@ import Haddock.Types import Haddock.Version import Haddock.InterfaceFile -import Haddock.Exception import Haddock.Options -import Haddock.GHC import Haddock.Utils +import Haddock.GhcUtils import Paths_haddock import Control.Monad @@ -31,15 +37,14 @@ #else import Control.Exception #endif -import Data.Dynamic import Data.Maybe import Data.IORef import qualified Data.Map as Map -import Data.Version import System.IO import System.Exit import System.Environment import System.FilePath +import Distribution.Verbosity #if defined(mingw32_HOST_OS) import Foreign @@ -51,13 +56,11 @@ import GHC.Paths #endif -import GHC -import DynFlags -import Bag -import ErrUtils +import GHC hiding (flags, verbosity) +import Config +import DynFlags hiding (flags, verbosity) #if __GLASGOW_HASKELL__ >= 609 import Panic (handleGhcException) -import Util import MonadUtils ( MonadIO(..) ) #else import Util hiding (handle) @@ -69,13 +72,15 @@ -------------------------------------------------------------------------------- -handleTopExceptions = +handleTopExceptions :: IO a -> IO a +handleTopExceptions = handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions +handleNormalExceptions :: IO a -> IO a handleNormalExceptions inner = handle (\exception -> do - hFlush stdout + hFlush stdout case exception of AsyncException StackOverflow -> do putStrLn "stack overflow: use -g +RTS -K