haddock-api 2.17.4 → 2.18.1
raw patch · 25 files changed
+913/−672 lines, 25 filesdep ~Cabaldep ~QuickCheckdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Cabal, QuickCheck, base, ghc, ghc-paths, haddock-library, hspec, xhtml
API changes (from Hackage documentation)
+ Documentation.Haddock: [expItemPats] :: ExportItem name -> ![(HsDecl name, DocForDecl name)]
+ Documentation.Haddock: [ifaceBundledPatSynMap] :: Interface -> !(Map Name [Name])
+ Documentation.Haddock: [ifaceIsSig] :: Interface -> !Bool
+ Documentation.Haddock: [instBundledPatSynMap] :: InstalledInterface -> Map Name [Name]
+ Documentation.Haddock: [instIsSig] :: InstalledInterface -> Bool
- Documentation.Haddock: DocHeader :: Header (DocH mod id) -> DocH mod id
+ Documentation.Haddock: DocHeader :: Header DocH mod id -> DocH mod id
- Documentation.Haddock: ExportDecl :: !(LHsDecl name) -> !(DocForDecl name) -> ![(name, DocForDecl name)] -> ![DocInstance name] -> ![(name, Fixity)] -> !Bool -> ExportItem name
+ Documentation.Haddock: ExportDecl :: !(LHsDecl name) -> ![(HsDecl name, DocForDecl name)] -> !(DocForDecl name) -> ![(name, DocForDecl name)] -> ![DocInstance name] -> ![(name, Fixity)] -> !Bool -> ExportItem name
- Documentation.Haddock: InstalledInterface :: Module -> HaddockModInfo Name -> DocMap Name -> ArgMap Name -> [Name] -> [Name] -> [DocOption] -> Map Name [Name] -> Map Name Fixity -> InstalledInterface
+ Documentation.Haddock: InstalledInterface :: Module -> Bool -> HaddockModInfo Name -> DocMap Name -> ArgMap Name -> [Name] -> [Name] -> [DocOption] -> Map Name [Name] -> Map Name [Name] -> Map Name Fixity -> InstalledInterface
- Documentation.Haddock: Interface :: !Module -> !FilePath -> !(HaddockModInfo Name) -> !(Documentation Name) -> !(Documentation DocName) -> ![DocOption] -> !(Map Name [LHsDecl Name]) -> !(DocMap Name) -> !(ArgMap Name) -> !(DocMap DocName) -> !(ArgMap DocName) -> !(Map Name [Name]) -> !(Map Name Fixity) -> ![ExportItem Name] -> ![ExportItem DocName] -> ![Name] -> ![Name] -> !AliasMap -> ![ClsInst] -> ![FamInst] -> ![DocInstance Name] -> ![DocInstance DocName] -> !(Int, Int) -> !WarningMap -> !(Maybe [RichToken]) -> Interface
+ Documentation.Haddock: Interface :: !Module -> !Bool -> !FilePath -> !(HaddockModInfo Name) -> !(Documentation Name) -> !(Documentation DocName) -> ![DocOption] -> !(Map Name [LHsDecl Name]) -> !(Map Name [Name]) -> !(DocMap Name) -> !(ArgMap Name) -> !(DocMap DocName) -> !(ArgMap DocName) -> !(Map Name [Name]) -> !(Map Name Fixity) -> ![ExportItem Name] -> ![ExportItem DocName] -> ![Name] -> ![Name] -> !AliasMap -> ![ClsInst] -> ![FamInst] -> ![DocInstance Name] -> ![DocInstance DocName] -> !(Int, Int) -> !WarningMap -> !(Maybe [RichToken]) -> Interface
Files
- CHANGES.md +1/−0
- haddock-api.cabal +32/−12
- resources/html/Classic.theme/xhaddock.css +1/−0
- resources/html/Ocean.std-theme/ocean.css +10/−4
- resources/html/haddock-util.js +5/−135
- src/Haddock.hs +38/−32
- src/Haddock/Backends/Hoogle.hs +12/−6
- src/Haddock/Backends/Hyperlinker/Ast.hs +22/−18
- src/Haddock/Backends/LaTeX.hs +41/−17
- src/Haddock/Backends/Xhtml.hs +40/−68
- src/Haddock/Backends/Xhtml/Decl.hs +84/−64
- src/Haddock/Backends/Xhtml/Layout.hs +4/−0
- src/Haddock/Backends/Xhtml/Names.hs +1/−1
- src/Haddock/Backends/Xhtml/Utils.hs +5/−1
- src/Haddock/Convert.hs +29/−26
- src/Haddock/GhcUtils.hs +19/−6
- src/Haddock/Interface.hs +12/−0
- src/Haddock/Interface/AttachInstances.hs +56/−53
- src/Haddock/Interface/Create.hs +309/−122
- src/Haddock/Interface/Rename.hs +51/−22
- src/Haddock/Interface/Specialize.hs +31/−43
- src/Haddock/InterfaceFile.hs +14/−10
- src/Haddock/Syb.hs +49/−6
- src/Haddock/Types.hs +45/−24
- src/Haddock/Utils.hs +2/−2
+ CHANGES.md view
@@ -0,0 +1,1 @@+See [`haddock`'s changelog](https://hackage.haskell.org/package/haddock/changelog).
haddock-api.cabal view
@@ -1,5 +1,5 @@ name: haddock-api-version: 2.17.4+version: 2.18.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -12,9 +12,11 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple-cabal-version: >= 1.10-stability: experimental+cabal-version: >= 2.0 +extra-source-files:+ CHANGES.md+ data-dir: resources data-files:@@ -36,12 +38,12 @@ default-language: Haskell2010 -- this package typically supports only single major versions- build-depends: base == 4.9.*- , Cabal == 1.24.*- , ghc == 8.0.*- , ghc-paths == 0.1.*- , haddock-library >= 1.4.2 && < 1.5- , xhtml == 3000.2.*+ build-depends: base ^>= 4.10.0+ , Cabal ^>= 2.0.0+ , ghc ^>= 8.2+ , ghc-paths ^>= 0.1.0.9+ , haddock-library ^>= 1.4.4+ , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version@@ -58,6 +60,9 @@ hs-source-dirs: src ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2+ ghc-options: -Wall+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances exposed-modules: Documentation.Haddock@@ -101,6 +106,9 @@ Haddock.Convert Paths_haddock_api + autogen-modules:+ Paths_haddock_api+ test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010@@ -111,15 +119,27 @@ test , src + -- NB: We only use a small subset of lib:haddock-api here, which+ -- explains why this component has a smaller build-depends set other-modules: Haddock.Backends.Hyperlinker.ParserSpec+ Haddock.Backends.Hyperlinker.Parser+ Haddock.Backends.Hyperlinker.Types build-depends:+ ghc ^>= 8.2+ , hspec ^>= 2.4.4+ , QuickCheck ^>= 2.10++ -- Versions for the dependencies below are transitively pinned by+ -- the non-reinstallable `ghc` package and hence need no version+ -- bounds+ build-depends: base , containers- , ghc- , hspec- , QuickCheck == 2.*++ build-tool-depends:+ hspec-discover:hspec-discover ^>= 2.4.4 source-repository head type: git
resources/html/Classic.theme/xhaddock.css view
@@ -285,6 +285,7 @@ padding: 0 8px 2px 5px; margin-right: -3px; background-color: #f0f0f0;+ -moz-user-select: none; } div.subs {
resources/html/Ocean.std-theme/ocean.css view
@@ -88,6 +88,11 @@ font-size: 182%; /* 24pt */ } +#module-header .caption sup {+ font-size: 70%;+ font-weight: normal;+}+ .info { font-size: 85%; /* 11pt */ }@@ -322,10 +327,6 @@ } #synopsis {- display: none;-}--.no-frame #synopsis { display: block; position: fixed; right: 0;@@ -393,6 +394,7 @@ background: #f0f0f0; padding: 0 0.5em 0.2em; margin: 0 -0.5em 0 0;+ -moz-user-select: none; } #interface .src .selflink { border-left: 1px solid #919191;@@ -607,6 +609,10 @@ #module-list .package { float: right;+}++:target {+ background-color: #ffff00; } /* @end */
resources/html/haddock-util.js view
@@ -1,7 +1,7 @@ // Haddock JavaScript utilities var rspace = /\s\s+/g,- rtrim = /^\s+|\s+$/g;+ rtrim = /^\s+|\s+$/g; function spaced(s) { return (" " + s + " ").replace(rspace, " "); } function trim(s) { return s.replace(rtrim, ""); }@@ -52,17 +52,17 @@ { var b = toggleShow(document.getElementById("section." + id)); toggleCollapser(document.getElementById("control." + id), b);- rememberCollapsed(id, b);+ rememberCollapsed(id); return b; } var collapsed = {};-function rememberCollapsed(id, b)+function rememberCollapsed(id) {- if(b)+ if(collapsed[id]) delete collapsed[id] else- collapsed[id] = null;+ collapsed[id] = true; var sections = []; for(var i in collapsed)@@ -107,136 +107,6 @@ } } return null;-}----var max_results = 75; // 50 is not enough to search for map in the base libraries-var shown_range = null;-var last_search = null;--function quick_search()-{- perform_search(false);-}--function full_search()-{- perform_search(true);-}---function perform_search(full)-{- var text = document.getElementById("searchbox").value.toLowerCase();- if (text == last_search && !full) return;- last_search = text;-- var table = document.getElementById("indexlist");- var status = document.getElementById("searchmsg");- var children = table.firstChild.childNodes;-- // first figure out the first node with the prefix- var first = bisect(-1);- var last = (first == -1 ? -1 : bisect(1));-- if (first == -1)- {- table.className = "";- status.innerHTML = "No results found, displaying all";- }- else if (first == 0 && last == children.length - 1)- {- table.className = "";- status.innerHTML = "";- }- else if (last - first >= max_results && !full)- {- table.className = "";- status.innerHTML = "More than " + max_results + ", press Search to display";- }- else- {- // decide what you need to clear/show- if (shown_range)- setclass(shown_range[0], shown_range[1], "indexrow");- setclass(first, last, "indexshow");- shown_range = [first, last];- table.className = "indexsearch";- status.innerHTML = "";- }--- function setclass(first, last, status)- {- for (var i = first; i <= last; i++)- {- children[i].className = status;- }- }--- // do a binary search, treating 0 as ...- // return either -1 (no 0's found) or location of most far match- function bisect(dir)- {- var first = 0, finish = children.length - 1;- var mid, success = false;-- while (finish - first > 3)- {- mid = Math.floor((finish + first) / 2);-- var i = checkitem(mid);- if (i == 0) i = dir;- if (i == -1)- finish = mid;- else- first = mid;- }- var a = (dir == 1 ? first : finish);- var b = (dir == 1 ? finish : first);- for (var i = b; i != a - dir; i -= dir)- {- if (checkitem(i) == 0) return i;- }- return -1;- }--- // from an index, decide what the result is- // 0 = match, -1 is lower, 1 is higher- function checkitem(i)- {- var s = getitem(i).toLowerCase().substr(0, text.length);- if (s == text) return 0;- else return (s > text ? -1 : 1);- }--- // from an index, get its string- // this abstracts over alternates- function getitem(i)- {- for ( ; i >= 0; i--)- {- var s = children[i].firstChild.firstChild.data;- if (s.indexOf(' ') == -1)- return s;- }- return ""; // should never be reached- }-}--function setSynopsis(filename) {- if (parent.window.synopsis && parent.window.synopsis.location) {- if (parent.window.synopsis.location.replace) {- // In Firefox this avoids adding the change to the history.- parent.window.synopsis.location.replace(filename);- } else {- parent.window.synopsis.location = filename;- }- } } function addMenuItem(html) {
src/Haddock.hs view
@@ -68,7 +68,6 @@ import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity)-import StaticFlags (discardStaticFlags) import Packages import Panic (handleGhcException) import Module@@ -398,30 +397,21 @@ ghcMode = CompManager, ghcLink = NoLink }- let dynflags'' = gopt_unset dynflags' Opt_SplitObjs- defaultCleanupHandler dynflags'' $ do- -- ignore the following return-value, which is a list of packages- -- that may need to be re-linked: Haddock doesn't do any- -- dynamic or static linking at all!- _ <- setSessionDynFlags dynflags''- ghcActs dynflags''+ let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs++ -- ignore the following return-value, which is a list of packages+ -- that may need to be re-linked: Haddock doesn't do any+ -- dynamic or static linking at all!+ _ <- setSessionDynFlags dynflags''+ ghcActs dynflags'' where parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do -- TODO: handle warnings? - -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot- -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if- -- we pass any, Haddock will fail. Since StaticFlags are global to the- -- GHC invocation, there's also no way to reparse/save them to set them- -- again properly.- --- -- This is a bit of a hack until we get rid of the rest of the remaining- -- StaticFlags. See GHC issue #8276.- let flags' = discardStaticFlags flags- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags) if not (null rest)- then throwE ("Couldn't parse GHC options: " ++ unwords flags')+ then throwE ("Couldn't parse GHC options: " ++ unwords flags) else return dynflags' -------------------------------------------------------------------------------@@ -436,15 +426,22 @@ #ifdef IN_GHC_TREE getInTreeDir #else- d <- getDataDir -- provided by Cabal- doesDirectoryExist d >>= \exists -> case exists of- True -> return d- False -> do- -- If directory does not exist then we are probably invoking from- -- ./dist/build/haddock/haddock so we use ./resources as a fallback.- doesDirectoryExist "resources" >>= \exists_ -> case exists_ of- True -> return "resources"- False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")+ -- if data directory does not exist we are probably+ -- invoking from either ./haddock-api or ./+ let res_dirs = [ getDataDir -- provided by Cabal+ , pure "resources"+ , pure "haddock-api/resources"+ ]++ check get_path = do+ p <- get_path+ exists <- doesDirectoryExist p+ pure $ if exists then Just p else Nothing++ dirs <- mapM check res_dirs + case [p | Just p <- dirs] of+ (p : _) -> return p + _ -> die "Haddock's resource directory does not exist!\n" #endif fs -> return (last fs) @@ -492,7 +489,7 @@ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $- throwE "-h cannot be used with --gen-index or --gen-contents"+ throwE "-h/--html cannot be used with --gen-index or --gen-contents" when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Hoogle `elem` flags) $@@ -550,9 +547,10 @@ getPrologue dflags flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing- [filename] -> withFile filename ReadMode $ \h -> do+ [filename] -> do+ h <- openFile filename ReadMode hSetEncoding h utf8- str <- hGetContents h+ str <- hGetContents h -- semi-closes the handle return . Just $! parseParas dflags str _ -> throwE "multiple -p/--prologue options" @@ -576,7 +574,15 @@ _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf | otherwise -> try_size (size * 2) -foreign import stdcall unsafe "windows.h GetModuleFileNameW"+# if defined(i386_HOST_ARCH)+# define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+# define WINDOWS_CCONV ccall+# else+# error Unknown mingw32 arch+# endif++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecDir = return Nothing
src/Haddock/Backends/Hoogle.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle@@ -15,12 +16,13 @@ ppHoogle ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..))+import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) +import HsBinds (emptyLHsBinds) import GHC import Outputable import NameSet@@ -84,7 +86,8 @@ f (HsDocTy a _) = f $ unL a f x = x -outHsType :: OutputableBndr a => DynFlags -> HsType a -> String+outHsType :: (OutputableBndrId a)+ => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -155,7 +158,9 @@ -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]-ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods+ppClass dflags decl subdocs =+ (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}+ ++ ppTyFams) : ppMethods where ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl@@ -180,6 +185,7 @@ tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe , tcdTyVars = tfe_pats tfe+ , tcdFixity = tfe_fixity tfe , tcdRhs = tfe_rhs tfe , tcdFVs = emptyNameSet }@@ -194,7 +200,7 @@ -- safety information to a state where the Outputable instance -- produces no output which means no overlap and unsafe (or [safe] -- is generated).- cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty+ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String]@@ -202,7 +208,7 @@ ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) where @@ -242,7 +248,7 @@ -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar . reL) $+ resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {}
src/Haddock/Backends/Hyperlinker/Ast.hs view
@@ -2,12 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}-+{-# LANGUAGE TypeApplications #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Syb+import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC@@ -16,6 +16,9 @@ import Data.Data import Data.Maybe +everythingInRenamedSource :: (Alternative f, Data x)+ => (forall a. Data a => a -> f r) -> x -> f r+everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken]@@ -53,7 +56,7 @@ -- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables =- everything (<|>) (var `combine` rec)+ everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) ->@@ -68,11 +71,10 @@ -- | Obtain details map for types. types :: GHC.RenamedSource -> DetailsMap-types =- everything (<|>) ty+types = everythingInRenamedSource ty where ty term = case cast term of- (Just (GHC.L sspan (GHC.HsTyVar name))) ->+ (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -81,9 +83,10 @@ -- That includes both identifiers bound by pattern matching or declared using -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses).+ binds :: GHC.RenamedSource -> DetailsMap-binds =- everything (<|>) (fun `combine` pat `combine` tvar)+binds = everythingInRenamedSource+ (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->@@ -93,7 +96,7 @@ (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->- [(sspan, RtkVar name)] ++ everything (<|>) rec recs+ [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty@@ -112,13 +115,13 @@ decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds- , everything (<|>) fun . GHC.hs_valds- , everything (<|>) (con `combine` ins)+ , everythingInRenamedSource fun . GHC.hs_valds+ , everythingInRenamedSource (con `Syb.combine` ins) ] where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name- GHC.SynDecl name _ _ _ -> pure . decl $ name+ GHC.SynDecl name _ _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of@@ -127,7 +130,8 @@ _ -> empty con term = case cast term of (Just cdcl) ->- map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl+ map decl (GHC.getConNames cdcl)+ ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst@@ -149,14 +153,14 @@ -- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) =- everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps+ everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of- (Just (GHC.IEVar v)) -> pure $ var v- (Just (GHC.IEThingAbs t)) -> pure $ typ t- (Just (GHC.IEThingAll t)) -> pure $ typ t+ (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v+ (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t+ (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) ->- [typ t] ++ map var vs+ [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name)
src/Haddock/Backends/LaTeX.hs view
@@ -227,8 +227,8 @@ processExport :: ExportItem DocName -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc)-processExport (ExportDecl decl doc subdocs insts fixities _splice)- = ppDecl decl doc insts subdocs fixities+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)+ = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y processExport (ExportNoDecl y subs)@@ -251,7 +251,7 @@ declNames (L _ decl) = case decl of TyClD d -> [tcdName d] SigD (TypeSig lnames _ ) -> map unLoc lnames- SigD (PatSynSig lname _) -> [unLoc lname]+ SigD (PatSynSig lnames _) -> map unLoc lnames ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames"@@ -278,16 +278,17 @@ ppDecl :: LHsDecl DocName+ -> [(HsDecl DocName,DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX -ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode TyClD d@(DataDecl {})- -> ppDataDecl instances subdocs loc (Just doc) d unicode+ -> ppDataDecl pats instances subdocs loc (Just doc) d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now -- TyClD d@(TySynonym {})@@ -296,10 +297,11 @@ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType t) unicode- SigD (PatSynSig lname ty) ->- ppLPatSig loc (doc, fnArgsDoc) lname ty unicode+ SigD (PatSynSig lnames ty) ->+ ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty+ DerivD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False@@ -354,14 +356,14 @@ where names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName+ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsSigType DocName -> Bool -> LaTeX-ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode+ppLPatSig _loc (doc, _argDocs) docnames ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern"- , ppDocBinder name+ , hsep $ punctuate comma $ map ppDocBinder docnames , dcolon unicode , ppLType unicode (hsSigType ty) ]@@ -564,11 +566,11 @@ ------------------------------------------------------------------------------- -ppDataDecl :: [DocInstance DocName] ->+ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX-ppDataDecl instances subdocs _loc doc dataDecl unicode+ppDataDecl pats instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body))@@ -578,10 +580,12 @@ cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons - body = catMaybes [constrBit, doc >>= documentationToLaTeX]+ body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX] (whereBit, leaders)- | null cons = (empty,[])+ | null cons+ , null pats = (empty,[])+ | null cons = (decltt (keyword "where"), repeat empty) | otherwise = case resTy of ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))@@ -593,6 +597,19 @@ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" + patternBit+ | null cons = Nothing+ | otherwise = Just $+ text "\\haddockbeginconstrs" $$+ vcat [ hsep [ keyword "pattern"+ , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames+ , dcolon unicode+ , ppLType unicode (hsSigType ty)+ ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)+ | (SigD (PatSynSig lnames ty),d) <- pats+ ] $$+ text "\\end{tabulary}\\par"+ instancesBit = ppDocInstances unicode instances @@ -884,6 +901,10 @@ tupleParens _ = parenList +sumParens :: [LaTeX] -> LaTeX+sumParens = ubxparens . hsep . punctuate (text " | ")++ ------------------------------------------------------------------------------- -- * Rendering of HsType --@@ -944,17 +965,20 @@ , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty-ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name+ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name+ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)+ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)+ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
src/Haddock/Backends/Xhtml.hs view
@@ -46,7 +46,7 @@ import Data.Ord ( comparing ) import DynFlags (Language(..))-import GHC hiding ( NoLink, moduleInfo )+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name import Module @@ -108,8 +108,8 @@ return () -headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html-headHtml docTitle miniPage themes mathjax_url =+headHtml :: String -> Themes -> Maybe String -> Html+headHtml docTitle themes mathjax_url = header << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle,@@ -118,15 +118,12 @@ script ! [src mjUrl, thetype "text/javascript"] << noHtml, script ! [thetype "text/javascript"] -- NB: Within XHTML, the content of script tags needs to be- -- a <![CDATA[ section. Will break if the miniPage name could- -- have "]]>" in it!- << primHtml (- "//<![CDATA[\nwindow.onload = function () {pageLoad();"- ++ setSynopsis ++ "};\n//]]>\n")+ -- a <![CDATA[ section.+ << primHtml+ "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n" ] where- setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage- mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url+ mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url srcButton :: SourceURLs -> Maybe Interface -> Maybe Html@@ -172,7 +169,7 @@ maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url pageContent =- body ! [theclass "no-frame"] << [+ body << [ divPackageHeader << [ unordList (catMaybes [ srcButton maybe_source_url iface,@@ -263,13 +260,20 @@ themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree dflags showPkgs- [(instMod iface, toInstalledDescription iface) | iface <- ifaces]+ [(instMod iface, toInstalledDescription iface)+ | iface <- ifaces+ , not (instIsSig iface)]+ sig_tree = mkModuleTree dflags showPkgs+ [(instMod iface, toInstalledDescription iface)+ | iface <- ifaces+ , instIsSig iface] html =- headHtml doctitle Nothing themes mathjax_url ++++ headHtml doctitle themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ ppPrologue qual doctitle prologue,+ ppSignatureTree qual sig_tree, ppModuleTree qual tree ] createDirectoryIfMissing True odir@@ -282,7 +286,13 @@ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppSignatureTree :: Qualification -> [ModuleTree] -> Html+ppSignatureTree qual ts =+ divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)++ ppModuleTree :: Qualification -> [ModuleTree] -> Html+ppModuleTree _ [] = mempty ppModuleTree qual ts = divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) @@ -359,7 +369,7 @@ where indexPage showLetters ch items =- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url ++++ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [@@ -469,32 +479,31 @@ mdl = ifaceMod iface aliases = ifaceModuleAliases iface mdl_str = moduleString mdl+ mdl_str_annot = mdl_str ++ if ifaceIsSig iface+ then " (signature)"+ else ""+ mdl_str_linked+ | ifaceIsSig iface+ = mdl_str +++ " (signature" ++++ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) ++++ ")"+ | otherwise+ = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html =- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url ++++ headHtml mdl_str_annot themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [- divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)- ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes- -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()-ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do- let mdl = ifaceMod iface- html =- headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++- miniBody <<- (divModuleHeader << sectionName << moduleString mdl +++- miniSynopsis mdl iface unicode qual)- createDirectoryIfMissing True odir- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)-+signatureDocURL :: String+signatureDocURL = "https://wiki.haskell.org/Module_signature" ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual@@ -546,43 +555,6 @@ linksInfo = (maybe_source_url, maybe_wiki_url) -miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html-miniSynopsis mdl iface unicode qual =- divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports- where- exports = numberSectionHeadings (ifaceRnExportItems iface)---processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName- -> [Html]-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =- ((divTopDecl <<).(declElem <<)) <$> case decl0 of- TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of- (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]- (DataDecl{}) -> [keyword "data" <+> b]- (SynDecl{}) -> [keyword "type" <+> b]- (ClassDecl {}) -> [keyword "class" <+> b]- SigD (TypeSig lnames _) ->- map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames- _ -> []-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =- [groupTag lvl << docToHtml Nothing qual (mkMeta txt)]-processForMiniSynopsis _ _ _ _ = []---ppNameMini :: Notation -> Module -> OccName -> Html-ppNameMini notation mdl nm =- anchor ! [ href (moduleNameUrl mdl nm)- , target mainFrameName ]- << ppBinder' notation nm---ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html-ppTyClBinderWithVarsMini mdl decl =- let n = tcdName decl- ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above- in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName- ppModuleContents :: Qualification -> [ExportItem DocName] -> Bool -- ^ Orphans sections@@ -632,8 +604,8 @@ processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual processExport summary _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ qual (ExportNoDecl y subs)
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -34,27 +34,29 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) -import GHC+import GHC hiding (LexicalFixity(..)) import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName- -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]+ -> [(HsDecl DocName, DocForDecl DocName)]+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual- SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname+ SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames ty fixities splice unicode qual- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual- InstD _ -> noHtml- _ -> error "declaration not supported by ppDecl"+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual+ InstD _ -> noHtml+ DerivD _ -> noHtml+ _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->@@ -74,22 +76,20 @@ pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- Located DocName -> LHsSigType DocName ->+ [Located DocName] -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual+ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual | summary = pref1- | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)+ | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern"- , ppBinder summary occname+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode , ppLType unicode qual (hsSigType typ) ] - occname = nameOccName . getName $ name- ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> Splice -> Unicode -> Qualification -> Html@@ -172,8 +172,8 @@ -- | Pretty-print type variables.-ppTyVars :: [LHsTyVarBndr DocName] -> [Html]-ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs+ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html]+ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs tyvarNames :: LHsQTyVars DocName -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit@@ -200,7 +200,7 @@ splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ]- ++ ppTyVars (hsQTvExplicit ltyvars))+ ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs@@ -354,20 +354,20 @@ -- | Print a type family and its variables ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =- ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs)+ ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -- | Print a newtype / data binder and its variables-ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html-ppDataBinderWithVars summ decl =- ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html+ppDataBinderWithVars summ unicode qual decl =+ ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs =- ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)+ ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix@@ -380,15 +380,6 @@ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) --- | Print an application of a 'DocName' and a list of 'Names'-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html-ppAppDocNameNames summ n ns =- ppTypeApp n [] ns ppDN ppTyName- where- ppDN notation = ppBinderFixity notation summ . nameOccName . getName- ppBinderFixity Infix = ppBinderInfix- ppBinderFixity _ = ppBinder- -- | General printing of type applications ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html ppTypeApp n [] (t1:t2:rest) ppDN ppT@@ -446,7 +437,7 @@ ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)- <+> ppAppDocNameNames summ n (tyvarNames tvs)+ <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -530,9 +521,8 @@ , f@(n',_) <- fixities , n == n' ] names = map unLoc lnames ]- -- FIXME: is taking just the first name ok? Is it possible that- -- there are different subdocs for different names in a single- -- type signature?+ -- N.B. taking just the first name is ok. Signatures with multiple names+ -- are expanded so that each name gets its own signature. minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method@@ -624,7 +614,7 @@ , [subFamInstDetails iid pdecl]) where pdata = keyword "data" <+> typ- pdecl = pdata <+> ppShortDataDecl False True dd unicode qual+ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual@@ -645,10 +635,10 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames- L loc rtyp = get_type typ- return $ ppSimpleSig links splice unicode qual loc names rtyp- where- get_type = hswc_body . hsib_body+ L _ rtyp = hsSigWcType typ+ -- Instance methods signatures are synified and thus don't have a useful + -- SrcSpan value. Use the methods name location instead.+ return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2@@ -675,20 +665,23 @@ -- TODO: print contexts-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html-ppShortDataDecl summary dataInst dataDecl unicode qual+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName+ -> [(HsDecl DocName,DocForDecl DocName)]+ -> Unicode -> Qualification -> Html+ppShortDataDecl summary dataInst dataDecl pats unicode qual - | [] <- cons = dataHeader+ | [] <- cons+ , [] <- pats = dataHeader - | [lcon] <- cons, isH98,+ | [lcon] <- cons, [] <- pats, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | isH98 = dataHeader- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)+ | [] <- pats, isH98 = dataHeader+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1) | otherwise = (dataHeader <+> keyword "where")- +++ shortSubDecls dataInst (map doGADTConstr cons)+ +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1) where dataHeader@@ -702,16 +695,25 @@ ConDeclH98 {} -> True ConDeclGADT{} -> False + pats1 = [ hsep [ keyword "pattern"+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames+ , dcolon unicode+ , ppLType unicode qual (hsSigType typ)+ ]+ | (SigD (PatSynSig lnames typ),_) <- pats+ ] + ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocName ->+ [(HsDecl DocName,DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html-ppDataDecl summary links instances fixities subdocs loc doc dataDecl+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual - | summary = ppShortDataDecl summary False dataDecl unicode qual- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit+ | summary = ppShortDataDecl summary False dataDecl pats unicode qual+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl@@ -726,7 +728,9 @@ fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual whereBit- | null cons = noHtml+ | null cons+ , null pats = noHtml+ | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual@@ -736,6 +740,17 @@ (map unLoc (getConNames (unLoc c)))) fixities ] + patternBit = subPatterns qual+ [ (hsep [ keyword "pattern"+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames+ , dcolon unicode+ , ppLType unicode qual (hsSigType typ)+ ] <+> ppFixities subfixs qual+ ,combineDocumentation (fst d), [])+ | (SigD (PatSynSig lnames typ),d) <- pats+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities+ ]+ instancesBit = ppInstances links (OriginData docname) instances splice unicode qual @@ -893,7 +908,7 @@ -- context ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b- ppDataBinderWithVars summary decl+ ppDataBinderWithVars summary unicode qual decl <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x@@ -916,6 +931,9 @@ tupleParens _ = parenList +sumParens :: [Html] -> Html+sumParens = ubxSumList+ -------------------------------------------------------------------------------- -- * Rendering of HsType --------------------------------------------------------------------------------@@ -967,8 +985,8 @@ ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html-ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html+ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)@@ -977,26 +995,27 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual = maybeParen ctxt_prec pREC_FUN $- ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual+ ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives-ppr_mono_ty _ (HsTyVar (L _ name)) True _+ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty-ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name+ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)+ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)-ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"@@ -1004,7 +1023,8 @@ -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -29,6 +29,7 @@ subArguments, subAssociatedTypes, subConstructors,+ subPatterns, subEquations, subFields, subInstances, subOrphanInstances,@@ -179,6 +180,9 @@ subConstructors :: Qualification -> [SubDecl] -> Html subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual++subPatterns :: Qualification -> [SubDecl] -> Html+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual subFields :: Qualification -> [SubDecl] -> Html subFields qual = divSubDecls "fields" "Fields" . subDlist qual
src/Haddock/Backends/Xhtml/Names.hs view
@@ -26,7 +26,7 @@ import qualified Data.Map as M import qualified Data.List as List -import GHC+import GHC hiding (LexicalFixity(..)) import Name import RdrName import FastString (unpackFS)
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -20,7 +20,7 @@ (<+>), (<=>), char, keyword, punctuate, - braces, brackets, pabrackets, parens, parenList, ubxParenList,+ braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, hsep, vcat,@@ -175,6 +175,10 @@ ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma+++ubxSumList :: [Html] -> Html+ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") ubxparens :: Html -> Html
src/Haddock/Convert.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE CPP, PatternGuards #-} ----------------------------------------------------------------------------- -- |@@ -18,7 +17,7 @@ -- instance heads, which aren't TyThings, so just export everything. import Bag ( emptyBag )-import BasicTypes ( TupleSort(..) )+import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) ) import Class import CoAxiom import ConLike@@ -30,15 +29,15 @@ import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn-import SrcLoc ( Located, noLoc, unLoc )+import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type import TyCoRep-import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )+import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, starKindTyConName, unitTy ) import PrelNames ( hasKey, eqTyConKey, ipClassKey- , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )+ , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique ) import Util ( filterByList, filterOut ) import Var@@ -78,10 +77,11 @@ { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl)+ , tcdFixity = Prefix , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl- , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) :+ , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature@@ -102,7 +102,7 @@ (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) ->- allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)+ allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x)@@ -114,7 +114,9 @@ hs_rhs = synifyType WithinType rhs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats- , hsib_vars = map tyVarName tkvs }+ , hsib_vars = map tyVarName tkvs+ , hsib_closed = True }+ , tfe_fixity = Prefix , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)@@ -147,6 +149,8 @@ alphaTyVars --a, b, c... which are unfortunately all kind * , hsq_dependent = emptyNameSet } + , tcdFixity = Prefix+ , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc []@@ -154,7 +158,7 @@ , dd_kindSig = Just (synifyKindSig (tyConKind tc)) -- we have their kind accurately: , dd_cons = [] -- No constructors- , dd_derivs = Nothing }+ , dd_derivs = noLoc [] } , tcdDataCusk = False , tcdFVs = placeHolderNamesTc } @@ -181,6 +185,7 @@ FamilyDecl { fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc)+ , fdFixity = Prefix , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn =@@ -192,6 +197,7 @@ | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc)+ , tcdFixity = Prefix , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } | otherwise =@@ -225,7 +231,7 @@ consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any.- alg_deriv = Nothing+ alg_deriv = noLoc [] defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing@@ -234,7 +240,8 @@ , dd_derivs = alg_deriv } in case lefts consRaw of [] -> return $- DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn+ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix+ , tcdDataDefn = defn , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs @@ -294,7 +301,7 @@ (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?"- gadt_ty = HsIB [] (synifyType WithinType res_ty)+ gadt_ty = HsIB [] (synifyType WithinType res_ty) False -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat ->@@ -311,7 +318,7 @@ , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name-synifyName = noLoc . getName+synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig Name@@ -360,24 +367,20 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name -- Ditto (see synifySigType)-synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))+synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) synifyPatSynSigType :: PatSyn -> LHsSigType Name -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType Name-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys- , lev `hasKey` ptrRepLiftedDataConKey- = noLoc (HsTyVar (noLoc starKindTyConName))- | tc `hasKey` tYPETyConKey- , [TyConApp lev []] <- tys- , lev `hasKey` ptrRepUnliftedDataConKey- = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName))+ , lev `hasKey` liftedRepDataConKey+ = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys@@ -393,7 +396,7 @@ | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name- = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)+ = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys@@ -401,7 +404,7 @@ -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))- (noLoc $ HsTyVar $ noLoc (getName tc))+ (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc)) (map (synifyType WithinType) $ filterOut isCoercionTy tys) synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1@@ -409,7 +412,7 @@ s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2-synifyType _ (ForAllTy (Anon t1) t2) = let+synifyType _ (FunTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2@@ -444,8 +447,8 @@ in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau synifyTyLit :: TyLit -> HsTyLit-synifyTyLit (NumTyLit n) = HsNumTy mempty n-synifyTyLit (StrTyLit s) = HsStrTy mempty s+synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n+synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k
src/Haddock/GhcUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -----------------------------------------------------------------------------@@ -17,17 +17,14 @@ import Control.Arrow-import Data.Function import Exception import Outputable import Name+import NameSet import Lexeme import Module-import RdrName (GlobalRdrEnv)-import GhcMonad (withSession) import HscTypes-import UniqFM import GHC import Class @@ -92,6 +89,10 @@ case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (ClassOpSig is_default filtered ty)+filterSigNames p (PatSynSig ns ty) =+ case filter (p . unLoc) ns of+ [] -> Nothing+ filtered -> Just (PatSynSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name@@ -104,7 +105,7 @@ sigNameNoLoc :: Sig name -> [name] sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns-sigNameNoLoc (PatSynSig n _) = [unLoc n]+sigNameNoLoc (PatSynSig ns _) = map unLoc ns sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns@@ -114,6 +115,7 @@ isUserLSig :: LSig name -> Bool isUserLSig (L _(TypeSig {})) = True isUserLSig (L _(ClassOpSig {})) = True+isUserLSig (L _(PatSynSig {})) = True isUserLSig _ = False @@ -133,6 +135,17 @@ pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr++nubByName :: (a -> Name) -> [a] -> [a]+nubByName f ns = go emptyNameSet ns+ where+ go !_ [] = []+ go !s (x:xs)+ | y `elemNameSet` s = go s xs+ | otherwise = let !s' = extendNameSet s y+ in x : go s' xs+ where+ y = f x ------------------------------------------------------------------------------- -- * Located
src/Haddock/Interface.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface@@ -56,7 +57,14 @@ import GHC hiding (verbosity) import HscTypes import FastString (unpackFS)+import MonadUtils (liftIO) +#if defined(mingw32_HOST_OS)+import System.IO+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))+#endif+ -- | Create 'Interface's and a link environment by typechecking the list of -- modules using the GHC API and processing the resulting syntax trees. processModules@@ -68,6 +76,10 @@ -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming -- environment processModules verbosity modules flags extIfaces = do+#if defined(mingw32_HOST_OS)+ -- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows+ liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure+#endif out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
src/Haddock/Interface/AttachInstances.hs view
@@ -18,11 +18,11 @@ import Haddock.Convert import Haddock.GhcUtils +import Control.Applicative import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing)-import Data.Function (on)-import Data.Maybe ( maybeToList, mapMaybe )+import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -33,14 +33,13 @@ import FamInstEnv import FastString import GHC-import GhcMonad (withSession) import InstEnv import MonadUtils (liftIO) import Name+import NameEnv import Outputable (text, sep, (<+>)) import PrelNames import SrcLoc-import TcRnDriver (tcRnGetInfo) import TyCon import TyCoRep import TysPrim( funTyCon )@@ -53,13 +52,15 @@ -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]-attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces+attachInstances expInfo ifaces instIfaceMap = do+ (_msgs, mb_index) <- getNameToInstancesIndex+ mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] - attach iface = do- newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)+ attach index iface = do+ newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) return $ iface { ifaceExportItems = newItems@@ -75,47 +76,56 @@ ] -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap- -> ExportItem Name- -> Ghc (ExportItem Name)-attachToExportItem expInfo iface ifaceMap instIfaceMap export =+attachToExportItem+ :: NameEnv ([ClsInst], [FamInst])+ -> ExportInfo+ -> Interface+ -> IfaceMap+ -> InstIfaceMap+ -> ExportItem Name+ -> Ghc (ExportItem Name)+attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do- mb_info <- getAllInfo (tcdName d)- insts <- case mb_info of- Just (_, _, cls_instances, fam_instances) ->- let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )- | i <- sortBy (comparing instFam) fam_instances- , let n = getName i- , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap- , not $ isNameHidden expInfo (fi_fam i)- , not $ any (isTypeHidden expInfo) (fi_tys i)- , let opaque = isTypeHidden expInfo (fi_rhs i)- ]- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))- | let is = [ (instanceSig i, getName i) | i <- cls_instances ]- , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is- , not $ isInstanceHidden expInfo cls tys- ]+ insts <-+ let mb_instances = lookupNameEnv index (tcdName d)+ cls_instances = maybeToList mb_instances >>= fst+ fam_instances = maybeToList mb_instances >>= snd+ fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )+ | i <- sortBy (comparing instFam) fam_instances+ , let n = getName i+ , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap+ , not $ isNameHidden expInfo (fi_fam i)+ , not $ any (isTypeHidden expInfo) (fi_tys i)+ , let opaque = isTypeHidden expInfo (fi_rhs i)+ ]+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))+ | let is = [ (instanceSig i, getName i) | i <- cls_instances ]+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is+ , not $ isInstanceHidden expInfo cls tys+ ] -- fam_insts but with failing type fams filtered out- cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]- famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]- in do- dfs <- getDynFlags- let mkBug = (text "haddock-bug:" <+>) . text- liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)- return $ cls_insts ++ cleanFamInsts- Nothing -> return []+ cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]+ famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]+ in do+ dfs <- getDynFlags+ let mkBug = (text "haddock-bug:" <+>) . text+ liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)+ return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e where- attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =- nubBy ((==) `on` fst) $ expItemFixities e +++ attachFixities e@ExportDecl{ expItemDecl = L _ d+ , expItemPats = patsyns+ } = e { expItemFixities =+ nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d- , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]- , n' <- n : subs+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]+ , n' <- n : (subs ++ patsyn_names) , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] }+ where+ patsyn_names = concatMap (getMainDeclBinder . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location@@ -142,14 +152,6 @@ iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's getInfo but doesn't cut things out depending on the--- interative context, which we don't set sufficiently anyway.-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))-getAllInfo name = withSession $ \hsc_env -> do- (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name- return r-- -------------------------------------------------------------------------------- -- Collecting and sorting instances --------------------------------------------------------------------------------@@ -169,15 +171,15 @@ = (map argCount args, className cls, map simplify args) argCount :: Type -> Int-argCount (AppTy t _) = argCount t + 1+argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts-argCount (ForAllTy (Anon _) _ ) = 2-argCount (ForAllTy _ t) = argCount t-argCount (CastTy t _) = argCount t+argCount (FunTy _ _ ) = 2+argCount (ForAllTy _ t) = argCount t+argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType-simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2]+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1@@ -239,8 +241,9 @@ case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args- ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty+ ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False CastTy ty _ -> typeHidden ty CoercionTy {} -> False
src/Haddock/Interface/Create.hs view
@@ -11,10 +11,15 @@ -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable+--+-- This module provides a single function 'createInterface',+-- which creates a Haddock 'Interface' from the typechecking+-- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where import Documentation.Haddock.Doc (metaDocAppend)+import Documentation.Haddock.Utf8 as Utf8 import Haddock.Types import Haddock.Options import Haddock.GhcUtils@@ -25,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List@@ -33,9 +39,10 @@ import Data.Ord import Control.Applicative import Control.Arrow (second)-import Control.DeepSeq+import Control.DeepSeq (force)+import Control.Exception (evaluate) import Control.Monad-import Data.Function (on)+import Data.Traversable import qualified Packages import qualified Module@@ -43,18 +50,23 @@ import GHC import HscTypes import Name+import NameSet import Bag import RdrName import TcRnTypes import FastString (concatFS)-import BasicTypes ( StringLiteral(..) )+import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'.-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface+createInterface :: TypecheckedModule+ -> [Flag] -- Boolean flags+ -> IfaceMap -- Locally processed modules+ -> InstIfaceMap -- External, already installed interfaces+ -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm@@ -62,12 +74,17 @@ L _ hsm = parsedSource tm !safety = modInfoSafe mi mdl = ms_mod ms+ sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))+ is_sig = ms_hsc_src ms == HsigFile dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md- !exportedNames = modInfoExports mi+ !exportedNames = modInfoExportsWithSelectors mi - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm+ (TcGblEnv { tcg_rdr_env = gre+ , tcg_warns = warnings+ , tcg_patsyns = patsyns+ }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side.@@ -83,29 +100,49 @@ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 + -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_++ exports0 = fmap (reverse . map unLoc) mayExports+ exports+ | OptIgnoreExports `elem` opts = Nothing+ | otherwise = exports0+ warningMap = mkWarningMap dflags warnings gre exportedNames++ localBundledPatSyns :: Map Name [Name]+ localBundledPatSyns =+ case exports of+ Nothing -> M.empty+ Just ies ->+ M.map (nubByName id) $+ M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)+ | IEThingWith (L _ ty_name) _ exported _ <- ies+ , let bundled_patsyns =+ filter is_patsyn (map (ieWrappedName . unLoc) exported)+ , not (null bundled_patsyns)+ ]+ where+ is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))+ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances- ++ map getName fam_instances+ localInsts = filter (nameIsLocalOrFrom sem_mdl)+ $ map getName instances+ ++ map getName fam_instances -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] 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 = mkWarningMap dflags warnings gre exportedNames- let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls- maps fixMap splices exports instIfaceMap dflags+ -- The MAIN functionality: compute the export items which will+ -- each be the actual documentation of this module.+ exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls+ maps localBundledPatSyns fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -129,33 +166,39 @@ tokenizedSrc <- mkMaybeTokenizedSrc flags tm return $! Interface {- ifaceMod = mdl- , ifaceOrigFilename = msHsFilePath ms- , ifaceInfo = info- , ifaceDoc = Documentation mbDoc modWarn- , ifaceRnDoc = Documentation Nothing Nothing- , ifaceOptions = opts- , ifaceDocMap = docMap- , ifaceArgMap = argMap- , ifaceRnDocMap = M.empty- , ifaceRnArgMap = M.empty- , ifaceExportItems = prunedExportItems- , ifaceRnExportItems = []- , ifaceExports = exportedNames- , ifaceVisibleExports = visibleNames- , ifaceDeclMap = declMap- , ifaceSubMap = subMap- , ifaceFixMap = fixMap- , ifaceModuleAliases = aliases- , ifaceInstances = instances- , ifaceFamInstances = fam_instances+ ifaceMod = mdl+ , ifaceIsSig = is_sig+ , ifaceOrigFilename = msHsFilePath ms+ , ifaceInfo = info+ , ifaceDoc = Documentation mbDoc modWarn+ , ifaceRnDoc = Documentation Nothing Nothing+ , ifaceOptions = opts+ , ifaceDocMap = docMap+ , ifaceArgMap = argMap+ , ifaceRnDocMap = M.empty+ , ifaceRnArgMap = M.empty+ , ifaceExportItems = prunedExportItems+ , ifaceRnExportItems = []+ , ifaceExports = exportedNames+ , ifaceVisibleExports = visibleNames+ , ifaceDeclMap = declMap+ , ifaceBundledPatSynMap = localBundledPatSyns+ , ifaceSubMap = subMap+ , ifaceFixMap = fixMap+ , ifaceModuleAliases = aliases+ , ifaceInstances = instances+ , ifaceFamInstances = fam_instances , ifaceOrphanInstances = [] -- Filled in `attachInstances` , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`- , ifaceHaddockCoverage = coverage- , ifaceWarningMap = warningMap- , ifaceTokenizedSrc = tokenizedSrc+ , ifaceHaddockCoverage = coverage+ , ifaceWarningMap = warningMap+ , ifaceTokenizedSrc = tokenizedSrc } +-- | Given all of the @import M as N@ declarations in a package,+-- create a mapping from the module identity of M, to an alias N+-- (if there are multiple aliases, we pick the last one.) This+-- will go in 'ifaceModuleAliases'. mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName mkAliasMap dflags mRenamedSource = case mRenamedSource of@@ -163,16 +206,31 @@ Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do- alias <- ideclAs impDecl+ SrcLoc.L _ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags+ -- TODO: This is supremely dodgy, because in general the+ -- UnitId isn't going to look anything like the package+ -- qualifier (even with old versions of GHC, the+ -- IPID would be p-0.1, but a package qualifier never+ -- has a version number it. (Is it possible that in+ -- Haddock-land, the UnitIds never have version numbers?+ -- I, ezyang, have not quite understand Haddock's package+ -- identifier model.)+ --+ -- Additionally, this is simulating some logic GHC already+ -- has for deciding how to qualify names when it outputs+ -- them to the user. We should reuse that information;+ -- or at least reuse the renamed imports, which know what+ -- they import! (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls --- similar to GHC.lookupModule+-- Similar to GHC.lookupModule+-- ezyang: Not really... lookupModuleDyn :: DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName =@@ -257,8 +315,14 @@ -> [(LHsDecl Name, [HsDocString])] -> 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)+ let+ (a, b, c, d) = unzip4 $ map mappings decls+ in ( f' (map (nubByName fst) a)+ , f (filterMapping (not . M.null) b)+ , f (filterMapping (not . null) c)+ , f (filterMapping (not . null) d)+ , instanceMap+ ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat@@ -266,6 +330,9 @@ f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) f' = M.fromListWith metaDocAppend . concat + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]+ filterMapping p = map (filter (p . snd))+ mappings :: (LHsDecl Name, [HsDocString]) -> ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))]@@ -305,16 +372,16 @@ where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d+ names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl -- Note [2]: --------------- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.--- That should work for normal user-written instances (from looking at GHC--- sources). We can assume that commented instances are user-written.--- This lets us relate Names (from ClsInsts) to comments (associated--- with InstDecls).-+-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried+-- inside them. That should work for normal user-written instances (from+-- looking at GHC sources). We can assume that commented instances are+-- user-written. This lets us relate Names (from ClsInsts) to comments+-- (associated with InstDecls and DerivDecls). -------------------------------------------------------------------------------- -- Declarations@@ -322,7 +389,11 @@ -- | Get all subordinate declarations inside a declaration, and their docs.-subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]+-- A subordinate declaration is something like the associate type or data+-- family of a type class.+subordinates :: InstMap+ -> HsDecl Name+ -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _@@ -338,7 +409,7 @@ , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]- dataSubs dd = constrs ++ fields+ dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)@@ -347,14 +418,20 @@ | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ]+ derivs = [ (instName, [unL doc], M.empty)+ | HsIB { hsib_body = L l (HsDocTy _ doc) }+ <- concatMap (unLoc . deriv_clause_tys . unLoc) $+ unLoc $ dd_derivs dd+ , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of- SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))- SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))+ SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty@@ -394,12 +471,12 @@ -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ =- mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ +++ mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ mkDecls hs_docs DocD group_ ++- mkDecls hs_instds InstD group_ +++ mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where@@ -433,8 +510,9 @@ filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True- isHandled (TyClD {}) = True- isHandled (InstD {}) = True+ isHandled (TyClD {}) = True+ isHandled (InstD {}) = True+ isHandled (DerivD {}) = True isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs@@ -484,13 +562,16 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems- :: IfaceMap+ :: Bool -- is it a signature+ -> IfaceMap -> Module -- this module+ -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig)- -> [LHsDecl Name]+ -> [LHsDecl Name] -- renamed source declarations -> Maps+ -> Map Name [Name] -> FixMap -> [SrcSpan] -- splice locations -> Maybe [IE Name]@@ -498,17 +579,28 @@ -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems- modMap thisMod warnings gre exportedNames decls- maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =+ is_sig modMap thisMod semMod warnings gre exportedNames decls+ maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where- lookupExport (IEVar (L _ x)) = declWith x- lookupExport (IEThingAbs (L _ t)) = declWith t- lookupExport (IEThingAll (L _ t)) = declWith t- lookupExport (IEThingWith (L _ t) _ _ _) = declWith t+ lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x+ lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t+ lookupExport (IEThingAll (L _ t)) = do+ let name = ieWrappedName t+ pats <- findBundledPatterns name+ declWith pats name+ lookupExport (IEThingWith (L _ t) _ _ _) = do+ let name = ieWrappedName t+ pats <- findBundledPatterns name+ declWith pats name lookupExport (IEModuleContents (L _ m)) =+ -- TODO: We could get more accurate reporting here if IEModuleContents+ -- also recorded the actual names that are exported here. We CAN+ -- compute this info using @gre@ but 'moduleExports does not seem to+ -- do so.+ -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr@@ -521,9 +613,10 @@ Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem Name ]- declWith t =- case findDecl t of+ declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]+ declWith pats t = do+ r <- findDecl t+ case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap@@ -558,15 +651,15 @@ -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig- in return [ mkExportDecl t newDecl docs_ ]+ in return [ mkExportDecl t newDecl pats docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] - _ -> return [ mkExportDecl t decl docs_ ]+ _ -> return [ mkExportDecl t decl pats docs_ ] -- Declaration from another package ([], _) -> do@@ -576,42 +669,105 @@ Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package.+ -- TODO: This needs to be more sophisticated to deal+ -- with signature inheritance case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]- return [ mkExportDecl t decl (noDocForDecl, subs_) ]+ return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] Just iface ->- return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]+ return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] - mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name- mkExportDecl name decl (doc, subs) = decl'+ mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)]+ -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name+ mkExportDecl name decl pats (doc, subs) = decl' where- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False- mdl = nameModule name+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False subs' = filter (isExported . fst) subs+ pats' = [ d | d@(patsyn_decl, _) <- pats+ , all isExported (getMainDeclBinder patsyn_decl) ] sub_names = map fst subs'- fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]--- isExported = (`elem` exportedNames)+ pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]+ fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] + exportedNameSet = mkNameSet exportedNames+ isExported n = elemNameSet n exportedNameSet - findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))+ findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n- | m == thisMod, Just ds <- M.lookup n declMap =- (ds, lookupDocs n warnings docMap argMap subMap)- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))- | otherwise = ([], (noDocForDecl, []))+ | m == semMod =+ case M.lookup n declMap of+ Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)+ Nothing+ | is_sig -> do+ -- OK, so it wasn't in the local declaration map. It could+ -- have been inherited from a signature. Reconstitute it+ -- from the type.+ mb_r <- hiDecl dflags n+ case mb_r of+ Nothing -> return ([], (noDocForDecl, []))+ -- TODO: If we try harder, we might be able to find+ -- a Haddock! Look in the Haddocks for each thing in+ -- requirementContext (pkgState)+ Just decl -> return ([decl], (noDocForDecl, []))+ | otherwise ->+ return ([], (noDocForDecl, []))+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap+ , Just ds <- M.lookup n (ifaceDeclMap iface) =+ return (ds, lookupDocs n warnings+ (ifaceDocMap iface)+ (ifaceArgMap iface)+ (ifaceSubMap iface))+ | otherwise = return ([], (noDocForDecl, [])) where m = nameModule n + findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)]+ findBundledPatterns t =+ let+ m = nameModule t + local_bundled_patsyns =+ M.findWithDefault [] t patSynMap++ iface_bundled_patsyns+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap+ , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)+ = patsyns++ | Just iface <- M.lookup m instIfaceMap+ , Just patsyns <- M.lookup t (instBundledPatSynMap iface)+ = patsyns++ | otherwise+ = []++ patsyn_decls = do+ for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do+ -- call declWith here so we don't have to prepare the pattern synonym for+ -- showing ourselves.+ export_items <- declWith [] patsyn_name+ pure [ (unLoc patsyn_decl, patsyn_doc)+ | ExportDecl {+ expItemDecl = patsyn_decl+ , expItemMbDoc = patsyn_doc+ } <- export_items+ ]++ in concat <$> patsyn_decls++-- | Given a 'Module' from a 'Name', convert it into a 'Module' that+-- we can actually find in the 'IfaceMap'.+semToIdMod :: UnitId -> Module -> Module+semToIdMod this_uid m+ | Module.isHoleModule m = mkModule this_uid (moduleName m)+ | otherwise = m+ hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t@@ -639,7 +795,7 @@ mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name [])- Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)+ Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of@@ -673,13 +829,13 @@ -- only return those that are. -- 3) B is visible and all its exports are in scope, in which case we return -- a single 'ExportModule' item.-moduleExports :: Module -- ^ Module A+moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A- -> [LHsDecl Name] -- ^ All the declarations in A+ -> [LHsDecl Name] -- ^ All the renamed declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> Maps@@ -687,8 +843,11 @@ -> [SrcSpan] -- ^ Locations of all TH splices -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls+ | expMod == moduleName thisMod+ = fullModuleContents dflags warnings gre maps fixMap splices decls | otherwise =+ -- NB: we constructed the identity module when looking up in+ -- the IfaceMap. case M.lookup m ifaceMap of Just iface | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)@@ -704,7 +863,7 @@ "documentation for exported module: " ++ pretty dflags expMod] return [] where- m = mkModule unitId expMod+ m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod @@ -725,24 +884,44 @@ -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]+-- | Simplified variant of 'mkExportItems', where we can assume that+-- every locally defined declaration is exported; thus, we just+-- zip through the renamed declarations.+fullModuleContents :: DynFlags+ -> WarningMap+ -> GlobalRdrEnv -- ^ The renaming environment+ -> Maps+ -> FixMap+ -> [SrcSpan] -- ^ Locations of all TH splices+ -> [LHsDecl Name] -- ^ All the renamed declarations+ -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =- liftM catMaybes $ mapM mkExportItem (expandSig decls)+ liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) where -- A type signature can have multiple names, like: -- foo, bar :: Types.. -- -- We go through the list of declarations and expand type signatures, so -- that every type signature has exactly one name!- expandSig :: [LHsDecl name] -> [LHsDecl name]- expandSig = foldr f []+ expandSigDecls :: [LHsDecl name] -> [LHsDecl name]+ expandSigDecls = concatMap f where- f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]- f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names- f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names- f x xs = x : xs+ f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] + -- also expand type signatures for class methods+ f (L l (TyClD cls@ClassDecl{})) =+ [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ]+ f x = [x]++ expandLSig :: LSig name -> [LSig name]+ expandLSig (L l sig) = [ L l s | s <- expandSig sig ]++ expandSig :: Sig name -> [Sig name]+ expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ]+ expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]+ expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ]+ expandSig x = [x]+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do return . Just . ExportGroup lev "" $ processDocString dflags gre docStr@@ -756,11 +935,13 @@ | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap =- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))+ expInst decl l name+ mkExportItem decl@(L l (DerivD {}))+ | Just name <- M.lookup l instMap =+ expInst decl l name mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name@@ -769,16 +950,20 @@ fixities name subs = [ (n,f) | n <- name : map fst subs , Just f <- [M.lookup n fixMap] ] - expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))+ expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) where (doc, subs) = lookupDocs name warnings docMap argMap subMap + expInst decl l name =+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in+ return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) + -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...).-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name-extractDecl name mdl decl+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name+extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of@@ -800,11 +985,11 @@ O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))- in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))+ in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) ->- SigD <$> extractRecSel name mdl n tys (dd_cons defn)+ SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)@@ -814,19 +999,19 @@ , selectorFieldOcc n == name ] in case matches of- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"+extractRecSel _ _ _ [] = error "extractRecSel: selector not found" -extractRecSel nm mdl t tvs (L _ con : rest) =+extractRecSel nm t tvs (L _ con : rest) = case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))- _ -> extractRecSel nm mdl t tvs rest+ _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds@@ -834,7 +1019,7 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name]@@ -850,8 +1035,9 @@ | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where- exportName e@ExportDecl {} = name ++ subs- where subs = map fst (expItemSubDocs e)+ exportName e@ExportDecl {} = name ++ subs ++ patsyns+ where subs = map fst (expItemSubDocs e)+ patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap decl -> getMainDeclBinder decl@@ -882,10 +1068,11 @@ summary = pm_mod_summary . tm_parsed_module $ tm mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]-mkTokenizedSrc ms src =- Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc- where- rawSrc = readFile $ msHsFilePath ms+mkTokenizedSrc ms src = do+ -- make sure to read the whole file at once otherwise+ -- we run out of file descriptors (see #495)+ rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate+ return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc)) -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
src/Haddock/Interface/Rename.hs view
@@ -55,7 +55,7 @@ -- combine the missing names and filter out the built-ins, which would -- otherwise always be missing.- missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much+ missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) @@ -179,7 +179,7 @@ renameLSigType = renameImplicit renameLType renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)-renameLSigWcType = renameImplicit (renameWc renameLType)+renameLSigWcType = renameWc (renameImplicit renameLType) renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType@@ -219,7 +219,7 @@ ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n+ HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do@@ -238,6 +238,7 @@ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts+ HsSumTy ts -> HsSumTy <$> mapM renameLType ts HsOpTy a (L loc op) b -> do op' <- rename op@@ -261,7 +262,7 @@ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a)- HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b+ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a@@ -313,6 +314,11 @@ renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d +renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)]+renamePats = mapM+ (\(d,doc) -> do { d' <- renameDecl d+ ; doc' <- renameDocForDecl doc+ ; return (d',doc')}) renameDecl :: HsDecl Name -> RnM (HsDecl DocName) renameDecl decl = case decl of@@ -328,6 +334,9 @@ InstD d -> do d' <- renameInstD d return (InstD d')+ DerivD d -> do+ d' <- renameDerivD d+ return (DerivD d') _ -> error "renameDecl" renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))@@ -340,19 +349,19 @@ decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) - ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname@@ -363,6 +372,7 @@ at_defs' <- mapM renameLTyFamDefltEqn at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+ , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) @@ -376,7 +386,9 @@ renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname- , fdTyVars = ltyvars, fdResultSig = result+ , fdTyVars = ltyvars+ , fdFixity = fixity+ , fdResultSig = result , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info lname' <- renameL lname@@ -384,7 +396,9 @@ result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname'- , fdTyVars = ltyvars', fdResultSig = result'+ , fdTyVars = ltyvars'+ , fdFixity = fixity+ , fdResultSig = result' , fdInjectivityAnn = injectivity' }) @@ -412,7 +426,8 @@ cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType- , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })+ , dd_kindSig = k', dd_cons = cons'+ , dd_derivs = noLoc [] }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars@@ -467,10 +482,10 @@ lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty return (ClassOpSig is_default lnames' ltype')- PatSynSig lname sig_ty -> do- lname' <- renameL lname+ PatSynSig lnames sig_ty -> do+ lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty- return $ PatSynSig lname' sig_ty'+ return $ PatSynSig lnames' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity)@@ -503,6 +518,15 @@ d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) +renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)+renameDerivD (DerivDecl { deriv_type = ty+ , deriv_strategy = strat+ , deriv_overlap_mode = omode }) = do+ ty' <- renameLSigType ty+ return (DerivDecl { deriv_type = ty'+ , deriv_strategy = strat+ , deriv_overlap_mode = omode })+ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs@@ -523,30 +547,33 @@ , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = pats'+ , tfe_fixity = fixity , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))+renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs'+ , tfe_fixity = fixity , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' , dfid_pats = pats'+ , dfid_fixity = fixity , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameImplicit :: (in_thing -> RnM out_thing)@@ -555,7 +582,8 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing'- , hsib_vars = PlaceHolder }) }+ , hsib_vars = PlaceHolder+ , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing@@ -563,7 +591,7 @@ renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing'- , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }+ , hswc_wcs = PlaceHolder }) } renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) renameDocInstance (inst, idoc, L l n) = do@@ -578,15 +606,16 @@ ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc')- ExportDecl decl doc subs instances fixities splice -> do+ ExportDecl decl pats doc subs instances fixities splice -> do decl' <- renameLDecl decl+ pats' <- renamePats pats doc' <- renameDocForDecl doc subs' <- mapM renameSub subs instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity)- return (ExportDecl decl' doc' subs' instances' fixities' splice)+ return (ExportDecl decl' pats' doc' subs' instances' fixities' splice) ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs
src/Haddock/Interface/Specialize.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} - module Haddock.Interface.Specialize ( specializeInstHead ) where@@ -28,72 +28,64 @@ import Data.Set (Set) import qualified Data.Set as Set ---- | Instantiate all occurrences of given name with particular type.-specialize :: (Eq name, Typeable name)- => Data a- => name -> HsType name -> a -> a-specialize name details =- everywhere $ mkT step- where- step (HsTyVar (L _ name')) | name == name' = details- step typ = typ-- -- | Instantiate all occurrences of given names with corresponding types.------ It is just a convenience function wrapping 'specialize' that supports more--- that one specialization.-specialize' :: (Eq name, Typeable name)+specialize :: forall name a. (Ord name, DataId name, NamedThing name) => Data a => [(name, HsType name)] -> a -> a-specialize' = flip $ foldr (uncurry specialize)+specialize specs = go+ where+ go :: forall x. Data x => x -> x+ go = everywhereButType @name $ mkT $ sugar . specialize_ty_var+ specialize_ty_var (HsTyVar _ (L _ name'))+ | Just t <- Map.lookup name' spec_map = t+ specialize_ty_var typ = typ+ -- This is a tricky recursive definition that is guaranteed to terminate+ -- because a type binder cannot be instantiated with a type that depends+ -- on that binder. i.e. @a -> Maybe a@ is invalid+ spec_map = Map.fromList [ (n, go t) | (n, t) <- specs] -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders.-specializeTyVarBndrs :: (Eq name, DataId name)+specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name) => Data a => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs =- specialize' $ zip bndrs' typs+ specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs bname (UserTyVar (L _ name)) = name bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, DataId name)+specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl =- decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }- where- specializeTyVars = specializeTyVarBndrs bndrs typs-+ decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Eq name, DataId name, SetName name)+specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name specializeSig bndrs typs (TypeSig lnames typ) =- TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})+ TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType name- true_type = unLoc (hswc_body (hsib_body typ))+ true_type = unLoc (hsSigWcType typ) typ' :: HsType name- typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type+ typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type.-specializeInstHead :: (Eq name, DataId name, SetName name)+specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' }@@ -115,15 +107,10 @@ -- and @(a, b, c)@. sugar :: forall name. (NamedThing name, DataId name) => HsType name -> HsType name-sugar =- everywhere $ mkT step- where- step :: HsType name -> HsType name- step = sugarOperators . sugarTuples . sugarLists-+sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing name => HsType name -> HsType name-sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)+sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name@@ -137,7 +124,7 @@ where aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy (L _ typ')) = aux apps typ'- aux apps (HsTyVar (L _ name))+ aux apps (HsTyVar _ (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name@@ -149,7 +136,7 @@ sugarOperators :: NamedThing name => HsType name -> HsType name-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb where@@ -224,7 +211,7 @@ query term ctx = case cast term :: Maybe (HsType name) of Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs))- Just (HsTyVar (L _ name))+ Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx)@@ -267,12 +254,13 @@ HsQualTy <$> located renameContext lctxt <*> renameLType lt-renameType (HsTyVar name) = HsTyVar <$> located renameName name+renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr renameType (HsListTy lt) = HsListTy <$> renameLType lt renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt+renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt renameType (HsOpTy la lop lb) = HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb renameType (HsParTy lt) = HsParTy <$> renameLType lt@@ -284,8 +272,8 @@ renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt renameType t@(HsRecTy _) = pure t renameType t@(HsCoreTy _) = pure t-renameType (HsExplicitListTy ph ltys) =- HsExplicitListTy ph <$> renameLTypes ltys+renameType (HsExplicitListTy ip ph ltys) =+ HsExplicitListTy ip ph <$> renameLTypes ltys renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t
src/Haddock/InterfaceFile.hs view
@@ -38,6 +38,7 @@ import GHC hiding (NoLink) import GhcMonad (withSession) import HscTypes+import NameCache import IfaceEnv import Name import UniqFM@@ -81,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801)-binaryInterfaceVersion = 28+#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)+binaryInterfaceVersion = 31 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -125,6 +126,7 @@ -- put the main thing let bh = setUserData bh0 $ newWriteState (putName bin_symtab)+ (putName bin_symtab) (putFastString bin_dict) put_ bh iface @@ -370,31 +372,33 @@ instance Binary InstalledInterface where- put_ bh (InstalledInterface modu info docMap argMap- exps visExps opts subMap fixMap) = do+ put_ bh (InstalledInterface modu is_sig info docMap argMap+ exps visExps opts subMap patSynMap fixMap) = do put_ bh modu+ put_ bh is_sig put_ bh info- put_ bh docMap- put_ bh argMap+ lazyPut bh (docMap, argMap) put_ bh exps put_ bh visExps put_ bh opts put_ bh subMap+ put_ bh patSynMap put_ bh fixMap get bh = do modu <- get bh+ is_sig <- get bh info <- get bh- docMap <- get bh- argMap <- get bh+ ~(docMap, argMap) <- lazyGet bh exps <- get bh visExps <- get bh opts <- get bh subMap <- get bh+ patSynMap <- get bh fixMap <- get bh - return (InstalledInterface modu info docMap argMap- exps visExps opts subMap fixMap)+ return (InstalledInterface modu is_sig info docMap argMap+ exps visExps opts subMap patSynMap fixMap) instance Binary DocOption where
src/Haddock/Syb.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE Rank2Types #-}-+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb- ( everything, everythingWithState, everywhere+ ( everything, everythingButType, everythingWithState+ , everywhere, everywhereButType , mkT , combine ) where@@ -10,17 +13,42 @@ import Data.Data import Control.Applicative+import Data.Maybe+import Data.Foldable +-- | Returns true if a == t.+-- requires AllowAmbiguousTypes+isType :: forall a b. (Typeable a, Typeable b) => b -> Bool+isType _ = isJust $ eqT @a @b -- | Perform a query on each level of a tree. -- -- This is stolen directly from SYB package and copied here to not introduce -- additional dependencies.-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)-everything k f x = foldl k (f x) (gmapQ (everything k f) x)+ -> (forall a. Data a => a -> r)+everything k f x = foldl' k (f x) (gmapQ (everything k f) x) +-- | Variation of "everything" with an added stop condition+-- Just like 'everything', this is stolen from SYB package.+everythingBut :: (r -> r -> r)+ -> (forall a. Data a => a -> (r, Bool))+ -> (forall a. Data a => a -> r)+everythingBut k f x = let (v, stop) = f x+ in if stop+ then v+ else foldl' k v (gmapQ (everythingBut k f) x) +-- | Variation of "everything" that does not recurse into children of type t+-- requires AllowAmbiguousTypes+everythingButType ::+ forall t r. (Typeable t)+ => (r -> r -> r)+ -> (forall a. Data a => a -> r)+ -> (forall a. Data a => a -> r)+everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t+ -- | Perform a query with state on each level of a tree. -- -- This is the same as 'everything' but allows for stateful computations. In@@ -31,14 +59,29 @@ -> (forall a. Data a => a -> r) everythingWithState s k f x = let (r, s') = f x s- in foldl k r (gmapQ (everythingWithState s' k f) x)-+ in foldl' k r (gmapQ (everythingWithState s' k f) x) -- | Apply transformation on each level of a tree. -- -- Just like 'everything', this is stolen from SYB package. everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) everywhere f = f . gmapT (everywhere f)++-- | Variation on everywhere with an extra stop condition+-- Just like 'everything', this is stolen from SYB package.+everywhereBut :: (forall a. Data a => a -> Bool)+ -> (forall a. Data a => a -> a)+ -> (forall a. Data a => a -> a)+everywhereBut q f x+ | q x = x+ | otherwise = f (gmapT (everywhereBut q f) x)++-- | Variation of "everywhere" that does not recurse into children of type t+-- requires AllowAmbiguousTypes+everywhereButType :: forall t . (Typeable t)+ => (forall a. Data a => a -> a)+ -> (forall a. Data a => a -> a)+everywhereButType = everywhereBut (isType @t) -- | Create generic transformation. --
src/Haddock/Types.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies, RecordWildCards #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+ -- in module GHC.PlaceHolder+ {-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module : Haddock.Types@@ -77,6 +80,9 @@ -- | The module behind this interface. ifaceMod :: !Module + -- | Is this a signature?+ , ifaceIsSig :: !Bool+ -- | Original file name of the module. , ifaceOrigFilename :: !FilePath @@ -97,6 +103,9 @@ -- names of subordinate declarations mapped to their parent declarations. , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + -- | Bundled pattern synonym declarations for specific types.+ , ifaceBundledPatSynMap :: !(Map Name [Name])+ -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name)@@ -152,45 +161,53 @@ data InstalledInterface = InstalledInterface { -- | The module represented by this interface.- instMod :: Module+ instMod :: Module + -- | Is this a signature?+ , instIsSig :: Bool+ -- | Textual information about the module.- , instInfo :: HaddockModInfo Name+ , instInfo :: HaddockModInfo Name -- | Documentation of declarations originating from the module (including -- subordinates).- , instDocMap :: DocMap Name+ , instDocMap :: DocMap Name - , instArgMap :: ArgMap Name+ , instArgMap :: ArgMap Name -- | All names exported by this module.- , instExports :: [Name]+ , instExports :: [Name] -- | All \"visible\" names exported by the module. -- A visible name is a name that will show up in the documentation of the -- module.- , instVisibleExports :: [Name]+ , instVisibleExports :: [Name] -- | Haddock options for this module (prune, ignore-exports, etc).- , instOptions :: [DocOption]+ , instOptions :: [DocOption] - , instSubMap :: Map Name [Name]- , instFixMap :: Map Name Fixity+ , instSubMap :: Map Name [Name]++ , instBundledPatSynMap :: Map Name [Name]+ + , instFixMap :: Map Name Fixity } -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface- { instMod = ifaceMod interface- , instInfo = ifaceInfo interface- , instDocMap = ifaceDocMap interface- , instArgMap = ifaceArgMap interface- , instExports = ifaceExports interface- , instVisibleExports = ifaceVisibleExports interface- , instOptions = ifaceOptions interface- , instSubMap = ifaceSubMap interface- , instFixMap = ifaceFixMap interface+ { instMod = ifaceMod interface+ , instIsSig = ifaceIsSig interface+ , instInfo = ifaceInfo interface+ , instDocMap = ifaceDocMap interface+ , instArgMap = ifaceArgMap interface+ , instExports = ifaceExports interface+ , instVisibleExports = ifaceVisibleExports interface+ , instOptions = ifaceOptions interface+ , instSubMap = ifaceSubMap interface+ , instBundledPatSynMap = ifaceBundledPatSynMap interface+ , instFixMap = ifaceFixMap interface } @@ -207,6 +224,9 @@ -- | A declaration. expItemDecl :: !(LHsDecl name) + -- | Bundled patterns for a data type declaration+ , expItemPats :: ![(HsDecl name, DocForDecl name)]+ -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). , expItemMbDoc :: !(DocForDecl name)@@ -343,7 +363,8 @@ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance OutputableBndr a => Outputable (InstType a) where+instance (OutputableBndrId a)+ => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx <+> ppr clsiTyVars@@ -378,8 +399,8 @@ mkType (KindedTyVar (L loc name) lkind) = HsKindSig tvar lkind where- tvar = L loc (HsTyVar (L loc name))- mkType (UserTyVar name) = HsTyVar name+ tvar = L loc (HsTyVar NotPromoted (L loc name))+ mkType (UserTyVar name) = HsTyVar NotPromoted name -- | An instance head that may have documentation and a source location.
src/Haddock/Utils.hs view
@@ -128,7 +128,7 @@ mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables-mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name -- Add the class context to a class-op signature@@ -150,7 +150,7 @@ lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs- = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))+ = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] --------------------------------------------------------------------------------