aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs4
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs91
-rw-r--r--haddock-api/src/Haddock/Interface.hs1
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs2
-rw-r--r--haddock-api/src/Haddock/Utils.hs150
6 files changed, 102 insertions, 147 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index cf7bd857..0b5e33a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -42,6 +42,7 @@ import Haddock.Utils
import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
import Control.Monad hiding (forM_)
+import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 9add4cae..d30312b7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -294,6 +294,10 @@ ppHtmlContents dflags odir doctitle _maybe_package
]
createDirectoryIfMissing True odir
writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+ where
+ -- Extract a module's short description.
+ toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
+ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 6577e08f..77d6ec39 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -20,9 +20,11 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
+import Data.Maybe ( mapMaybe )
import Haddock.Types( DocName, DocNameI )
+import BasicTypes ( PromotionFlag(..) )
import Exception
import FV
import Outputable ( Outputable, panic, showPpr )
@@ -253,6 +255,95 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
getGADTConTypeG (XConDecl nec) = noExtCon nec
+mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
+
+
+addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
+-- Add the class context to a class-op signature
+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
+ = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
+ -- The mkEmptySigWcType is suspicious
+ where
+ go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))
+ = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
+ , hst_bndrs = tvs, hst_body = go ty })
+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ = L loc (HsQualTy { hst_xqual = noExtField
+ , hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ go (L loc ty)
+ = L loc (HsQualTy { hst_xqual = noExtField
+ , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
+lHsQTyVarsToTypes tvs
+ = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ | tv <- hsQTvExplicit tvs ]
+
+
+--------------------------------------------------------------------------------
+-- * Making abstract declarations
+--------------------------------------------------------------------------------
+
+
+restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
+restrictTo names (L loc decl) = L loc $ case decl of
+ TyClD x d | isDataDecl d ->
+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD x d | isClassDecl d ->
+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
+ tcdATs = restrictATs names (tcdATs d) })
+ _ -> decl
+
+restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
+ | DataType <- new_or_data
+ = defn { dd_cons = restrictCons names cons }
+ | otherwise -- Newtype
+ = case restrictCons names cons of
+ [] -> defn { dd_ND = DataType, dd_cons = [] }
+ [con] -> defn { dd_cons = [con] }
+ _ -> error "Should not happen"
+restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
+
+restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
+ where
+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case con_args d of
+ PrefixCon _ -> Just d
+ RecCon fields
+ | all field_avail (unL fields) -> Just d
+ | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
+ -- if we have *all* the field names available, then
+ -- keep the record declaration. Otherwise degrade to
+ -- a constructor declaration. This isn't quite right, but
+ -- it's the best we can do.
+ InfixCon _ _ -> Just d
+ where
+ field_avail :: LConDeclField GhcRn -> Bool
+ field_avail (L _ (ConDeclField _ fs _ _))
+ = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
+ field_avail (L _ (XConDeclField nec)) = noExtCon nec
+ field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
+
+ keep _ = Nothing
+
+restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
+
+
+restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
+restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
+
+
-------------------------------------------------------------------------------
-- * Parenthesization
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 24568235..6775cf2b 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -43,6 +43,7 @@ import Haddock.Types
import Haddock.Utils
import Control.Monad
+import Control.Monad.IO.Class ( liftIO )
import Control.Exception (evaluate)
import Data.List (foldl', isPrefixOf, nub)
import qualified Data.Map as Map
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 17be6fa1..7b0f29f4 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -21,9 +21,9 @@ module Haddock.InterfaceFile (
import Haddock.Types
-import Haddock.Utils hiding (out)
import Control.Monad
+import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Array
import Data.IORef
import Data.List (mapAccumR)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 3eb702c9..1d213420 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -13,15 +13,9 @@
-----------------------------------------------------------------------------
module Haddock.Utils (
- -- * Misc utilities
- restrictTo, emptyHsQTvs,
- toDescription, toInstalledDescription,
- mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
-
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
contentsHtmlFile, indexHtmlFile, indexJsonFile,
- moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
haddockJsFile, jsQuickJumpFile,
quickJumpCssFile,
@@ -32,7 +26,7 @@ module Haddock.Utils (
makeAnchorId,
-- * Miscellaneous utilities
- getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ getProgramName, bye, die, escapeStr,
writeUtf8File, withTempDir,
-- * HTML cross reference mapping
@@ -45,9 +39,6 @@ module Haddock.Utils (
replace,
spanWith,
- -- * MTL stuff
- MonadIO(..),
-
-- * Logging
parseVerbosity, Verbosity(..), silent, normal, verbose, deafening,
out,
@@ -61,23 +52,21 @@ import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types
import Haddock.GhcUtils
-import BasicTypes ( PromotionFlag(..) )
import Exception (ExceptionMonad)
import GHC
import Name
-import Control.Monad ( liftM )
+import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
import Numeric ( showIntAtBase )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
-import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit
import System.Directory ( createDirectory, removeDirectoryRecursive )
-import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
+import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
@@ -85,8 +74,6 @@ import qualified System.FilePath.Posix as HtmlPath
import qualified System.Posix.Internals
#endif
-import MonadUtils ( MonadIO(..) )
-
--------------------------------------------------------------------------------
-- * Logging
@@ -129,117 +116,14 @@ out progVerbosity msgVerbosity msg
--------------------------------------------------------------------------------
--- | Extract a module's short description.
-toDescription :: Interface -> Maybe (MDoc Name)
-toDescription = fmap mkMeta . hmi_description . ifaceInfo
-
-
--- | Extract a module's short description.
-toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
-toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
-mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
-
-addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
--- Add the class context to a class-op signature
-addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
- -- The mkEmptySigWcType is suspicious
- where
- go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))
- = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
- , hst_bndrs = tvs, hst_body = go ty })
- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt ctxt, hst_body = ty })
- go (L loc ty)
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
-
- extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
- add_ctxt (L loc preds) = L loc (extra_pred : preds)
-
-addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-
-lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
-lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
- | tv <- hsQTvExplicit tvs ]
-
---------------------------------------------------------------------------------
--- * Making abstract declarations
---------------------------------------------------------------------------------
-
-
-restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
-restrictTo names (L loc decl) = L loc $ case decl of
- TyClD x d | isDataDecl d ->
- TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD x d | isClassDecl d ->
- TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
- tcdATs = restrictATs names (tcdATs d) })
- _ -> decl
-
-restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
- | DataType <- new_or_data
- = defn { dd_cons = restrictCons names cons }
- | otherwise -- Newtype
- = case restrictCons names cons of
- [] -> defn { dd_ND = DataType, dd_cons = [] }
- [con] -> defn { dd_cons = [con] }
- _ -> error "Should not happen"
-restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
-
-restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
- where
- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
- case con_args d of
- PrefixCon _ -> Just d
- RecCon fields
- | all field_avail (unL fields) -> Just d
- | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
- InfixCon _ _ -> Just d
- where
- field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField _ fs _ _))
- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
- field_avail (L _ (XConDeclField nec)) = noExtCon nec
- field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
-
- keep _ = Nothing
-
-restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-
-
-restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-
-emptyHsQTvs :: LHsQTyVars GhcRn
--- 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_ext = error "haddock:emptyHsQTvs"
- , hsq_explicit = [] }
-
-
--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
--------------------------------------------------------------------------------
-
baseName :: ModuleName -> FilePath
baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
@@ -266,13 +150,6 @@ indexHtmlFile = "doc-index.html"
indexJsonFile = "doc-index.json"
-
-moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
-moduleIndexFrameName = "modules"
-mainFrameName = "main"
-synopsisFrameName = "synopsis"
-
-
subIndexHtmlFile :: String -> String
subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
where b | all isAlpha ls = ls
@@ -346,7 +223,7 @@ quickJumpCssFile = "quick-jump.css"
getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+getProgramName = fmap (`withoutSuffix` ".bin") getProgName
where str `withoutSuffix` suff
| suff `isSuffixOf` str = take (length str - length suff) str
| otherwise = str
@@ -355,25 +232,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
bye :: String -> IO a
bye s = putStr s >> exitSuccess
-
-dieMsg :: String -> IO ()
-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
-
-
-noDieMsg :: String -> IO ()
-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
-
-
-mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
-mapSnd _ [] = []
-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
-
-
-mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM _ Nothing = return Nothing
-mapMaybeM f (Just a) = liftM Just (f a)
-
-
escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:09:12 +0000