From a5199600c39d25d7b71dcb2328000c1c49ad95a2 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 6 Feb 2019 01:01:41 -0800 Subject: Better identifier parsing * '(<|>)' and '`elem`' now get parsed and rendered properly as links * 'DbModule'/'DbUnitId' now properly get split apart into two links * tuple names now get parsed properly * some more small niceties... The identifier parsing code is more precise and more efficient (although to be fair: it is also longer and in its own module). On the rendering side, we need to pipe through information about backticks/parens/neither all the way through from renaming to the backends. In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc lib docs change. The only "regression" is things like '\0'. These should be changed to @\\0@ (the path by which this previously worked seems accidental). --- haddock-api/src/Haddock/InterfaceFile.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e1d8dbe1..7645b1bb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) -binaryInterfaceVersion = 34 +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -701,3 +701,28 @@ instance Binary DocName where name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" -- cgit v1.2.3 From 5bef8bd8a72465a0abb1753a8bbeb94634a9d698 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 11:46:42 -0400 Subject: Clean up warnings * unused imports * imports of `Data.List` without import lists * missing `CompatPrelude` file in `.cabal` --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 2 -- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 1 - haddock-api/src/Haddock/Utils/Json.hs | 2 +- haddock-library/haddock-library.cabal | 26 ++++++++++------------ haddock.cabal | 1 + 14 files changed, 22 insertions(+), 35 deletions(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1f98ef9c..b38d4047 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -27,10 +27,9 @@ import Haddock.Utils hiding (out) import GHC import Outputable -import NameSet import Data.Char -import Data.List +import Data.List (isPrefixOf, intercalate) import Data.Maybe import Data.Version diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index f2fb1041..63b12a14 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -38,7 +38,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List ( sort ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -517,12 +517,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = char '{' -ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) @@ -1063,7 +1057,6 @@ ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv ForallVis -> text "\\ " <> arrow unicode ForallInvis -> dot - ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c7ae15ca..b450dc94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,7 +36,6 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) -import qualified GHC import GHC.Exts import Name import BooleanFormula diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index edab4b16..0d7accfc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Data.List +import Data.List (intersperse) import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index c2c0d733..24568235 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -44,7 +44,7 @@ import Haddock.Utils import Control.Monad import Control.Exception (evaluate) -import Data.List +import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 35f24ee5..685dca01 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -21,7 +21,7 @@ import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) -import Data.List +import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d5cbdaf5..b182a615 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -32,7 +32,7 @@ import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) -import Data.List +import Data.List (find, foldl', sortBy) import Data.Maybe import Data.Ord import Control.Applicative diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 0b40ed3c..08a3c0f8 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,7 @@ module Haddock.Interface.LexParseRn import Control.Arrow import Control.Monad import Data.Functor (($>)) -import Data.List +import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 72d063dc..0b122b07 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -22,14 +22,12 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import Outputable ( panic ) import RdrName (RdrName(Exact)) import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b5be311a..3ce2fabb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -26,7 +26,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 79673365..3eb702c9 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -65,7 +65,6 @@ import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs index e3c3dddc..2270a547 100644 --- a/haddock-api/src/Haddock/Utils/Json.hs +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -19,7 +19,7 @@ import Data.Char import Data.Int import Data.String import Data.Word -import Data.List +import Data.List (intersperse) import Data.Monoid import Data.ByteString.Builder (Builder) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index e58fe2ef..294ef5be 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -59,22 +59,20 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: - test - src - - cpp-options: - -DTEST + test + src other-modules: - Documentation.Haddock.Doc - Documentation.Haddock.Markup - Documentation.Haddock.Parser - Documentation.Haddock.Parser.Monad - Documentation.Haddock.Parser.Util - Documentation.Haddock.Parser.UtilSpec - Documentation.Haddock.ParserSpec - Documentation.Haddock.Types - Documentation.Haddock.Parser.Identifier + CompatPrelude + Documentation.Haddock.Doc + Documentation.Haddock.Markup + Documentation.Haddock.Parser + Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Util + Documentation.Haddock.Parser.UtilSpec + Documentation.Haddock.ParserSpec + Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.11.0 diff --git a/haddock.cabal b/haddock.cabal index 92fe249e..425ed454 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -87,6 +87,7 @@ executable haddock transformers other-modules: + CompatPrelude Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Identifier -- cgit v1.2.3 From 03dbfdd70186e484135ba1ea8d27672264cd9712 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 20:10:52 -0400 Subject: Tentative 2.24 release Adjusted changelogs and versions in `.cabal` files in preparation for the upcoming release bundled with GHC 8.10. --- CHANGES.md | 7 +++++++ haddock-api/haddock-api.cabal | 6 +++--- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/CHANGES.md | 4 +++- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 4 ++-- 7 files changed, 18 insertions(+), 9 deletions(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/CHANGES.md b/CHANGES.md index 88656da4..b0600381 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +## Changes in 2.24.0 + + * Reify oversaturated data family instances correctly (#1103) + + * Removed the majority of Haddock's possible `panic` routes through + the TTG refactor to make extension variants empty + ## Changes in 2.23.0 * "Linuwial" is the new default theme (#721, #782, #949) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 8ad0ae64..0324fcd6 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -45,7 +45,7 @@ library build-depends: base ^>= 4.14.0 , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -167,7 +167,7 @@ test-suite spec build-depends: ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.12 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8 , QuickCheck >= 2.11 && < 2.14 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b38d4047..b4a605f2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -260,7 +260,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k - tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" + tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 3ce2fabb..17be6fa1 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811) -binaryInterfaceVersion = 35 +binaryInterfaceVersion = 36 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index d112db45..5b400d7c 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,7 +1,9 @@ -## Changes in version 1.8.0.1 +## Changes in version 1.9.0 * Fix build-time regression for `base < 4.7` (#1119) + * Update parsing to strip whitespace from table cells (#1074) + ## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 294ef5be..57f45887 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: haddock-library -version: 1.8.0.1 +version: 1.9.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell diff --git a/haddock.cabal b/haddock.cabal index 425ed454..f01fe8fc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: haddock -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -144,7 +144,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.23.0 + build-depends: haddock-api == 2.24.0 test-suite html-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From e68cc0f05c102193660466d611640aec922bc9a9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 08:50:57 -0400 Subject: Remove unused `Haddock.Utils` functions * removed functions in `Haddock.Utils` that were not used anywhere (or exported from the `haddock-api` package) * moved GHC-specific utils from `Haddock.Utils` to `Haddock.GhcUtils` --- haddock-api/src/Haddock.hs | 1 + haddock-api/src/Haddock/Backends/Xhtml.hs | 4 + haddock-api/src/Haddock/GhcUtils.hs | 91 ++++++++++++++++++ haddock-api/src/Haddock/Interface.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 150 +----------------------------- 6 files changed, 102 insertions(+), 147 deletions(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index cf7bd857..0b5e33a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 9add4cae..d30312b7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -294,6 +294,10 @@ ppHtmlContents dflags odir doctitle _maybe_package ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + where + -- Extract a module's short description. + toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) + toInstalledDescription = fmap mkMeta . hmi_description . instInfo ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 6577e08f..77d6ec39 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -20,9 +20,11 @@ module Haddock.GhcUtils where import Control.Arrow import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) +import BasicTypes ( PromotionFlag(..) ) import Exception import FV import Outputable ( Outputable, panic, showPpr ) @@ -253,6 +255,95 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" getGADTConTypeG (XConDecl nec) = noExtCon nec +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) + + +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn +-- Add the class context to a class-op signature +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + + +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn +restrictTo names (L loc decl) = L loc $ case decl of + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn +restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) + | DataType <- new_or_data + = defn { dd_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { dd_ND = DataType, dd_cons = [] } + [con] -> defn { dd_cons = [con] } + _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" + +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case con_args d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + where + field_avail :: LConDeclField GhcRn -> Bool + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + field_avail (L _ (XConDeclField nec)) = noExtCon nec + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + + keep _ = Nothing + +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] +restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] + + ------------------------------------------------------------------------------- -- * Parenthesization ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 24568235..6775cf2b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -43,6 +43,7 @@ import Haddock.Types import Haddock.Utils import Control.Monad +import Control.Monad.IO.Class ( liftIO ) import Control.Exception (evaluate) import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 17be6fa1..7b0f29f4 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -21,9 +21,9 @@ module Haddock.InterfaceFile ( import Haddock.Types -import Haddock.Utils hiding (out) import Control.Monad +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Array import Data.IORef import Data.List (mapAccumR) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3eb702c9..1d213420 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -13,15 +13,9 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, - -- * Filename utilities moduleHtmlFile, moduleHtmlFile', contentsHtmlFile, indexHtmlFile, indexJsonFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, haddockJsFile, jsQuickJumpFile, quickJumpCssFile, @@ -32,7 +26,7 @@ module Haddock.Utils ( makeAnchorId, -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + getProgramName, bye, die, escapeStr, writeUtf8File, withTempDir, -- * HTML cross reference mapping @@ -45,9 +39,6 @@ module Haddock.Utils ( replace, spanWith, - -- * MTL stuff - MonadIO(..), - -- * Logging parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, @@ -61,23 +52,21 @@ import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils -import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Control.Monad ( liftM ) +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit import System.Directory ( createDirectory, removeDirectoryRecursive ) -import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -85,8 +74,6 @@ import qualified System.FilePath.Posix as HtmlPath import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) ) - -------------------------------------------------------------------------------- -- * Logging @@ -129,117 +116,14 @@ out progVerbosity msgVerbosity msg -------------------------------------------------------------------------------- --- | Extract a module's short description. -toDescription :: Interface -> Maybe (MDoc Name) -toDescription = fmap mkMeta . hmi_description . ifaceInfo - - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) -toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) - -addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn --- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious - where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) - add_ctxt (L loc preds) = L loc (extra_pred : preds) - -addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine - -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] -lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) - | tv <- hsQTvExplicit tvs ] - --------------------------------------------------------------------------------- --- * Making abstract declarations --------------------------------------------------------------------------------- - - -restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn -restrictTo names (L loc decl) = L loc $ case decl of - TyClD x d | isDataDecl d -> - TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD x d | isClassDecl d -> - TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" - -restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField _ fs _ _)) - = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField nec)) = noExtCon nec - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] - - keep _ = Nothing - -restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsQTyVars GhcRn --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs" - , hsq_explicit = [] } - - -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -266,13 +150,6 @@ indexHtmlFile = "doc-index.html" indexJsonFile = "doc-index.json" - -moduleIndexFrameName, mainFrameName, synopsisFrameName :: String -moduleIndexFrameName = "modules" -mainFrameName = "main" -synopsisFrameName = "synopsis" - - subIndexHtmlFile :: String -> String subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" where b | all isAlpha ls = ls @@ -346,7 +223,7 @@ quickJumpCssFile = "quick-jump.css" getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName +getProgramName = fmap (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str @@ -355,25 +232,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a bye s = putStr s >> exitSuccess - -dieMsg :: String -> IO () -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = liftM Just (f a) - - escapeStr :: String -> String escapeStr = escapeURIString isUnreserved -- cgit v1.2.3 From 8edc70fef3f3a54238d981153a6ac42b2d7f0bde Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 13:12:50 -0400 Subject: Cleanup up GHC flags in `.cabal` files * enable more useful warning flags in `haddock-api`, handle the new warnings generated * remove `-fwarn-tabs` (now we'd use `-Wtabs`, but this has been in `-Wall` for a while now) --- haddock-api/haddock-api.cabal | 12 ++++++++---- haddock-api/src/Haddock/Interface/Specialize.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 5 files changed, 12 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 54255e09..4abfd984 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -63,10 +63,14 @@ library 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 + ghc-options: -funbox-strict-fields -O2 + -Wall + -Wcompat + -Widentities + -Wredundant-constraints + -Wnoncanonical-monad-instances + -Wmissing-home-modules + exposed-modules: Documentation.Haddock diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 19b03596..492818bd 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -295,7 +295,7 @@ renameBinder (KindedTyVar x lname lkind) = renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 7b0f29f4..cb60fb00 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -158,7 +158,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 1a06d0e5..24ca920f 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -44,7 +44,7 @@ common lib-defaults , text ^>= 1.2.3.0 , parsec ^>= 3.1.13.0 - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs + ghc-options: -funbox-strict-fields -Wall if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances diff --git a/haddock.cabal b/haddock.cabal index f01fe8fc..1d6ad180 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From 28b6b667a4f6cfb79d84ce48b6e4a1dd4592cc21 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 28 Jul 2020 13:06:53 -0400 Subject: Bump GHC version to 9.0 --- haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock.cabal | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/InterfaceFile.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 759e12f6..be707166 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -45,7 +45,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.15.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.11 + , ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 39de2395..9686de1f 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if MIN_VERSION_ghc(8,11,0) && !MIN_VERSION_ghc(8,13,0) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) binaryInterfaceVersion = 34 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock.cabal b/haddock.cabal index 52113bd1..45acf494 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -33,7 +33,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.12.*, GHC==8.10.*, GHC==8.8.1 +tested-with: GHC==9.0.*, GHC==8.10.* extra-source-files: CHANGES.md @@ -80,7 +80,7 @@ executable haddock Cabal >= 1.10, ghc-boot, ghc-boot-th, - ghc == 8.11.*, + ghc == 9.0.*, bytestring, parsec, text, -- cgit v1.2.3