diff options
Diffstat (limited to 'src/Haddock/Utils.hs')
| -rw-r--r-- | src/Haddock/Utils.hs | 44 |
1 files changed, 29 insertions, 15 deletions
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index de97ef85..b8f32589 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils @@ -13,7 +14,7 @@ module Haddock.Utils ( -- * Misc utilities - restrictTo, + restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, -- * Filename utilities @@ -70,7 +71,7 @@ import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) +import System.Exit import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -125,18 +126,24 @@ toInstalledDescription = hmi_description . instInfo restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d && tcdND d == DataType -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> - case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) - [con] -> TyClD (d { tcdCons = [con] }) - _ -> error "Should not happen" + TyClD d | isDataDecl d -> + TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) }) TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl +restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name +restrictTyDefn _ defn@(TySynonym {}) + = defn +restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons }) + | DataType <- new_or_data + = defn { td_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { td_ND = DataType, td_cons = [] } + [con] -> defn { td_cons = [con] } + _ -> error "Should not happen" restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -156,16 +163,22 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] - keep _ | otherwise = Nothing + keep _ = Nothing restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ] +emptyHsQTvs :: LHsTyVarBndrs Name +-- This function is here, rather than in HsTypes, because it *renamed*, but +-- does not necessarily have all the rigt kind variables. It is used +-- in Haddock just for printing, so it doesn't matter +emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. @@ -286,7 +299,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess +bye s = putStr s >> exitSuccess die :: String -> IO a @@ -319,7 +332,6 @@ escapeStr = escapeURIString isUnreserved -- to avoid depending on the network lib, since doing so gives a -- circular build dependency between haddock and network -- (at least if you want to build network with haddock docs) --- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs escapeURIChar :: (Char -> Bool) -> Char -> String escapeURIChar p c | p c = [c] @@ -410,13 +422,14 @@ markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocURL url) = markupURL m url +markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocExamples e) = markupExample m e @@ -436,13 +449,14 @@ idMarkup = Markup { markupIdentifier = DocIdentifier, markupIdentifierUnchecked = DocIdentifierUnchecked, markupModule = DocModule, + markupWarning = DocWarning, markupEmphasis = DocEmphasis, markupMonospaced = DocMonospaced, markupUnorderedList = DocUnorderedList, markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, - markupURL = DocURL, + markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, markupExample = DocExamples |