{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
module Haddock.Interface.LexParseRn
( processDocString
, processDocStringParas
, processDocStrings
, processModuleHeader
) where
import Data.IntSet (toList)
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 RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-> Maybe (MDoc Name)
processDocStrings dflags gre strs =
case metaDocConcat $ map (processDocStringParas dflags gre) strs of
MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing
x -> Just x
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
processDocStringParas dflags gre (HsDocString fs) =
overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> 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 = rename dflags gre <$> hmi_description hmi
hmi' = hmi { hmi_description = descr }
doc' = overDoc (rename dflags gre) doc
return (hmi', Just doc')
let flags :: [LangExt.Extension]
flags = map toEnum (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 -> 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
[] -> DocMonospaced (DocString (showPpr dflags x))
a:_ -> outOfScope dflags a
[a] -> DocIdentifier a
a:b:_ | isTyConName a -> DocIdentifier a
| otherwise -> 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 (map rn docs)
DocOrderedList docs -> DocOrderedList (map rn docs)
DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
DocCodeBlock doc -> DocCodeBlock (rn doc)
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
DocModule str -> DocModule str
DocHyperlink l -> DocHyperlink l
DocPic str -> DocPic str
DocMathInline str -> DocMathInline str
DocMathDisplay str -> DocMathDisplay str
DocAName str -> DocAName str
DocProperty p -> DocProperty p
DocExamples e -> DocExamples e
DocEmpty -> DocEmpty
DocString str -> DocString str
DocHeader (Header l t) -> DocHeader $ Header l (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))