{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
module Haddock.Interface.LexParseRn
( processDocString
, processDocStringParas
, processDocStrings
, processModuleHeader
) where
import Data.List
import Documentation.Haddock.Doc (metaDocConcat)
import DynFlags (languageExtensions)
import qualified GHC.LanguageExtensions as LangExt
import FastString
import GHC
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
processDocStrings dflags gre strs = do
mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
case mdoc of
MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
x -> pure (Just x)
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
processDocStringParas dflags gre (HsDocString fs) =
overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre (HsDocString fs) =
rename dflags gre $ parseString dflags (unpackFS fs)
processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
processModuleHeader dflags gre safety mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
(hmi, doc) = parseModuleHeader dflags str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
Nothing -> pure Nothing
let hmi' = hmi { hmi_description = descr }
doc' <- overDocF (rename dflags gre) doc
return (hmi', Just doc')
let flags :: [LangExt.Extension]
flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
} , doc)
where
failure = (emptyHaddockModInfo, Nothing)
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
DocIdentifier x -> do
let choices = dataTcOccs x
let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
case names of
[] ->
case choices of
[] -> pure (DocMonospaced (DocString (showPpr dflags x)))
a:_ -> pure (outOfScope dflags a)
[a] -> pure (DocIdentifier a)
a:b:_ | isTyConName a -> pure (DocIdentifier a)
| otherwise -> pure (DocIdentifier b)
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
DocBold doc -> DocBold <$> rn doc
DocMonospaced doc -> DocMonospaced <$> rn doc
DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
DocOrderedList docs -> DocOrderedList <$> traverse rn docs
DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule str -> pure (DocModule str)
DocHyperlink l -> pure (DocHyperlink l)
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
DocMathDisplay str -> pure (DocMathDisplay str)
DocAName str -> pure (DocAName str)
DocProperty p -> pure (DocProperty p)
DocExamples e -> pure (DocExamples e)
DocEmpty -> pure (DocEmpty)
DocString str -> pure (DocString str)
DocHeader (Header l t) -> DocHeader . Header l <$> rn t
DocTable t -> DocTable <$> traverse rn t
outOfScope :: DynFlags -> RdrName -> Doc a
outOfScope dflags x =
case x of
Unqual occ -> monospaced occ
Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
Orig _ occ -> monospaced occ
Exact name -> monospaced name
where
monospaced a = DocMonospaced (DocString (showPpr dflags a))