From b2a807da55d197c648fd2df1f156f9862711d92b Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 27 Aug 2014 13:49:31 +0100 Subject: Changes due to ghc api changes in package representation Also fix a bug with finding the package name and version given a module. This had become wrong due to the package key changes (it was very hacky in the first place). We now look up the package key in the package db to get the package info properly. --- src/Haddock.hs | 13 ++++++++----- src/Haddock/Backends/Hoogle.hs | 6 ++++-- src/Haddock/GhcUtils.hs | 25 +++++-------------------- 3 files changed, 17 insertions(+), 27 deletions(-) diff --git a/src/Haddock.hs b/src/Haddock.hs index 024b1098..bed47625 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -42,7 +42,6 @@ import Data.IORef import qualified Data.Map as Map import System.IO import System.Exit -import System.Directory #if defined(mingw32_HOST_OS) import Foreign @@ -63,6 +62,8 @@ import DynFlags hiding (verbosity) import StaticFlags (discardStaticFlags) import Panic (handleGhcException) import Module +import PackageConfig +import FastString -------------------------------------------------------------------------------- -- * Exception handling @@ -242,7 +243,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgMod = ifaceMod (head ifaces) pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo pkgMod + (pkgName,pkgVer) = modulePackageInfo dflags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -276,14 +277,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do copyHtmlBits odir libDir themes when (Flag_Hoogle `elem` flags) $ do - let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] + = title + | otherwise = unpackFS pkgNameFS + where PackageName pkgNameFS = pkgName + ppHoogle dflags pkgNameStr pkgVer title prologue visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style libDir - ------------------------------------------------------------------------------- -- * Reading and dumping interface files ------------------------------------------------------------------------------- diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 628e1cd0..13145298 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -25,6 +25,7 @@ import Outputable import Data.Char import Data.List import Data.Maybe +import Data.Version import System.FilePath import System.IO @@ -34,13 +35,14 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ - ["@version " ++ version | version /= ""] ++ + ["@version " ++ showVersion version + | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] h <- openFile (odir filename) WriteMode hSetEncoding h utf8 diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 33d92131..2c7b79a1 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -22,8 +22,6 @@ import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Function import Data.Traversable -import Distribution.Compat.ReadP -import Distribution.Text import Exception import Outputable @@ -43,24 +41,11 @@ moduleString = moduleNameString . moduleName -- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageKey pkg of - Nothing -> (packageKeyString pkg, "") - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) - where pkg = modulePackageKey modu - - --- This was removed from GHC 6.11 --- XXX we shouldn't be using it, probably - --- | Try and interpret a GHC 'PackageKey' as a cabal 'PackageIdentifer'. Returns @Nothing@ if --- we could not parse it as such an object. -unpackPackageKey :: PackageKey -> Maybe PackageIdentifier -unpackPackageKey p - = case [ pid | (pid,"") <- readP_to_S parse str ] of - [] -> Nothing - (pid:_) -> Just pid - where str = packageKeyString p +modulePackageInfo :: DynFlags -> Module -> (PackageName, Version) +modulePackageInfo dflags modu = + (packageName pkg, packageVersion pkg) + where + pkg = getPackageDetails dflags (modulePackageKey modu) lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) -- cgit v1.2.3 From eee52f697233f99e23c1d8183511229fb93e3f3e Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 31 Aug 2014 11:23:53 +0200 Subject: Import Data.Word w/o import-list This is needed to keep the compilation warning free (and thus pass GHC's ./validate) regardless of whether Word is re-exported from Prelude or not See https://ghc.haskell.org/trac/ghc/ticket/9531 for more details --- .../vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs index eda8fd88..576dded9 100644 --- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs @@ -129,7 +129,7 @@ import Data.Bits (Bits, (.|.), shiftL) import Data.ByteString.Internal (c2w, w2c) import Data.Int (Int8, Int16, Int32, Int64) import Data.String (IsString(..)) -import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Word import Prelude hiding (takeWhile) import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Internal as I -- cgit v1.2.3 From aacaa91951b16f22e3ad54412974b81c32230a8c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 5 Sep 2014 18:13:24 -0500 Subject: Follow changes to TypeAnnot in GHC HEAD Signed-off-by: Austin Seipp --- src/Haddock/Convert.hs | 10 +++++----- src/Haddock/Interface/Rename.hs | 27 +++++++++++++++++++++------ 2 files changed, 26 insertions(+), 11 deletions(-) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index dfb0f14f..48306392 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -81,7 +81,7 @@ tyThingToLHsDecl t = noLoc $ case t of , tcdATs = atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } | otherwise -> TyClD (synifyTyCon Nothing tc) @@ -118,7 +118,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenSynFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNames })) + , tfid_fvs = placeHolderNamesTc })) | Just ax' <- isClosedSynFamilyTyCon_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error @@ -148,7 +148,7 @@ synifyTyCon coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing } - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } | isSynFamilyTyCon tc = case synTyConRhs_maybe tc of @@ -177,7 +177,7 @@ synifyTyCon coax tc SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } _ -> error "synifyTyCon: impossible synTyCon" | otherwise = -- (closed) newtype and data @@ -217,7 +217,7 @@ synifyTyCon coax tc , dd_cons = cons , dd_derivs = alg_deriv } in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index a804f4a1..dd2bd73f 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -20,6 +21,8 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import NameSet +import Coercion import Control.Applicative import Control.Monad hiding (mapM) @@ -177,6 +180,7 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind + renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do @@ -303,17 +307,17 @@ renameTyClD d = case d of decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs }) + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -466,7 +470,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = pats_w_bndrs { hswb_cts = pats' } + , tfe_pats = HsWB pats' PlaceHolder PlaceHolder , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) @@ -483,7 +487,9 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' } + ; return (DataFamInstDecl { dfid_tycon = tc' + , dfid_pats + = HsWB pats' PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) @@ -518,3 +524,12 @@ renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder -- cgit v1.2.3 From 0cc5bc85e9fca92ab712b68a2ba2c0dd9d3d79f4 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Tue, 9 Sep 2014 01:03:27 -0500 Subject: Fix import of 'empty' due to AMP. Signed-off-by: Austin Seipp --- src/Haddock/Backends/LaTeX.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 7b72c030..eca22077 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -31,7 +31,7 @@ import qualified Data.Map as Map import System.Directory import System.FilePath import Data.Char -import Control.Monad +import Control.Monad hiding (empty) import Data.Maybe import Data.List -- cgit v1.2.3 From c3a7d4701ee64f6c29b95a6bed519f6c16b9bffd Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Tue, 9 Sep 2014 17:35:20 +0200 Subject: Bump `base` constraint for AMP --- haddock.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock.cabal b/haddock.cabal index ef645266..01ab35d4 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -71,7 +71,7 @@ executable haddock ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 build-depends: - base >= 4.3 && < 4.8 + base >= 4.3 && < 4.9 if flag(in-ghc-tree) hs-source-dirs: src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE @@ -140,7 +140,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.3 && < 4.8, + base >= 4.3 && < 4.9, bytestring, filepath, directory, -- cgit v1.2.3 From 4023817d7c0e46db012ba2eea28022626841ca9b Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Sun, 14 Sep 2014 14:08:35 +0200 Subject: Followup changes to addition of -fwarn-context-quantification (GHC Trac #4426) --- src/Haddock/Backends/Hoogle.hs | 1 + src/Haddock/Backends/LaTeX.hs | 5 ++++- src/Haddock/Backends/Xhtml/Decl.hs | 3 ++- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 13145298..4535ce5c 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -134,6 +134,7 @@ ppSig dflags (TypeSig names sig) prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c + HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c x -> x ppSig _ _ = [] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index eca22077..014f3350 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -402,6 +402,8 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Qualified a lctxt ltype) + = do_args n leader (HsForAllTy Implicit a lctxt ltype) do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ @@ -621,6 +623,7 @@ ppConstrHdr forall tvs ctxt unicode where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Qualified -> empty Implicit -> empty @@ -871,7 +874,7 @@ ppForAll expl tvs cxt unicode | otherwise = ppLContext cxt unicode where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 0429580c..829c6668 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -650,6 +650,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual where ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " + Qualified -> noHtml Implicit -> noHtml @@ -812,7 +813,7 @@ ppForAll expl tvs cxt unicode qual | otherwise = ppLContext cxt unicode qual where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -- cgit v1.2.3 From ee47a1ab37699db0573c9cf0aa6461e1f8865197 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 18 Sep 2014 13:38:11 -0700 Subject: Properly render package ID (not package key) in index, fixes #329. Signed-off-by: Edward Z. Yang --- src/Haddock.hs | 4 ++-- src/Haddock/Backends/Xhtml.hs | 14 ++++++++------ src/Haddock/ModuleTree.hs | 13 ++++++++----- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/src/Haddock.hs b/src/Haddock.hs index bed47625..980926cd 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -262,14 +262,14 @@ render dflags flags qual ifaces installedIfaces srcMap = do copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title pkgStr + ppHtmlContents dflags odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do - ppHtml title pkgStr visibleIfaces odir + ppHtml dflags title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 192c708a..b6a1190d 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -60,7 +60,8 @@ import Module -------------------------------------------------------------------------------- -ppHtml :: String +ppHtml :: DynFlags + -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] -> FilePath -- ^ Destination directory @@ -75,7 +76,7 @@ ppHtml :: String -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () -ppHtml doctitle maybe_package ifaces odir prologue +ppHtml dflags doctitle maybe_package ifaces odir prologue themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug = do @@ -84,7 +85,7 @@ ppHtml doctitle maybe_package ifaces odir prologue visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $ - ppHtmlContents odir doctitle maybe_package + ppHtmlContents dflags odir doctitle maybe_package themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents @@ -239,7 +240,8 @@ moduleInfo iface = ppHtmlContents - :: FilePath + :: DynFlags + -> FilePath -> String -> Maybe String -> Themes @@ -250,10 +252,10 @@ ppHtmlContents -> Bool -> Qualification -- ^ How to qualify names -> IO () -ppHtmlContents odir doctitle _maybe_package +ppHtmlContents dflags odir doctitle _maybe_package themes maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do - let tree = mkModuleTree showPkgs + let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html = headHtml doctitle Nothing themes +++ diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs index 28c5c06d..cb926685 100644 --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -15,18 +15,21 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( Doc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, - packageKeyString ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import DynFlags ( DynFlags ) +import Packages ( lookupPackage ) +import PackageConfig ( sourcePackageIdString ) data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] -mkModuleTree showPkgs mods = +mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] +mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) | otherwise = Nothing fn (mod_,pkg,short) = addToTrees mod_ pkg short -- cgit v1.2.3 From 3f57c2423252731487f66f503b5119c3becf4673 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Thu, 18 Sep 2014 23:57:37 +0200 Subject: Disambiguate string-literals GHC fails type-inference with `OverloadedStrings` + `Data.Foldable.elem` otherwise. --- haddock-library/src/Documentation/Haddock/Parser.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 68d9ecec..e8bc2761 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -199,7 +199,7 @@ moduleName = DocModule <$> (char '"' *> modid <* char '"') -- accept {small | large | digit | ' } here. But as we can't -- match on unicode characters, this is currently not possible. -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n")) + <*> (decodeUtf8 <$> takeWhile (`notElem` (" .&[{}(=*)+]!|@/;,^?\"\n"::String))) -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. @@ -271,7 +271,7 @@ innerList item = do -- | Parses definition lists. definitionList :: Parser [(DocH mod Identifier, DocH mod Identifier)] definitionList = do - label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` "]\n")) <* "]" + label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` ("]\n"::String))) <* "]" c <- takeLine (cs, items) <- more definitionList let contents = parseString . dropNLs . unlines $ c : cs @@ -456,7 +456,7 @@ autoUrl = mkLink <$> url url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) mkLink :: BS.ByteString -> DocH mod a mkLink s = case unsnoc s of - Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) <> DocString [x] + Just (xs, x) | x `elem` (",.!?"::String) -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) <> DocString [x] _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) -- | Parses strings between identifier delimiters. Consumes all input that it @@ -473,7 +473,7 @@ parseValid = do <|> return vs _ -> fail "outofvalid" where - idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^") + idChar = satisfy (`elem` ("_.!#$%&*+/<=>?@\\|-~:^"::String)) <|> digit <|> letter_ascii -- | Parses UTF8 strings from ByteString streams. -- cgit v1.2.3 From db14fd8ab4fab43694139bc203808b814eafb2dc Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Fri, 19 Sep 2014 00:10:36 +0200 Subject: Revert "Followup changes to addition of -fwarn-context-quantification" This reverts commit 4023817d7c0e46db012ba2eea28022626841ca9b temporarily as the respective feature hasn't landed in GHC HEAD yet, but this commit blocks later commits from being referenced in GHC HEAD. --- src/Haddock/Backends/Hoogle.hs | 1 - src/Haddock/Backends/LaTeX.hs | 5 +---- src/Haddock/Backends/Xhtml/Decl.hs | 3 +-- 3 files changed, 2 insertions(+), 7 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 4535ce5c..13145298 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -134,7 +134,6 @@ ppSig dflags (TypeSig names sig) prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c - HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c x -> x ppSig _ _ = [] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 014f3350..eca22077 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -402,8 +402,6 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Qualified a lctxt ltype) - = do_args n leader (HsForAllTy Implicit a lctxt ltype) do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ @@ -623,7 +621,6 @@ ppConstrHdr forall tvs ctxt unicode where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty Implicit -> empty @@ -874,7 +871,7 @@ ppForAll expl tvs cxt unicode | otherwise = ppLContext cxt unicode where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 829c6668..0429580c 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -650,7 +650,6 @@ ppConstrHdr forall_ tvs ctxt unicode qual where ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml Implicit -> noHtml @@ -813,7 +812,7 @@ ppForAll expl tvs cxt unicode qual | otherwise = ppLContext cxt unicode qual where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -- cgit v1.2.3 From 12dc730e62236e15f1194ddc8260affc24928bd1 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 18 Sep 2014 15:32:15 -0700 Subject: Revert "Revert "Followup changes to addition of -fwarn-context-quantification"" This reverts commit db14fd8ab4fab43694139bc203808b814eafb2dc. It's in HEAD now. --- src/Haddock/Backends/Hoogle.hs | 1 + src/Haddock/Backends/LaTeX.hs | 5 ++++- src/Haddock/Backends/Xhtml/Decl.hs | 3 ++- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 13145298..4535ce5c 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -134,6 +134,7 @@ ppSig dflags (TypeSig names sig) prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c + HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c x -> x ppSig _ _ = [] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index eca22077..014f3350 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -402,6 +402,8 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Qualified a lctxt ltype) + = do_args n leader (HsForAllTy Implicit a lctxt ltype) do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ @@ -621,6 +623,7 @@ ppConstrHdr forall tvs ctxt unicode where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Qualified -> empty Implicit -> empty @@ -871,7 +874,7 @@ ppForAll expl tvs cxt unicode | otherwise = ppLContext cxt unicode where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 0429580c..829c6668 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -650,6 +650,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual where ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " + Qualified -> noHtml Implicit -> noHtml @@ -812,7 +813,7 @@ ppForAll expl tvs cxt unicode qual | otherwise = ppLContext cxt unicode qual where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} + is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -- cgit v1.2.3 From a65d2131647e010608d2a1956116a0012946838f Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Fri, 26 Sep 2014 19:18:28 +0200 Subject: Revert "Fix import of 'empty' due to AMP." This reverts commit 0cc5bc85e9fca92ab712b68a2ba2c0dd9d3d79f4 since it turns out we don't need to re-export `empty` from Control.Monad after all. --- src/Haddock/Backends/LaTeX.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 014f3350..06a24b4f 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -31,7 +31,7 @@ import qualified Data.Map as Map import System.Directory import System.FilePath import Data.Char -import Control.Monad hiding (empty) +import Control.Monad import Data.Maybe import Data.List -- cgit v1.2.3 From 2f639ffe09dd24d8648363b567de2d7caa39db99 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 9 Oct 2014 21:38:11 -0700 Subject: Fix use-after-close lazy IO bug Make `getPrologue` force `parseParas dflags str` before returning. Without this, it will attempt to read from the file after it is closed, with unspecified and generally bad results. Signed-off-by: David Feuer Signed-off-by: Edward Z. Yang --- src/Haddock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haddock.hs b/src/Haddock.hs index 980926cd..c0a6714b 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -451,7 +451,7 @@ getPrologue dflags flags = [filename] -> withFile filename ReadMode $ \h -> do hSetEncoding h utf8 str <- hGetContents h - return . Just $ parseParas dflags str + return . Just $! parseParas dflags str _ -> throwE "multiple -p/--prologue options" -- cgit v1.2.3 From c72175b89bfe2759b7f8d5519fda25ed8bfd27a5 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Mon, 20 Oct 2014 20:05:27 -0500 Subject: Add an .arcconfig file. Signed-off-by: Austin Seipp --- .arcconfig | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 .arcconfig diff --git a/.arcconfig b/.arcconfig new file mode 100644 index 00000000..0693c58f --- /dev/null +++ b/.arcconfig @@ -0,0 +1,5 @@ +{ + "project.name" : "haddock", + "repository.callsign" : "HADDOCK", + "phabricator.uri" : "https://phabricator.haskell.org" +} -- cgit v1.2.3 From c3f27a96bd2a1ec14f441c72a2df95c16c2c5408 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Mon, 20 Oct 2014 20:07:01 -0500 Subject: Add .arclint file. Signed-off-by: Austin Seipp --- .arclint | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 .arclint diff --git a/.arclint b/.arclint new file mode 100644 index 00000000..01f217d7 --- /dev/null +++ b/.arclint @@ -0,0 +1,24 @@ +{ + "linters": { + "filename": { + "type": "filename" + }, + "generated": { + "type": "generated" + }, + "merge-conflict": { + "type": "merge-conflict" + }, + "nolint": { + "type": "nolint" + }, + "haskell": { + "type": "text", + "include": ["(\\.(l?hs(-boot)?|x|y\\.pp)(\\.in)?$)"], + "severity": { + "5": "disabled", + "2": "warning" + } + } + } +} -- cgit v1.2.3 From 3fb325a2ca6b6397905116024922d079447a2e08 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 28 Oct 2014 21:57:49 +0000 Subject: Experimental support for collapsable headers (cherry picked from commit e2ed3b9d8dfab09f1b1861dbc8e74f08e137ebcc) --- src/Haddock/Backends/Xhtml.hs | 17 +++-- src/Haddock/Backends/Xhtml/Decl.hs | 14 +++-- src/Haddock/Backends/Xhtml/DocMarkup.hs | 106 +++++++++++++++++++++++++++++--- src/Haddock/Backends/Xhtml/Layout.hs | 9 +-- 4 files changed, 117 insertions(+), 29 deletions(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index b6a1190d..38382871 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -544,7 +544,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc - where doc = docSection qual (ifaceRnDoc iface) + where doc = docSection Nothing qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -592,7 +592,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - [groupTag lvl << docToHtml qual txt] + [groupTag lvl << docToHtml Nothing qual txt] processForMiniSynopsis _ _ _ _ = [] @@ -609,7 +609,6 @@ ppTyClBinderWithVarsMini mdl 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] -> Html ppModuleContents qual exports | null sections = noHtml @@ -627,10 +626,10 @@ ppModuleContents qual exports | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where - html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs - (ssecs, rest1) = process lev rest - (secs, rest2) = process n rest1 + html = linkedAnchor (groupId id0) + << docToHtmlNoAnchors (Just id0) qual doc +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 process n (_ : rest) = process n rest mk_subsections [] = noHtml @@ -652,7 +651,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocName -> Maybe Html processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc + = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual 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 _ _ qual (ExportNoDecl y []) @@ -662,7 +661,7 @@ processExport summary _ _ qual (ExportNoDecl y subs) ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs) processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection_ qual doc + = nothingIf summary $ docSection_ Nothing qual doc processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 829c6668..d4869abd 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -28,6 +28,7 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) +import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -89,7 +90,7 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) - +++ docSection qual doc + +++ docSection Nothing qual doc where pref1 = hsep [ toHtml "pattern" , pp_cxt prov @@ -130,10 +131,11 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> Splice -> Unicode -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection qual doc + subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc where + curName = getName <$> listToMaybe docnames argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t @@ -263,7 +265,7 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> ppTyFam summary associated links instances fixities loc doc decl splice unicode qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection qual doc +++ instancesBit + | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit where docname = unLoc $ fdLName decl @@ -439,7 +441,7 @@ ppClassDecl summary links instances fixities loc d subdocs , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) splice unicode qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual - | otherwise = classheader +++ docSection qual d + | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where classheader @@ -558,7 +560,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl splice unicode qual | summary = ppShortDataDecl summary False dataDecl unicode qual - | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit + | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit where docname = tcdName dataDecl diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 5e27d9b0..741e97e0 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -31,6 +31,7 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) import GHC +import Name parHtmlMarkup :: Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html @@ -86,26 +87,108 @@ parHtmlMarkup qual insertAnchors ppId = Markup { htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] +-- | We use this intermediate type to transform the input 'Doc' tree +-- in an arbitrary way before rendering, such as grouping some +-- elements. This is effectivelly a hack to prevent the 'Doc' type +-- from changing if it is possible to recover the layout information +-- we won't need after the fact. +data Hack a id = + UntouchedDoc (DocH a id) + | CollapsingHeader (Header (DocH a id)) (DocH a id) Int (Maybe String) + | HackAppend (Hack a id) (Hack a id) + deriving Eq + +-- | Group things under bold 'DocHeader's together. +toHack :: Int -- ^ Counter for header IDs which serves to assign + -- unique identifiers within the comment scope + -> Maybe String + -- ^ It is not enough to have unique identifier within the + -- scope of the comment: if two different comments have the + -- same ID for headers, the collapse/expand behaviour will act + -- on them both. This serves to make each header a little bit + -- more unique. As we can't export things with the same names, + -- this should work more or less fine: it is in fact the + -- implicit assumption the collapse/expand mechanism makes for + -- things like ‘Instances’ boxes. + -> [DocH a id] -> Hack a id +toHack _ _ [] = UntouchedDoc DocEmpty +toHack _ _ [x] = UntouchedDoc x +toHack n nm (DocHeader (Header l (DocBold x)):xs) = + let -- Header with dropped bold + h = Header l x + -- Predicate for takeWhile, grab everything including ‘smaller’ + -- headers + p (DocHeader (Header l' _)) = l' > l + p _ = True + -- Stuff ‘under’ this header + r = takeWhile p xs + -- Everything else that didn't make it under + r' = drop (length r) xs + app y [] = y + app y ys = HackAppend y (toHack (n + 1) nm ys) + in case r of + -- No content under this header + [] -> CollapsingHeader h DocEmpty n nm `app` r' + -- We got something out, stitch it back together into one chunk + y:ys -> CollapsingHeader h (foldl DocAppend y ys) n nm `app` r' +toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs) + +-- | Remove ‘top-level’ 'DocAppend's turning them into a flat list. +-- This lends itself much better to processing things in order user +-- might look at them, such as in 'toHack'. +flatten :: DocH a id -> [DocH a id] +flatten (DocAppend x y) = flatten x ++ flatten y +flatten x = [x] + +-- | Generate the markup needed for collapse to happen. For +-- 'UntouchedDoc' and 'HackAppend' we do nothing more but +-- extract/append the underlying 'Doc' and convert it to 'Html'. For +-- 'CollapsingHeader', we attach extra info to the generated 'Html' +-- that allows us to expand/collapse the content. +hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html +hackMarkup fmt h = case h of + UntouchedDoc d -> markup fmt d + CollapsingHeader (Header lvl titl) par n nm -> + let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n + col' = collapseControl id_ True "caption" + instTable = (thediv ! collapseSection id_ True [] <<) + lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] + getHeader = fromMaybe caption (lookup lvl lvs) + subCation = getHeader ! col' << markup fmt titl + in (subCation +++) . instTable $ markup fmt par + HackAppend d d' -> markupAppend fmt (hackMarkup fmt d) (hackMarkup fmt d') + +-- | Goes through 'hackMarkup' to generate the 'Html' rather than +-- skipping straight to 'markup': this allows us to employ XHtml +-- specific hacks to the tree before first. +markupHacked :: DocMarkup id Html + -> Maybe String + -> Doc id + -> Html +markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Qualification -> Doc DocName -> Html -docToHtml qual = markup fmt . cleanup +docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Qualification -> Doc DocName -> Html +docToHtml n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html -docToHtmlNoAnchors qual = markup fmt . cleanup +docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' + -> Qualification -> Doc DocName -> Html +docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) origDocToHtml :: Qualification -> Doc Name -> Html -origDocToHtml qual = markup fmt . cleanup +origDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) rdrDocToHtml :: Qualification -> Doc RdrName -> Html -rdrDocToHtml qual = markup fmt . cleanup +rdrDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -116,12 +199,15 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Documentation DocName -> Html -docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation +docSection :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> Documentation DocName -> Html +docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation -docSection_ :: Qualification -> Doc DocName -> Html -docSection_ qual = (docElement thediv <<) . docToHtml qual +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> Doc DocName -> Html +docSection_ n qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) qual cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 253854c8..64930ef9 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,6 @@ import Text.XHtml hiding ( name, title, p, quote ) import FastString ( unpackFS ) import GHC - -------------------------------------------------------------------------------- -- * Sections of the document -------------------------------------------------------------------------------- @@ -134,7 +133,7 @@ subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv subEntry (decl, mdoc, subs) = dterm ! [theclass "src"] << decl +++ - docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) + docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) clearDiv = thediv ! [ theclass "clear" ] << noHtml @@ -146,7 +145,7 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap (docToHtml qual) mdoc) + docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs @@ -175,7 +174,9 @@ subEquations :: Qualification -> [SubDecl] -> Html subEquations qual = divSubDecls "equations" "Equations" . subTable qual -subInstances :: Qualification -> String -> [SubDecl] -> Html +subInstances :: Qualification + -> String -- ^ Class name, used for anchor generation + -> [SubDecl] -> Html subInstances qual nm = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) -- cgit v1.2.3 From 3937a98afe1bf1a215fd9115051af388e45b7299 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Fri, 31 Oct 2014 11:08:02 +0100 Subject: Collapse user-defined section by default (re #335) --- src/Haddock/Backends/Xhtml/DocMarkup.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 741e97e0..a1f56adf 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -150,8 +150,8 @@ hackMarkup fmt h = case h of UntouchedDoc d -> markup fmt d CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ True [] <<) + col' = collapseControl id_ False "caption" + instTable = (thediv ! collapseSection id_ False [] <<) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCation = getHeader ! col' << markup fmt titl -- cgit v1.2.3 From 5a79e5b25a1e628f7d1d9f4bf97ccd9e30242c6a Mon Sep 17 00:00:00 2001 From: Yuras Shumovich Date: Fri, 31 Oct 2014 16:11:04 -0500 Subject: reflect ForeignType constructore removal Reviewers: austin Reviewed By: austin Differential Revision: https://phabricator.haskell.org/D358 --- src/Haddock/Interface/Rename.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index dd2bd73f..dca93cc0 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -298,10 +298,6 @@ renameLThing fn (L loc x) = return . L loc =<< fn x renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of - ForeignType lname b -> do - lname' <- renameL lname - return (ForeignType lname' b) - -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl -- cgit v1.2.3 From 199936af5bb902c81f822b2dc57308dc25e18cfc Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Fri, 31 Oct 2014 19:33:53 -0500 Subject: Remove overlapping pattern match Signed-off-by: Austin Seipp --- src/Haddock/Backends/Xhtml.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 38382871..85d2652a 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -587,7 +587,6 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - _ -> [] SigD (TypeSig lnames (L _ _)) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] -- cgit v1.2.3 From 9cdf19bad54a6cc4b322396fdd06f4c1ee045b22 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 15 Nov 2014 11:55:43 +0100 Subject: Make compatible with `deepseq-1.4.0.0` ...by not relying on the default method implementation of `rnf` --- src/Haddock/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 1f44fde4..7a66e16d 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -342,9 +342,9 @@ instance (NFData a, NFData mod) DocHeader a -> a `deepseq` () -instance NFData Name -instance NFData OccName -instance NFData ModuleName +instance NFData Name where rnf x = seq x () +instance NFData OccName where rnf x = seq x () +instance NFData ModuleName where rnf x = seq x () instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` () -- cgit v1.2.3 From bf80e2f594777c0c32fae092454bff0c13ae6181 Mon Sep 17 00:00:00 2001 From: "Dr. ERDI Gergo" Date: Thu, 20 Nov 2014 22:35:38 +0800 Subject: Update Haddock to new pattern synonym type signature syntax --- html-test/ref/Operators.html | 4 +- html-test/ref/PatternSyns.html | 36 +++++++++--------- src/Haddock/Backends/LaTeX.hs | 70 +++++++++++++++++------------------ src/Haddock/Backends/Xhtml/Decl.hs | 75 ++++++++++++++++++++------------------ src/Haddock/Convert.hs | 10 +++-- src/Haddock/Interface/Create.hs | 4 +- src/Haddock/Interface/Rename.hs | 10 ++--- 7 files changed, 105 insertions(+), 104 deletions(-) diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index bfecfb38..dc06e3b5 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -92,7 +92,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Operators.html");}; >

  • pattern (:+) t t :: [t]
    • :: t -> t -> [t]
  • data

    pattern (:+) t t :: [t] :: t -> t -> [t] infixr 3FooCtor x

  • pattern pattern Foo t :: :: t -> FooType t
  • pattern pattern Bar t :: :: t -> FooType (FooType t)
  • pattern t :<-> t :: (pattern (:<->) :: t -> t -> (FooType t, FooTypeEmpty
  • pattern pattern E :: :: (><) k t t

    • pattern pattern Foo t :: :: t -> FooType t

    pattern pattern Bar t :: :: t -> FooType (FooType

    pattern t :<-> t :: (pattern (:<->) :: t -> t -> (FooType t, FooType

    pattern pattern E :: :: (><) k t t

    ppClassDecl instances loc doc subdocs d unicode SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -350,32 +350,28 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> (HsExplicitFlag, LHsTyVarBndrs DocName) -> LHsContext DocName -> LHsContext DocName + -> LHsType DocName -> Bool -> LaTeX -ppLPatSig loc doc docname args typ prov req unicode = - ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode - -ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName - -> HsPatSynDetails (HsType DocName) -> HsType DocName - -> HsContext DocName -> HsContext DocName - -> Bool -> LaTeX -ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) +ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode + = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" - , pp_ctx prov - , pp_head + , ppDocBinder name , dcolon unicode - , pp_ctx req - , ppType unicode typ + , ppLTyVarBndrs expl qtvs unicode + , ctx + , ppType unicode ty ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of + (Nothing, Nothing) -> empty + (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - pp_type = ppParendType unicode - pp_ctx ctx = ppContext ctx unicode + darr = darrow unicode ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) @@ -786,15 +782,21 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + +ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe [] _ = Nothing +ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX -ppContextNoArrow [] _ = empty -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode +ppContextNoArrow cxt unicode = fromMaybe empty $ + ppContextNoLocsMaybe (map unLoc cxt) unicode ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX -ppContextNoLocs [] _ = empty -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode +ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode ppContext :: HsContext DocName -> Bool -> LaTeX @@ -869,14 +871,16 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode +ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Bool -> LaTeX +ppLTyVarBndrs expl tvs unicode + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + | otherwise = empty where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode @@ -954,11 +958,6 @@ ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n -ppBinderInfix :: OccName -> LaTeX -ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = quotes $ ppOccName n - isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n @@ -997,9 +996,6 @@ ppLDocName (L _ d) = ppDocName d ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName -ppDocBinderInfix :: DocName -> LaTeX -ppDocBinderInfix = ppBinderInfix . nameOccName . getName - ppName :: Name -> LaTeX ppName = ppOccName . nameOccName diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index d4869abd..97f3fb09 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,7 +32,6 @@ import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe -import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -49,8 +48,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl 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 lty fixities splice unicode qual - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req 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" @@ -74,39 +73,32 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Located DocName -> - HsPatSynDetails (LHsType DocName) -> LHsType DocName -> - LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> + (HsExplicitFlag, LHsTyVarBndrs DocName) -> + LHsContext DocName -> LHsContext DocName -> + LHsType DocName -> + [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = - ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) - (unLoc prov) (unLoc req) fixities splice unicode qual - -ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> - HsPatSynDetails (HsType DocName) -> HsType DocName -> - HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities - splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual | summary = pref1 - | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ toHtml "pattern" - , pp_cxt prov - , pp_head + , ppBinder summary occname , dcolon unicode - , pp_cxt req - , ppType unicode qual typ + , ppLTyVarBndrs expl qtvs unicode qual + , cxt + , ppLType unicode qual typ ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] - pp_cxt cxt = ppContext cxt unicode qual - pp_type = ppParendType unicode qual + cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of + (Nothing, Nothing) -> noHtml + (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - occname = nameOccName . getName $ docname + darr = darrow unicode + occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> @@ -357,17 +349,23 @@ ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual - <+> darrow unicode +ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html +ppContextNoLocsMaybe [] _ _ = Nothing +ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual + ppContext :: HsContext DocName -> Unicode -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual @@ -811,12 +809,19 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Unicode -> Qualification -> Html ppForAll expl tvs cxt unicode qual - | show_forall = forall_part <+> ppLContext cxt unicode qual - | otherwise = ppLContext cxt unicode qual + = forall_part <+> ppLContext cxt unicode qual + where + forall_part = ppLTyVarBndrs expl tvs unicode qual + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Unicode -> Qualification + -> Html +ppLTyVarBndrs expl tvs unicode _qual + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + | otherwise = noHtml where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 48306392..08892cd3 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -20,7 +20,7 @@ module Haddock.Convert where import HsSyn import TcType ( tcSplitSigmaTy ) import TypeRep -import Type(isStrLitTy) +import Type ( isStrLitTy, mkFunTys ) import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import Var @@ -94,12 +94,14 @@ tyThingToLHsDecl t = noLoc $ case t of (synifyType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps + let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps + qtvs = univ_tvs ++ ex_tvs + ty = mkFunTys arg_tys res_ty in SigD $ PatSynSig (synifyName ps) - (fmap (synifyType WithinType) (patSynTyDetails ps)) - (synifyType WithinType res_ty) + (Implicit, synifyTyVars qtvs) (synifyCtx req_theta) (synifyCtx prov_theta) + (synifyType WithinType ty) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index ad6a1e98..551e6e7e 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -340,8 +340,8 @@ typeDocs d = let docs = go 0 in case d of SigD (TypeSig _ ty) -> docs (unLoc ty) - SigD (PatSynSig _ arg_tys ty req prov) -> - let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + SigD (PatSynSig _ _ req prov ty) -> + let allTys = ty : concat [ unLoc req, unLoc prov ] in F.foldMap (docs . unLoc) allTys ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index dca93cc0..aa1a170f 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -402,15 +402,13 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLType ltype return (TypeSig lnames' ltype') - PatSynSig lname args ltype lreq lprov -> do + PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname - args' <- case args of - PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs - InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright - ltype' <- renameLType ltype + qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - return $ PatSynSig lname' args' ltype' lreq' lprov' + lty' <- renameLType lty + return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' FixSig (FixitySig lname fixity) -> do lname' <- renameL lname return $ FixSig (FixitySig lname' fixity) -- cgit v1.2.3 From 19409126be62383bc64d79698b265ffaf96269a5 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 19 Nov 2014 23:00:19 +0100 Subject: Follow changes from #9812 --- src/Haddock/Convert.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 08892cd3..9efa8ad4 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -117,7 +117,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) synifyAxiom :: CoAxiom br -> HsDecl Name synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) - | isOpenSynFamilyTyCon tc + | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) @@ -152,8 +152,8 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isSynFamilyTyCon tc - = case synTyConRhs_maybe tc of + | isTypeFamilyTyCon tc + = case famTyConFlav_maybe tc of Just rhs -> let info = case rhs of OpenSynFamilyTyCon -> OpenTypeFamily @@ -173,14 +173,11 @@ synifyTyCon coax tc FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing) --always kind '*' _ -> error "synifyTyCon: impossible open data type?" - | isSynTyCon tc - = case synTyConRhs_maybe tc of - Just (SynonymTyCon ty) -> - SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } - _ -> error "synifyTyCon: impossible synTyCon" + | Just ty <- synTyConRhs_maybe tc + = SynDecl { tcdLName = synifyName tc + , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdRhs = synifyType WithinType ty + , tcdFVs = placeHolderNamesTc } | otherwise = -- (closed) newtype and data let -- cgit v1.2.3 From 2b3712d701c1df626abbc60525c35e735272e45d Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 18 Nov 2014 21:49:31 -0500 Subject: Changes to reflect refactoring in GHC as part of #7484 --- src/Haddock/GhcUtils.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 2c7b79a1..43112ff3 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -26,6 +26,7 @@ import Data.Traversable import Exception import Outputable import Name +import Lexeme import Packages import Module import RdrName (GlobalRdrEnv) -- cgit v1.2.3 From 5d8117d8f1f910c85d36865d646b65510b23583d Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 21 Nov 2014 11:23:09 -0600 Subject: Follow API changes in D426 Signed-off-by: Austin Seipp --- src/Haddock/Backends/Hoogle.hs | 14 ++++----- src/Haddock/Backends/LaTeX.hs | 28 ++++++++++------- src/Haddock/Backends/Xhtml/Decl.hs | 61 +++++++++++++++++++++++++------------- src/Haddock/Convert.hs | 6 ++-- src/Haddock/GhcUtils.hs | 33 +++++++++++---------- src/Haddock/Interface/Create.hs | 31 ++++++++++--------- src/Haddock/Interface/Rename.hs | 26 ++++++++-------- src/Haddock/Utils.hs | 7 ++--- 8 files changed, 120 insertions(+), 86 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 4535ce5c..cdd4d56e 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -184,21 +184,21 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) - ++ f (con_details con) +ppCtor dflags dat subdocs con + = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [lookupCon dflags subdocs (cd_fld_name r) ++ - [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] - | r <- recs] + f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat + [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ + [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + | r <- map unLoc recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ unL $ con_name con + name = out dflags $ map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index d3074438..ec3ea8d1 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -26,6 +26,7 @@ import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc ) import FastString ( unpackFS, unpackLitString, zString ) +import Outputable ( panic) import qualified Data.Map as Map import System.Directory @@ -631,19 +632,19 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ResTyH98 -> case con_details con of PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppBinder occ) : + decltt (hsep ((header_ unicode <+> ppOcc) : map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl RecCon fields -> - (decltt (header_ unicode <+> ppBinder occ) + (decltt (header_ unicode <+> ppOcc) <-> rDoc mbDoc <+> nl) $$ doRecordFields fields InfixCon arg1 arg2 -> decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppBinder occ, + ppOcc, ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl @@ -657,33 +658,40 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = where doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) fields) + vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ ppForAll forall ltvs (con_cxt con) unicode, ppLType unicode (foldr mkFunTy resTy args) ] ) <-> rDoc mbDoc header_ = ppConstrHdr forall tyVars context - occ = nameOccName . getName . unLoc . con_name $ con + occ = map (nameOccName . getName . unLoc) $ con_names con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mbDoc = case con_names con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = - decltt (ppBinder (nameOccName . getName $ name) +ppSideBySideField subdocs unicode (ConDeclField names ltype _) = + decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= combineDocumentation . fst + -- Where there is more than one name, they all have the same documentation + mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 97f3fb09..0cb5ffb4 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -579,7 +579,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons - , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) + (map unLoc (con_names (unLoc c)))) fixities ] instancesBit = ppInstances instances docname unicode qual @@ -598,15 +599,15 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualificatio ppShortConstrParts summary dataInst con unicode qual = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - (header_ unicode qual +++ hsep (ppBinder summary occ + (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) RecCon fields -> - (header_ unicode qual +++ ppBinder summary occ <+> char '{', + (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppBinderInfix summary occ, ppLParendType unicode qual arg2], + ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of @@ -617,20 +618,29 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) -- (except each field gets its own line in docs, to match -- non-GADT records) - RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> + RecCon fields -> (ppOcc <+> dcolon unicode <+> ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) where - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) - doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) + doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = nameOccName . getName . unLoc . con_name $ con + occ = map (nameOccName . getName . unLoc) $ con_names con + + ppOcc = case occ of + [one] -> ppBinder summary one + _ -> hsep (punctuate comma (map (ppBinder summary) occ)) + + ppOccInfix = case occ of + [one] -> ppBinderInfix summary one + _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) + ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con @@ -661,15 +671,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field decl = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - hsep ((header_ +++ ppBinder False occ) + hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) <+> fixity - RecCon _ -> header_ +++ ppBinder False occ <+> fixity + RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> hsep [header_ +++ ppLParendType unicode qual arg1, - ppBinderInfix False occ, + ppOccInfix, ppLParendType unicode qual arg2] <+> fixity @@ -685,40 +695,51 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field _ -> [] doRecordFields fields = subFields qual - (map (ppSideBySideField subdocs unicode qual) fields) + (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppBinder False occ <+> dcolon unicode + doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = nameOccName . getName . unLoc . con_name $ con + occ = map (nameOccName . getName . unLoc) $ con_names con + + ppOcc = case occ of + [one] -> ppBinder False one + _ -> hsep (punctuate comma (map (ppBinder False) occ)) + + ppOccInfix = case occ of + [one] -> ppBinderInfix False one + _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) + ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>= + combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = - (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, +ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = + (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= combineDocumentation . fst + -- Where there is more than one name, they all have the same documentation + mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html -ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) - = ppBinder summary (nameOccName . getName $ name) +ppShortField summary unicode qual (ConDeclField names ltype _) + = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 9efa8ad4..2e8300d1 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -253,8 +253,8 @@ synifyDataCon use_gadt_syntax dc = noLoc $ -- HsNoBang never appears, it's implied instead. ) arg_tys (dataConStrictMarks dc) - field_tys = zipWith (\field synTy -> ConDeclField - (synifyName field) synTy Nothing) + field_tys = zipWith (\field synTy -> noLoc $ ConDeclField + [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> error "synifyDataCon: contradiction!" @@ -267,7 +267,7 @@ synifyDataCon use_gadt_syntax dc = noLoc $ then ResTyGADT (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! - in ConDecl name Implicit{-we don't know nor care-} + in ConDecl [name] Implicit{-we don't know nor care-} qvars ctx hs_arg_tys hs_res_ty Nothing False --we don't want any "deprecated GADT syntax" warnings! diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 43112ff3..e64d298f 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -100,7 +100,10 @@ filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig (FixitySig ns ty)) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _) = Just orig filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of @@ -116,12 +119,12 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns +sigNameNoLoc _ = [] isTyClD :: HsDecl a -> Bool @@ -195,11 +198,6 @@ instance Traversable (GenLocated l) where instance NamedThing (TyClDecl Name) where getName = tcdName - -instance NamedThing (ConDecl Name) where - getName = unL . con_name - - ------------------------------------------------------------------------------- -- * Subordinates ------------------------------------------------------------------------------- @@ -212,13 +210,13 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map (unL . cd_fld_name) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields _ -> [] - instance Parent (TyClDecl Name) where children d - | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d + | isDataDecl d = map unL $ concatMap (con_names . unL) + $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] @@ -230,11 +228,14 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name]) family = getName &&& children +familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) + -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d - | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 551e6e7e..afff7e10 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt msg -> format "Deprecated: " (concatFS msg) - WarningTxt msg -> format "Warning: " (concatFS msg) + DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg) + WarningTxt msg -> format "Warning: " (concatFS $ map unLoc msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs @@ -328,11 +328,12 @@ subordinates instMap decl = case decl of dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) - constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons ] + constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) + | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons - , ConDeclField n _ doc <- flds ] + , L _ (ConDeclField ns _ doc) <- flds + , n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -374,7 +375,8 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup Name -> FixMap mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] + | L _ (FixitySig ns f) <- hs_fixds group_, + L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. @@ -490,11 +492,11 @@ mkExportItems Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar x) = declWith x - lookupExport (IEThingAbs t) = declWith t - lookupExport (IEThingAll t) = declWith t - lookupExport (IEThingWith t _) = declWith t - lookupExport (IEModuleContents m) = + lookupExport (IEVar (L _ x)) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll (L _ t)) = declWith t + lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEModuleContents (L _ m)) = 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 @@ -772,7 +774,8 @@ extractDecl name mdl decl InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , ConDeclField { cd_fld_name = L _ n } <- rec + , ConDeclField { cd_fld_names = ns } <- map unLoc rec + , L _ n <- ns , n == name ] in case matches of @@ -804,11 +807,11 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> + RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty | ResTyGADT ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index aa1a170f..566e3acb 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -260,7 +260,6 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') - renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className @@ -365,19 +364,22 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars +renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do - lname' <- renameL lname + lnames' <- mapM renameL lnames ltyvars' <- renameLTyVarBndrs ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) + where - renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields + renameDetails (RecCon fields) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon fields') renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a @@ -388,12 +390,12 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t -renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) -renameConDeclFieldField (ConDeclField name t doc) = do - name' <- renameL name +renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) +renameConDeclFieldField (L l (ConDeclField names t doc)) = do + names' <- mapM renameL names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return (ConDeclField name' t' doc') + return $ L l (ConDeclField names' t' doc') renameSig :: Sig Name -> RnM (Sig DocName) @@ -409,9 +411,9 @@ renameSig sig = case sig of lprov' <- renameLContext lprov lty' <- renameLType lty return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' - FixSig (FixitySig lname fixity) -> do - lname' <- renameL lname - return $ FixSig (FixitySig lname' fixity) + FixSig (FixitySig lnames fixity) -> do + lnames' <- mapM renameL lnames + return $ FixSig (FixitySig lnames' fixity) MinimalSig s -> MinimalSig <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 9ccca362..ecf58b34 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -146,24 +146,23 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | unLoc (con_name d) `elem` names = + keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = case con_details d of PrefixCon _ -> Just d RecCon fields | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) + | otherwise -> Just (d { con_details = PrefixCon (field_types (map 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 (ConDeclField n _ _) = unLoc n `elem` names + field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing - restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -- cgit v1.2.3 From 1a9dcfef033dd66514015d4a942ba67d21f95482 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Wed, 6 Aug 2014 10:26:54 +0200 Subject: Support for PartialTypeSignatures --- src/Haddock/Backends/Hoogle.hs | 20 ++++++++++---------- src/Haddock/Backends/LaTeX.hs | 27 +++++++++++++++++---------- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 33 ++++++++++++++++++++------------- src/Haddock/Convert.hs | 9 +++++---- src/Haddock/GhcUtils.hs | 8 ++++---- src/Haddock/Interface/Create.hs | 16 ++++++++-------- src/Haddock/Interface/Rename.hs | 14 ++++++++------ 8 files changed, 73 insertions(+), 56 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index cdd4d56e..1df6d9b1 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -64,7 +64,7 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d) = HsForAllTy a b c (g d) + f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b) @@ -82,7 +82,7 @@ outHsType dflags = out dflags . dropHsDocTy makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c +makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d makeExplicit x = x makeExplicitL :: LHsType a -> LHsType a @@ -120,21 +120,21 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) +ppSig dflags (TypeSig names sig _) = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of - HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c - HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c + HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d + HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d x -> x ppSig _ _ = [] @@ -144,12 +144,12 @@ ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where - addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig sig) = MinimalSig sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) + f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d + f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index ec3ea8d1..801f3138 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -212,7 +212,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -249,7 +249,7 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _) -> map unLoc lnames + SigD (TypeSig lnames _ _) -> map unLoc lnames SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] @@ -293,7 +293,7 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode SigD (PatSynSig lname qtvs prov req ty) -> ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode @@ -393,15 +393,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc (Map.lookup n argDocs) do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Qualified a lctxt ltype) - = do_args n leader (HsForAllTy Implicit a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ lctxt ltype) + do_args n leader (HsForAllTy Qualified e a lctxt ltype) + = do_args n leader (HsForAllTy Implicit e a lctxt ltype) + do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype @@ -521,7 +521,7 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ)) <- lsigs + | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -895,9 +895,12 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] + where ctxt' = case extra of + Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt + Nothing -> ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -937,6 +940,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty _ HsWildcardTy _ = char '_' + +ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name + ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 85d2652a..49f835c8 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -587,7 +587,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _)) -> + SigD (TypeSig lnames (L _ _) _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 0cb5ffb4..2c0a124a 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -43,11 +43,11 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl 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 lty fixities splice unicode qual + 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 lty fixities splice unicode qual SigD (PatSynSig lname qtvs prov req ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual @@ -132,13 +132,13 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Implicit _ lctxt ltype) + do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) | not (null (unLoc lctxt)) = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) @@ -416,7 +416,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ)) <- sigs + | L _ (TypeSig lnames (L _ typ) _) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -461,7 +461,7 @@ ppClassDecl summary links instances fixities loc d subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ)) <- lsigs + | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -474,12 +474,12 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -850,9 +850,12 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + hsep [ppForAll expl tvs ctxt' unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + where ctxt' = case extra of + Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt + Nothing -> ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -898,6 +901,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty _ HsWildcardTy _ _ = char '_' + +ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name + ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 2e8300d1..dd769c21 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -91,7 +91,7 @@ tyThingToLHsDecl t = noLoc $ case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) + (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) -> let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps @@ -112,7 +112,8 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) in TyFamEqn { tfe_tycon = name , tfe_pats = HsWB { hswb_cts = typats , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs } + , hswb_tvs = map tyVarName tvs + , hswb_wcs = [] } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> HsDecl Name @@ -277,7 +278,7 @@ synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] synifyCtx :: [PredType] -> LHsContext Name @@ -360,7 +361,7 @@ synifyType s forallty@(ForAllTy _tv _ty) = sCtx = synifyCtx ctx sTau = synifyType WithinType tau in noLoc $ - HsForAllTy forallPlicitness sTvs sCtx sTau + HsForAllTy forallPlicitness Nothing sTvs sCtx sTau synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index e64d298f..5aa9b818 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -105,10 +105,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _) = Just orig -filterSigNames p (TypeSig ns ty) = +filterSigNames p (TypeSig ns ty nwcs) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) + filtered -> Just (TypeSig filtered ty nwcs) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -119,7 +119,7 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (TypeSig ns _ _) = map unLoc ns sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] @@ -219,7 +219,7 @@ instance Parent (TyClDecl Name) where $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ] | otherwise = [] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index afff7e10..396c138f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -340,7 +340,7 @@ typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty) -> docs (unLoc ty) + SigD (TypeSig _ ty _) -> docs (unLoc ty) SigD (PatSynSig _ _ req prov ty) -> let allTys = ty : concat [ unLoc req, unLoc prov ] in F.foldMap (docs . unLoc) allTys @@ -348,7 +348,7 @@ typeDocs d = TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) + go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc @@ -713,7 +713,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr 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 (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs @@ -791,10 +791,10 @@ toTypeNoLoc = noLoc . HsTyVar . unLoc extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of - L _ (HsForAllTy expl tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) +extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of + L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds @@ -808,7 +808,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) + L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 566e3acb..b08cd275 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -183,11 +183,11 @@ renameMaybeLKind = traverse renameLKind renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl tyvars lcontext ltype -> do + HsForAllTy expl extra tyvars lcontext ltype -> do tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl tyvars' lcontext' ltype') + return (HsForAllTy expl extra tyvars' lcontext' ltype') HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype @@ -236,6 +236,8 @@ renameType t = case t of HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsWildcardTy -> pure HsWildcardTy + HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c @@ -400,10 +402,10 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig lnames ltype _ -> do lnames' <- mapM renameL lnames ltype' <- renameLType ltype - return (TypeSig lnames' ltype') + return (TypeSig lnames' ltype' PlaceHolder) PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname qtvs' <- renameLTyVarBndrs qtvs @@ -466,7 +468,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder + , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) @@ -485,7 +487,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder + = HsWB pats' PlaceHolder PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -- cgit v1.2.3 From b94ab9034367f51b978904d60f2604db10abbd9f Mon Sep 17 00:00:00 2001 From: "Dr. ERDI Gergo" Date: Sat, 29 Nov 2014 15:39:09 +0800 Subject: For pattern synonyms, render "pattern" as a keyword --- html-test/ref/Operators.html | 8 ++++++-- html-test/ref/PatternSyns.html | 32 ++++++++++++++++++++++++-------- src/Haddock/Backends/Xhtml/Decl.hs | 2 +- 3 files changed, 31 insertions(+), 11 deletions(-) diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index dc06e3b5..b076206d 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -90,7 +90,9 @@ window.onload = function () {pageLoad();setSynopsis("mini_Operators.html");}; >
  • pattern pattern (:+) :: t -> t -> [t]

  • pattern pattern (:+) :: t -> t -> [t] infixr 3FooCtor x

  • pattern pattern Foo :: t -> FooType t
  • pattern pattern Bar :: t -> FooTypeFooType t)
  • pattern pattern (:<->) :: t -> t -> (FooTypeEmpty
  • pattern pattern E :: (><)

    • pattern pattern Foo :: t -> FooType

    pattern pattern Bar :: t -> FooType

    pattern pattern (:<->) :: t -> t -> (FooType

    pattern pattern E :: (><) ppFixities fixities qual) +++ docSection Nothing qual doc where - pref1 = hsep [ toHtml "pattern" + pref1 = hsep [ keyword "pattern" , ppBinder summary occname , dcolon unicode , ppLTyVarBndrs expl qtvs unicode qual -- cgit v1.2.3