aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock.hs7
-rw-r--r--src/Haddock/Interface/Create.hs129
-rw-r--r--src/Haddock/Interface/LexParseRn.hs53
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs46
-rw-r--r--src/Haddock/Parser.hs17
5 files changed, 105 insertions, 147 deletions
diff --git a/src/Haddock.hs b/src/Haddock.hs
index 78844c96..3d049b18 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -448,11 +448,8 @@ getPrologue dflags flags =
[filename] -> withFile filename ReadMode $ \h -> do
hSetEncoding h utf8
str <- hGetContents h
- case parseParasMaybe dflags str of
- Nothing ->
- throwE $ "failed to parse haddock prologue from file: " ++ filename
- Just doc -> return (Just doc)
- _otherwise -> throwE "multiple -p/--prologue options"
+ return . Just $ parseParas dflags str
+ _ -> throwE "multiple -p/--prologue options"
#ifdef IN_GHC_TREE
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 08810d6e..bc615cde 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# LANGUAGE TupleSections, BangPatterns, LambdaCase #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -29,11 +29,11 @@ import Data.Maybe
import Data.Monoid
import Data.Ord
import Control.Applicative
+import Control.Arrow (second)
import Control.DeepSeq
import Control.Monad
import Data.Function (on)
import qualified Data.Foldable as F
-import qualified Data.Traversable as T
import qualified Packages
import qualified Module
@@ -44,7 +44,7 @@ import Name
import Bag
import RdrName
import TcRnTypes
-import FastString (unpackFS, concatFS)
+import FastString (concatFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -89,15 +89,14 @@ createInterface tm flags modMap instIfaceMap = do
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
- maps@(!docMap, !argMap, !subMap, !declMap, _) <-
- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
+ maps@(!docMap, !argMap, !subMap, !declMap, _) =
+ mkMaps dflags gre localInsts declsWithDocs
let exports0 = fmap (reverse . map unLoc) mayExports
exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
-
- warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+ | OptIgnoreExports `elem` opts = Nothing
+ | otherwise = exports0
+ warningMap = mkWarningMap dflags warnings gre exportedNames
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
@@ -121,8 +120,7 @@ createInterface tm flags modMap instIfaceMap = do
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
-
- modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+ modWarn = moduleWarning dflags gre warnings
return $! Interface {
ifaceMod = mdl
@@ -182,35 +180,27 @@ lookupModuleDyn dflags Nothing mdlName =
-- Warnings
-------------------------------------------------------------------------------
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
mkWarningMap dflags warnings gre exps = case warnings of
- NoWarnings -> return M.empty
- WarnAll _ -> return M.empty
- WarnSome ws -> do
+ NoWarnings -> M.empty
+ WarnAll _ -> M.empty
+ WarnSome ws ->
let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
, let n = gre_name elt, n `elem` exps ]
- M.fromList <$> mapM parse ws'
- where
- parse (n, w) = (,) n <$> parseWarning dflags gre w
-
-
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
-moduleWarning dflags gre ws =
- case ws of
- NoWarnings -> return Nothing
- WarnSome _ -> return Nothing
- WarnAll w -> Just <$> parseWarning dflags gre w
-
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
-parseWarning dflags gre w = do
- r <- case w of
- (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
- (WarningTxt msg) -> format "Warning: " (concatFS msg)
- r `deepseq` return r
+ in M.fromList $ map (second $ parseWarning dflags gre) ws'
+
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
+moduleWarning _ _ NoWarnings = Nothing
+moduleWarning _ _ (WarnSome _) = Nothing
+moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
+parseWarning dflags gre w = force $ case w of
+ DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
+ WarningTxt msg -> format "Warning: " (concatFS msg)
where
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
- . fromMaybe (DocString . unpackFS $ xs)
- <$> processDocString dflags gre (HsDocString xs)
+ . processDocString dflags gre $ HsDocString xs
-------------------------------------------------------------------------------
@@ -258,35 +248,44 @@ mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Name]
-> [(LHsDecl Name, [HsDocString])]
- -> ErrMsgM Maps
-mkMaps dflags gre instances decls = do
- (a, b, c, d) <- unzip4 <$> mapM mappings decls
- return (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+ -> Maps
+mkMaps dflags gre instances decls =
+ let (a, b, c, d) = unzip4 $ map mappings decls
+ in (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
where
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
- mappings (ldecl, docStrs) = do
+ mappings :: (LHsDecl Name, [HsDocString])
+ -> ( [(Name, Doc Name)]
+ , [(Name, Map Int (Doc Name))]
+ , [(Name, [Name])]
+ , [(Name, [LHsDecl Name])]
+ )
+ mappings (ldecl, docStrs) =
let L l decl = ldecl
- let declDoc strs m = do
- doc <- processDocStrings dflags gre strs
- m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
- return (doc, m')
- (doc, args) <- declDoc docStrs (typeDocs decl)
- let subs = subordinates instanceMap decl
- (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
- let ns = names l decl
+ declDoc :: [HsDocString] -> Map Int HsDocString
+ -> (Maybe (Doc Name), Map Int (Doc Name))
+ declDoc strs m =
+ let doc' = processDocStrings dflags gre strs
+ m' = M.map (processDocStringParas dflags gre) m
+ in (doc', m')
+ (doc, args) = declDoc docStrs (typeDocs decl)
+ subs :: [(Name, [HsDocString], Map Int HsDocString)]
+ subs = subordinates instanceMap decl
+ (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+ ns = names l decl
subNs = [ n | (n, _, _) <- subs ]
dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
sm = [ (n, subNs) | n <- ns ]
cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
- seqList ns `seq`
+ in seqList ns `seq`
seqList subNs `seq`
doc `seq`
seqList subDocs `seq`
seqList subArgs `seq`
- return (dm, am, sm, cm)
+ (dm, am, sm, cm)
instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -499,24 +498,16 @@ mkExportItems
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
- lookupExport (IEGroup lev docStr) = liftErrMsg $
- ifDoc (processDocString dflags gre docStr)
- (\doc -> return [ ExportGroup lev "" doc ])
- lookupExport (IEDoc docStr) = liftErrMsg $
- ifDoc (processDocStringParas dflags gre docStr)
- (\doc -> return [ ExportDoc doc ])
- lookupExport (IEDocNamed str) = liftErrMsg $
- ifDoc (findNamedDoc str [ unL d | d <- decls ])
- (\docStr ->
- ifDoc (processDocStringParas dflags gre docStr)
- (\doc -> return [ ExportDoc doc ]))
+ lookupExport (IEGroup lev docStr) = return $
+ return . ExportGroup lev "" $ processDocString dflags gre docStr
+ lookupExport (IEDoc docStr) = return $
+ return . ExportDoc $ processDocStringParas dflags gre docStr
- ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]
- ifDoc parse finish = do
- mbDoc <- parse
- case mbDoc of Nothing -> return []; Just doc -> finish doc
-
+ lookupExport (IEDocNamed str) = liftErrMsg $
+ findNamedDoc str [ unL d | d <- decls ] >>= return . \case
+ Nothing -> []
+ Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
@@ -728,11 +719,9 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- mbDoc <- liftErrMsg $ processDocString dflags gre docStr
- return $ fmap (ExportGroup lev "") mbDoc
+ return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
- return $ fmap ExportDoc mbDoc
+ return . Just . ExportDoc $ processDocStringParas dflags gre docStr
mkExportItem (L l (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index d9d4ae58..54c7351d 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -21,8 +21,7 @@ module Haddock.Interface.LexParseRn
import Control.Applicative
import Data.IntSet (toList)
import Data.List
-import Data.Maybe
-import Data.Monoid ((<>))
+import Data.Monoid (mconcat)
import DynFlags (ExtensionFlag(..), languageExtensions)
import FastString
import GHC
@@ -33,34 +32,27 @@ import Name
import Outputable (showPpr)
import RdrName
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-processDocStrings dflags gre strs = do
- docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
- let doc = foldl' (<>) DocEmpty docs
- case doc of
- DocEmpty -> return Nothing
- _ -> return (Just doc)
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
+processDocStrings dflags gre strs =
+ case mconcat $ map (processDocStringParas dflags gre) strs of
+ DocEmpty -> Nothing
+ x -> Just x
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-processDocStringParas = process parseParasMaybe
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocStringParas = process parseParas
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-processDocString = process parseStringMaybe
-process :: (DynFlags -> String -> Maybe (Doc RdrName))
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString = process parseString
+
+process :: (DynFlags -> String -> Doc RdrName)
-> DynFlags
-> GlobalRdrEnv
-> HsDocString
- -> ErrMsgM (Maybe (Doc Name))
-process parse dflags gre (HsDocString fs) = do
- let str = unpackFS fs
- case parse dflags str of
- Nothing -> do
- tell [ "doc comment parse failed: " ++ str ]
- return Nothing
- Just doc -> do
- return (Just (rename dflags gre doc))
+ -> Doc Name
+process parse dflags gre (HsDocString fs) =
+ rename dflags gre $ parse dflags (unpackFS fs)
processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
@@ -68,19 +60,14 @@ processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsD
processModuleHeader dflags gre safety mayStr = do
(hmi, doc) <-
case mayStr of
-
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
- case parseModuleHeader dflags str of
- Left msg -> do
- tell ["haddock module header parse failed: " ++ msg]
- return failure
- Right (hmi, doc) -> do
- let !descr = rename dflags gre <$> hmi_description hmi
- hmi' = hmi { hmi_description = descr }
- doc' = rename dflags gre doc
- return (hmi', Just doc')
+ (hmi, doc) = parseModuleHeader dflags str
+ !descr = rename dflags gre <$> hmi_description hmi
+ hmi' = hmi { hmi_description = descr }
+ doc' = rename dflags gre doc
+ return (hmi', Just doc')
let flags :: [ExtensionFlag]
-- We remove the flags implied by the language setting and we display the language instead
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 0be2511f..6848dc63 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -11,14 +11,13 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Haddock.Types
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import Data.Char
+import DynFlags
import Haddock.Parser
-
+import Haddock.Types
import RdrName
-import DynFlags
-
-import Data.Char
-import Control.Monad (mplus)
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -26,7 +25,7 @@ import Control.Monad (mplus)
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
parseModuleHeader dflags str0 =
let
getKey :: String -> String -> (Maybe String,String)
@@ -43,28 +42,17 @@ parseModuleHeader dflags str0 =
(stabilityOpt,str7) = getKey "Stability" str6
(portabilityOpt,str8) = getKey "Portability" str7
- description1 :: Either String (Maybe (Doc RdrName))
- description1 = case descriptionOpt of
- Nothing -> Right Nothing
- Just description -> case parseStringMaybe dflags description of
- Nothing -> Left ("Cannot parse Description: " ++ description)
- Just doc -> Right (Just doc)
- in
- case description1 of
- Left mess -> Left mess
- Right docOpt -> case parseParasMaybe dflags str8 of
- Nothing -> Left "Cannot parse header documentation paragraphs"
- Just doc -> Right (HaddockModInfo {
- hmi_description = docOpt,
- hmi_copyright = copyrightOpt,
- hmi_license = licenseOpt `mplus` licenceOpt,
- hmi_maintainer = maintainerOpt,
- hmi_stability = stabilityOpt,
- hmi_portability = portabilityOpt,
- hmi_safety = Nothing,
- hmi_language = Nothing, -- set in LexParseRn
- hmi_extensions = [] -- also set in LexParseRn
- }, doc)
+ in (HaddockModInfo {
+ hmi_description = parseString dflags <$> descriptionOpt,
+ hmi_copyright = copyrightOpt,
+ hmi_license = licenseOpt `mplus` licenceOpt,
+ hmi_maintainer = maintainerOpt,
+ hmi_stability = stabilityOpt,
+ hmi_portability = portabilityOpt,
+ hmi_safety = Nothing,
+ hmi_language = Nothing, -- set in LexParseRn
+ hmi_extensions = [] -- also set in LexParseRn
+ }, parseParas dflags str8)
-- | This function is how we read keys.
--
diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs
index 720f442b..ea4b7a3f 100644
--- a/src/Haddock/Parser.hs
+++ b/src/Haddock/Parser.hs
@@ -13,13 +13,12 @@
-- Stability : experimental
-- Portability : portable
-module Haddock.Parser ( module Documentation.Haddock.Parser
- , parseParasMaybe
- , parseStringMaybe
+module Haddock.Parser ( parseParas
+ , parseString
, parseIdent
) where
-import Documentation.Haddock.Parser
+import qualified Documentation.Haddock.Parser as P
import DynFlags (DynFlags)
import FastString (mkFastString)
import Documentation.Haddock.Types
@@ -29,13 +28,11 @@ import RdrName (RdrName)
import SrcLoc (mkRealSrcLoc, unLoc)
import StringBuffer (stringToStringBuffer)
-{-# DEPRECATED parseParasMaybe "use `parseParas` instead" #-}
-parseParasMaybe :: DynFlags -> String -> Maybe (DocH mod RdrName)
-parseParasMaybe d = Just . overIdentifier (parseIdent d) . parseParas
+parseParas :: DynFlags -> String -> DocH mod RdrName
+parseParas d = P.overIdentifier (parseIdent d) . P.parseParas
-{-# DEPRECATED parseStringMaybe "use `parseString` instead" #-}
-parseStringMaybe :: DynFlags -> String -> Maybe (DocH mod RdrName)
-parseStringMaybe d = Just . overIdentifier (parseIdent d) . parseString
+parseString :: DynFlags -> String -> DocH mod RdrName
+parseString d = P.overIdentifier (parseIdent d) . P.parseString
parseIdent :: DynFlags -> String -> Maybe RdrName
parseIdent dflags str0 =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 23:17:09 +0000