diff options
Diffstat (limited to 'src/Haddock/Interface/LexParseRn.hs')
-rw-r--r-- | src/Haddock/Interface/LexParseRn.hs | 146 |
1 files changed, 0 insertions, 146 deletions
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs deleted file mode 100644 index f1021436..00000000 --- a/src/Haddock/Interface/LexParseRn.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE BangPatterns #-} - ----------------------------------------------------------------------------- --- | --- Module : Haddock.Interface.LexParseRn --- Copyright : (c) Isaac Dupree 2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.LexParseRn - ( processDocString - , processDocStringParas - , processDocStrings - , processModuleHeader - ) where - -import Control.Applicative -import Data.IntSet (toList) -import Data.List -import Documentation.Haddock.Doc (docConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) -import FastString -import GHC -import Haddock.Interface.ParseModuleHeader -import Haddock.Parser -import Haddock.Types -import Name -import Outputable (showPpr) -import RdrName - -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) -processDocStrings dflags gre strs = - case docConcat $ map (processDocStringParas dflags gre) strs of - DocEmpty -> Nothing - x -> Just x - - -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocStringParas = process parseParas - - -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocString = process parseString - -process :: (DynFlags -> String -> Doc RdrName) - -> DynFlags - -> GlobalRdrEnv - -> HsDocString - -> Doc Name -process parse dflags gre (HsDocString fs) = - rename dflags gre $ parse dflags (unpackFS fs) - - -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (Doc 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' = 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 - 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:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b - [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. - - 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 - 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) - -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - -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 -- Shouldn't happen since x is out of scope - where - monospaced a = DocMonospaced (DocString (showPpr dflags a)) |