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 From 45acead293f9fc18e984d2e83d137809359d506d Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Mon, 22 Dec 2014 17:51:52 +0100 Subject: Bump versions for ghc-7.11 --- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b0df5491..e8db3cfb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -76,7 +76,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711) +#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 713) binaryInterfaceVersion = 27 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock.cabal b/haddock.cabal index fbb4bfed..3b6002f1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -57,7 +57,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.9 && < 7.11, + ghc >= 7.11 && < 7.13, bytestring, transformers -- cgit v1.2.3 From 56b9e6bcef33612b40d3f93f170397eff77411eb Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 23 Dec 2014 15:22:56 +0000 Subject: Eliminate instanceHead' in favour of GHC's instanceSig This is made possible by the elimination of "silent superclass parameters" in GHC --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 1341e57f..080de6ff 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -80,7 +80,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = , let opaque = isTypeHidden expInfo (fi_rhs i) ] cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] @@ -117,20 +117,6 @@ instLookup f name iface ifaceMap instIfaceMap = iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's 'instanceHead' but drops "silent" arguments. -instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) -instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) - where - dfun = is_dfun ispec - (tvs, cls, tys) = instanceHead ispec - (_, theta, _) = tcSplitSigmaTy (idType dfun) - --- | Drop "silent" arguments. See GHC Note [Silent superclass --- arguments]. -dropSilentArgs :: DFunId -> ThetaType -> ThetaType -dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta - - -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -- cgit v1.2.3 From 8b1d44fbdde141cf883f5ddcd337bbbab8433228 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 6 Jan 2015 16:37:47 +0000 Subject: Remove redundant constraints from haddock, discovered by -fwarn-redundant-constraints --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 1bb04ed3..afb5111e 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -239,6 +239,6 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) -------------------------------------------------------------------------------- -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a withTempDir dir = gbracket_ (liftIO $ createDirectory dir) (liftIO $ removeDirectoryRecursive dir) -- cgit v1.2.3 From 04cf63d0195837ed52075ed7d2676e71831e8a0b Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Thu, 8 Jan 2015 15:50:22 +0000 Subject: Track naming change in DataCon --- haddock-api/src/Haddock/Convert.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 1b1a8a88..29d13392 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -265,15 +265,15 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsUserBang (Just True) True - HsStrict -> HsUserBang (Just False) True + HsUnpack {} -> HsSrcBang (Just True) True + HsStrict -> HsSrcBang (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn _ -> noLoc $ HsBangTy bang tySyn -- HsNoBang never appears, it's implied instead. ) - arg_tys (dataConStrictMarks dc) + arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys -- cgit v1.2.3 From d61bbc75890e4eb0ad508b9c2a27b91f691213e6 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Sep 2014 01:03:27 -0500 Subject: Follow API changes in D538 Signed-off-by: Austin Seipp --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 +++++++++++++------------- haddock-api/src/Haddock/Convert.hs | 22 +++++++++++----------- haddock-api/src/Haddock/GhcUtils.hs | 14 +++----------- haddock-api/src/Haddock/Interface/Create.hs | 18 +++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 18 +++++++++--------- haddock-api/src/Haddock/Utils.hs | 4 ++-- 8 files changed, 61 insertions(+), 69 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index dd10bb0a..fe656a4b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -145,7 +145,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig sig) = MinimalSig sig + addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d @@ -189,7 +189,7 @@ ppCtor dflags dat subdocs 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 (map unLoc recs)) ++ concat + f (RecCon (L _ 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] @@ -203,7 +203,7 @@ ppCtor dflags dat subdocs con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT x -> x + ResTyGADT _ x -> x --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b717fc01..b0a18b70 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -477,7 +477,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -486,13 +486,13 @@ ppClassHdr summ lctxt n tvs fds unicode = <+> ppFds fds unicode -ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) + fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + hsep (map (ppDocName . unLoc) vars2) ppClassDecl :: [DocInstance DocName] -> SrcSpan @@ -598,8 +598,8 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ -> (decltt (keyword "where"), repeat empty) - _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing @@ -636,7 +636,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl - RecCon fields -> + RecCon (L _ fields) -> (decltt (header_ unicode <+> ppOcc) <-> rDoc mbDoc <+> nl) $$ @@ -648,11 +648,11 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy @@ -948,8 +948,8 @@ ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u ppr_tylit :: HsTyLit -> Bool -> LaTeX -ppr_tylit (HsNumTy n) _ = integer n -ppr_tylit (HsStrTy s) _ = text (show s) +ppr_tylit (HsNumTy _ n) _ = integer n +ppr_tylit (HsStrTy _ s) _ = text (show s) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3bf4322d..bed9488a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -146,7 +146,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -381,7 +381,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -390,13 +390,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual = <+> ppFds fds unicode qual -ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html +ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map (ppDocName qual Prefix True) + ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] @@ -470,7 +470,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of + 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] @@ -572,7 +572,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml | otherwise = case resTy of - ResTyGADT _ -> keyword "where" + ResTyGADT _ _ -> keyword "where" _ -> noHtml constrBit = subConstructors qual @@ -600,7 +600,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) - RecCon fields -> + RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') @@ -609,7 +609,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) @@ -617,7 +617,7 @@ 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 -> (ppOcc <+> dcolon unicode <+> + RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) @@ -682,7 +682,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy @@ -690,7 +690,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy fieldPart = case con_details con of - RecCon fields -> [doRecordFields fields] + RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual @@ -907,8 +907,8 @@ ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html -ppr_tylit (HsNumTy n) = toHtml (show n) -ppr_tylit (HsStrTy s) = toHtml (show s) +ppr_tylit (HsNumTy _ n) = toHtml (show n) +ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 29d13392..83173222 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -32,7 +32,7 @@ import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn import PrelNames (ipClassName) -import SrcLoc ( Located, noLoc, unLoc ) +import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) @@ -75,9 +75,9 @@ tyThingToLHsDecl t = case t of , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ + (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -146,7 +146,7 @@ synifyTyCon coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (getName fakeTyVar) + = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) @@ -265,8 +265,8 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang (Just True) True - HsStrict -> HsSrcBang (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) True + HsStrict -> HsSrcBang Nothing (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn @@ -279,13 +279,13 @@ synifyDataCon use_gadt_syntax dc = (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon field_tys + (True,False) -> return $ RecCon (noLoc field_tys) (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType res_ty) + then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= @@ -313,7 +313,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -384,8 +384,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy n -synifyTyLit (StrTyLit s) = HsStrTy s +synifyTyLit (NumTyLit n) = HsNumTy mempty n +synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5aa9b818..b0ea1730 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -104,8 +104,8 @@ 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 nwcs) = +filterSigNames _ orig@(MinimalSig _ _) = Just orig +filterSigNames p (TypeSig ns ty nwcs) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty nwcs) @@ -182,14 +182,6 @@ before :: Located a -> Located a -> Bool before = (<) `on` getLoc -instance Foldable (GenLocated l) where - foldMap f (L _ x) = f x - - -instance Traversable (GenLocated l) where - mapM f (L l x) = (return . L l) =<< f x - traverse f (L l x) = L l <$> f x - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -210,7 +202,7 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 98a715a9..9ef3d1b1 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/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 $ map unLoc msg) - WarningTxt msg -> format "Warning: " (concatFS $ map unLoc 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 @@ -335,7 +335,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons - , L _ (ConDeclField ns _ doc) <- flds + , L _ (ConDeclField ns _ doc) <- (unLoc flds) , n <- ns ] -- | Extract function argument docs from inside types. @@ -496,7 +496,7 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEVar (L _ x)) = declWith x - lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t lookupExport (IEThingWith (L _ t) _) = declWith t lookupExport (IEModuleContents (L _ m)) = @@ -553,7 +553,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -745,7 +745,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name @@ -785,7 +785,7 @@ 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_names = ns } <- map unLoc rec + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , n == name ] @@ -818,13 +818,13 @@ 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 -> + RecCon (L _ 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 = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty - | ResTyGADT ty <- con_res con = ty + | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1ea212f5..25ea9e9f 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -251,10 +251,10 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc (UserTyVar n)) = do { n' <- rename n ; return (L loc (UserTyVar n')) } -renameLTyVarBndr (L loc (KindedTyVar n kind)) +renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar n' kind')) } + ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do @@ -331,9 +331,9 @@ renameTyClD d = case d of where renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) + xs' <- mapM rename (map unLoc xs) + ys' <- mapM rename (map unLoc ys) + return (L loc (map noLoc xs', map noLoc ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig @@ -378,9 +378,9 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_details = details', con_res = restype', con_doc = mbldoc' }) where - renameDetails (RecCon fields) = do + renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecCon fields') + return (RecCon (L l fields')) renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a @@ -388,7 +388,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) @@ -415,7 +415,7 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig s -> MinimalSig <$> traverse renameL s + MinimalSig src s -> MinimalSig src <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 9a821b2e..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -154,8 +154,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] case con_details d of PrefixCon _ -> Just d RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) }) + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- cgit v1.2.3 From 4bb685bd0f5774584c6bef3f8786daffeac13b56 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 10 Feb 2015 12:10:33 +0000 Subject: Track changes in HsSyn for quasi-quotes --- haddock-api/src/Haddock/Backends/LaTeX.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - haddock-api/src/Haddock/Interface/Rename.hs | 4 ---- 3 files changed, 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b0a18b70..c9262c7e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -911,7 +911,6 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bed9488a..2fcc21e0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -872,7 +872,6 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 25ea9e9f..1234d05c 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -233,14 +233,10 @@ renameType t = case t of HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b 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 - renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs -- cgit v1.2.3 From f9ae6aaf269474228f368380966fc80b73587832 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 22 Jan 2015 23:34:05 +0000 Subject: --package-name and --package-version flags Used for --hoogle amongst other things. Now we need to teach cabal to use it. The situation is still a bit sub-par because if the flags aren't passed in, the crash will occur. Closes #353. (cherry picked from commit 8e06728afb0784128ab2df0be7a5d7a191d30ff4) --- haddock-api/src/Haddock.hs | 27 ++++++++++++++++++++++++--- haddock-api/src/Haddock/GhcUtils.hs | 14 -------------- haddock-api/src/Haddock/Options.hs | 37 +++++++++++++++++++++++++++++-------- 3 files changed, 53 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 915ad47a..72c544e1 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -25,6 +25,7 @@ module Haddock ( withGhc ) where +import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX @@ -36,7 +37,6 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils -import Haddock.GhcUtils hiding (pretty) import Control.Monad hiding (forM_) import Data.Foldable (forM_) @@ -66,9 +66,9 @@ import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) import StaticFlags (discardStaticFlags) +import Packages import Panic (handleGhcException) import Module -import PackageConfig import FastString -------------------------------------------------------------------------------- @@ -252,7 +252,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgMod = ifaceMod (head ifaces) pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo dflags pkgMod + (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -299,6 +299,27 @@ render dflags flags qual ifaces installedIfaces srcMap = do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir +-- | From GHC 7.10, this function has a potential to crash with a +-- nasty message such as @expectJust getPackageDetails@ because +-- package name and versions can no longer reliably be extracted in +-- all cases: if the package is not installed yet then this info is no +-- longer available. The @--package-name@ and @--package-version@ +-- Haddock flags allow the user to specify this information and it is +-- returned here if present: if it is not present, the error will +-- occur. Nasty but that's how it is for now. Potential TODO. +modulePackageInfo :: DynFlags + -> [Flag] -- ^ Haddock flags are checked as they may + -- contain the package name or version + -- provided by the user which we + -- prioritise + -> Module -> (PackageName, Data.Version.Version) +modulePackageInfo dflags flags modu = + (fromMaybe (packageName pkg) (optPackageName flags), + fromMaybe (packageVersion pkg) (optPackageVersion flags)) + where + pkg = getPackageDetails dflags (modulePackageKey modu) + + ------------------------------------------------------------------------------- -- * Reading and dumping interface files ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index b0ea1730..5caefa77 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,18 +16,14 @@ module Haddock.GhcUtils where -import Data.Version import Control.Applicative ( (<$>) ) import Control.Arrow -import Data.Foldable hiding (concatMap) import Data.Function -import Data.Traversable import Exception import Outputable import Name import Lexeme -import Packages import Module import RdrName (GlobalRdrEnv) import GhcMonad (withSession) @@ -40,15 +36,6 @@ import Class moduleString :: Module -> String moduleString = moduleNameString . moduleName - --- return the (name,version) of the package -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) lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of @@ -280,4 +267,3 @@ setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f - diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 3fa6397f..e847333e 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -28,15 +28,21 @@ module Haddock.Options ( qualification, verbosity, ghcFlags, - readIfaceArgs + readIfaceArgs, + optPackageName, + optPackageVersion ) where -import Distribution.Verbosity -import Haddock.Utils -import Haddock.Types -import System.Console.GetOpt import qualified Data.Char as Char +import Data.Version +import Distribution.Verbosity +import FastString +import Haddock.Types +import Haddock.Utils +import Packages +import System.Console.GetOpt +import qualified Text.ParserCombinators.ReadP as RP data Flag @@ -83,7 +89,9 @@ data Flag | Flag_Qualification String | Flag_PrettyHtml | Flag_NoPrintMissingDocs - deriving (Eq) + | Flag_PackageName String + | Flag_PackageVersion String + deriving (Eq, Show) options :: Bool -> [OptDescr Flag] @@ -107,7 +115,7 @@ options backwardsCompat = Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) - "output for Hoogle", + "output for Hoogle; you may want --package-name and --package-version too", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -171,7 +179,11 @@ options backwardsCompat = Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) - "don't print information about any undocumented entities" + "don't print information about any undocumented entities", + Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") + "name of the package being documented", + Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") + "version of the package being documented in usual x.y.z.w format" ] @@ -192,6 +204,15 @@ parseHaddockOpts params = usage <- getUsage throwE (concat errors ++ usage) +optPackageVersion :: [Flag] -> Maybe Data.Version.Version +optPackageVersion flags = + let ver = optLast [ v | Flag_PackageVersion v <- flags ] + in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion + +optPackageName :: [Flag] -> Maybe PackageName +optPackageName flags = + optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ] + optTitle :: [Flag] -> Maybe String optTitle flags = -- cgit v1.2.3 From 5bbae8b9bc17d2166c7e03d5f42f2b12fadf70b7 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 1 May 2015 09:36:47 +0100 Subject: Track change in API of TyCon --- haddock-api/src/Haddock/Convert.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 83173222..ce1ef8b6 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -338,8 +338,9 @@ synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. - | isTupleTyCon tc, tyConArity tc == length tys = - noLoc $ HsTupleTy (case tupleTyConSort tc of + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = noLoc $ HsTupleTy (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) -- cgit v1.2.3 From 26a590c009005d77fbee9e2c79286bd93f7955f5 Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Mon, 4 May 2015 15:32:59 +0100 Subject: Track API changes to support empty closed type familes --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Convert.hs | 16 ++++++++++------ haddock-api/src/Haddock/Interface/Rename.hs | 2 +- 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2fcc21e0..88aa966c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -265,9 +265,9 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise = ppInstances instances docname unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ce1ef8b6..d841aecc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -131,7 +131,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) - | Just ax' <- isClosedSynFamilyTyCon_maybe tc + | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = synifyTyCon (Just ax) tc >>= return . TyClD @@ -168,11 +168,15 @@ synifyTyCon coax tc Just rhs -> let info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - return $ ClosedTypeFamily - (brListMap (noLoc . synifyAxBranch tc) branches) - BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily [] - AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily [] + ClosedSynFamilyTyCon mb -> case mb of + Just (CoAxiom { co_ax_branches = branches }) + -> return $ ClosedTypeFamily $ Just $ + brListMap (noLoc . synifyAxBranch tc) branches + Nothing -> return $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> return $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> return $ ClosedTypeFamily Nothing in info >>= \i -> return (FamDecl (FamilyDecl { fdInfo = i diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1234d05c..56e5b07f 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -347,7 +347,7 @@ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM renameLTyFamInstEqn eqns + = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) -- cgit v1.2.3 From 2380f07c430c525b205ce2eae6dab23c8388d899 Mon Sep 17 00:00:00 2001 From: Murray Campbell Date: Sun, 26 Apr 2015 13:49:01 -0700 Subject: Change ModuleTree Node to carry PackageKey and SourcePackageId to resolve #385 Signed-off-by: Austin Seipp --- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +-- haddock-api/src/Haddock/ModuleTree.hs | 41 +++++++++++++++++-------------- 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 65a7e6c4..6ef1e863 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -289,7 +289,7 @@ mkNodeList qual ss p ts = case ts of mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg short ts) = +mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -313,7 +313,7 @@ mkNode qual ss p (Node s leaf pkg short ts) = mdl = intercalate "." (reverse (s:ss)) shortDescr = maybe noHtml (origDocToHtml qual) short - htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index eec1342e..2f731214 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,41 +15,44 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) | otherwise = Nothing - fn (mod_,pkg,short) = addToTrees mod_ pkg short - - -addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) + | otherwise = Nothing + fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + + +addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ ts = ts +addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short +addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg + this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] +mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ = [] +mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] +mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] splitModule :: Module -> [String] -- cgit v1.2.3 From 5a57a24c44e06e964c4ea2276c842c722c4e93d9 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 13 May 2015 12:04:21 +0100 Subject: Track the new location of setRdrNameSpace --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 35abf8a6..ac823da3 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -29,7 +29,8 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import Outputable (showPpr) +import RdrHsSyn ( setRdrNameSpace ) +import Outputable ( showPpr ) import RdrName processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -- cgit v1.2.3 From 45df734c8e0242ca2e88fba5359207e49d7bf158 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 25 May 2015 17:14:01 +0200 Subject: ApiAnnotations : strings in warnings do not return SourceText The strings used in a WARNING pragma are captured via strings :: { Located ([AddAnn],[Located FastString]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } .. The STRING token has a method getSTRINGs that returns the original source text for a string. A warning of the form {-# WARNING Logic , mkSolver , mkSimpleSolver , mkSolverForLogic , solverSetParams , solverPush , solverPop , solverReset , solverGetNumScopes , solverAssertCnstr , solverAssertAndTrack , solverCheck , solverCheckAndGetModel , solverGetReasonUnknown "New Z3 API support is still incomplete and fragile: \ \you may experience segmentation faults!" #-} returns the concatenated warning string rather than the original source. --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9ef3d1b1..5adaef69 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -158,7 +158,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - ideclPkgQual impDecl) + fmap snd $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -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 $ map unLoc msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From 553c719236972f3a1d445146352ec94614979b63 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 8 Jun 2015 23:47:28 -0500 Subject: Update after wild card renaming refactoring in D613 Summary: * Move `Post*` type instances to `Haddock.Types` as other modules than `Haddock.Interface.Rename` will rely on these type instances. * Update after wild card renaming refactoring in D613. Reviewers: simonpj, austin Reviewed By: austin Differential Revision: https://phabricator.haskell.org/D954 GHC Trac Issues: #10098 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 12 +++++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 +++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 19 +++++-------------- haddock-api/src/Haddock/Types.hs | 19 ++++++++++++++++++- 4 files changed, 37 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c9262c7e..e1090a0e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -898,9 +898,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX 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] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -939,9 +941,9 @@ 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 _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 88aa966c..c0be9735 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -852,9 +852,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon 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 + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -899,9 +901,9 @@ 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 _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 56e5b07f..2b50ce9a 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -21,8 +20,6 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import NameSet -import Coercion import Control.Applicative import Control.Monad hiding (mapM) @@ -234,8 +231,7 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) @@ -257,6 +253,10 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className @@ -517,12 +517,3 @@ 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 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e93294a0..847320a7 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -34,6 +34,8 @@ import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) import OccName import Outputable +import NameSet (NameSet) +import Coercion (Coercion) import Control.Applicative (Applicative(..)) import Control.Monad (ap) @@ -551,3 +553,18 @@ instance Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- + +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 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 53c47c6fc6cdaa5084b36ea6ba8320a460fa7106 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Fri, 3 Jul 2015 15:57:06 +0200 Subject: StrictData: print correct strictness marks --- haddock-api/src/Haddock/Backends/LaTeX.hs | 7 +++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e1090a0e..86a6909b 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -823,8 +823,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ (Just True)) = char '!' +ppBang (HsSrcBang _ _ (Just False)) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c0be9735..2da4cc1c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,9 +769,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" +ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d841aecc..c11ca545 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -269,13 +269,13 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) True - HsStrict -> HsSrcBang Nothing (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) + HsStrict -> HsSrcBang Nothing (Just False) (Just True) + HsLazy -> HsSrcBang Nothing Nothing Nothing _ -> bang in case src_bang of - HsNoBang -> tySyn + (HsSrcBang _ Nothing Nothing) -> tySyn _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. ) arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField -- cgit v1.2.3 From 5eb0785cde60997f072c3bdfefaf8c389c96d42e Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Wed, 8 Jul 2015 15:03:04 +0200 Subject: StrictData: changes in HsBang type --- haddock-api/src/Haddock/Backends/LaTeX.hs | 10 +++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 86a6909b..d85d75da 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -823,11 +823,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' -ppBang (HsSrcBang _ _ (Just True)) = char '!' -ppBang (HsSrcBang _ _ (Just False)) = char '~' -ppBang _ = empty +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2da4cc1c..21ef167b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,11 +769,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" -ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" -ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" -ppBang _ = noHtml +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c11ca545..edf91ce5 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -269,12 +269,12 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) - HsStrict -> HsSrcBang Nothing (Just False) (Just True) - HsLazy -> HsSrcBang Nothing Nothing Nothing + HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict + HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict + HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness _ -> bang in case src_bang of - (HsSrcBang _ Nothing Nothing) -> tySyn + (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn _ -> noLoc $ HsBangTy bang tySyn ) arg_tys (dataConSrcBangs dc) -- cgit v1.2.3 From 3436273f6e87d9358f6c23ad5b6b2838ce573892 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 26 Jul 2015 22:19:40 +0200 Subject: Replace (SourceText,FastString) with WithSourceText data type Phab:D907 introduced SourceText for a number of data types, by replacing FastString with (SourceText,FastString). Since this has an Outputable instance, no warnings are generated when ppr is called on it, but unexpected output is generated. See Phab:D1096 for an example of this. Replace the (SourceText,FastString) tuples with a new data type data WithSourceText = WithSourceText SourceText FastString Trac ticket: #10692 --- haddock-api/src/Haddock/Interface/Create.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5adaef69..ab79fb8d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -45,6 +45,7 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) +import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -158,7 +159,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - fmap snd $ ideclPkgQual impDecl) + fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -194,8 +195,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 $ map (snd . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From 62f3a12863121fa5b6c2787185e62cfa3f44bdd6 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Tue, 14 Jul 2015 21:01:01 +0200 Subject: HsBang is split into HsSrcBang and HsImplBang With recent changes in GHC handling of strictness annotations in Haddock is simplified. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +--- haddock-api/src/Haddock/Convert.hs | 20 ++++++++------------ 3 files changed, 10 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d85d75da..b8558f4f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -822,9 +822,7 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' +ppBang :: HsSrcBang -> LaTeX ppBang (HsSrcBang _ _ SrcStrict) = char '!' ppBang (HsSrcBang _ _ SrcLazy) = char '~' ppBang _ = empty diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 21ef167b..b2b6f904 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -768,9 +768,7 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" +ppBang :: HsSrcBang -> Html ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" ppBang _ = noHtml diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index edf91ce5..7c9040a9 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -266,18 +266,14 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict - HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict - HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness - _ -> bang - in case src_bang of - (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - ) - arg_tys (dataConSrcBangs dc) + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLoc $ HsBangTy bang' tySyn) + arg_tys (dataConSrcBangs dc) + field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys -- cgit v1.2.3 From 6a1d4a65010932a660ceacda93c8c20fb5e1399d Mon Sep 17 00:00:00 2001 From: Thomas Miedema Date: Sat, 15 Aug 2015 14:51:18 +0200 Subject: Follow changes in GHC build system --- ghc.mk | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghc.mk b/ghc.mk index a3bb834f..af2d8de3 100644 --- a/ghc.mk +++ b/ghc.mk @@ -59,9 +59,9 @@ endif .PHONY: install_utils/haddock_data install_utils/haddock_data: $(foreach i,$(sort $(dir $(utils/haddock_dist_DATA_FILES))), \ - $(call make-command,$(call INSTALL_DIR,"$(DESTDIR)$(ghclibdir)/$i"))) + $(call make-command,$(INSTALL_DIR) "$(DESTDIR)$(ghclibdir)/$i")) $(foreach i,$(utils/haddock_dist_DATA_FILES), \ - $(call make-command,$(call INSTALL_DATA,$(INSTALL_OPTS),utils/haddock/haddock-api/resources/$i,"$(DESTDIR)$(ghclibdir)/$(dir $i)"))) + $(call make-command,$(INSTALL_DATA) $(INSTALL_OPTS) utils/haddock/haddock-api/resources/$i "$(DESTDIR)$(ghclibdir)/$(dir $i)")) .PHONY: install_utils/haddock_link install_utils/haddock_link: -- cgit v1.2.3 From 29c9681c1132eb01fae829ef6848468a2de044e7 Mon Sep 17 00:00:00 2001 From: Eric Seidel Date: Thu, 4 Jun 2015 20:29:56 -0700 Subject: account for changes to ipClass --- haddock-api/src/Haddock/Convert.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 7c9040a9..ce30e1dd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,14 +31,13 @@ import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn -import PrelNames (ipClassName) import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) import TypeRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) +import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) import Var @@ -349,7 +348,7 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | tyConName tc == ipClassName + | tc == ipTyCon , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- cgit v1.2.3 From ad49d1608f406dc83f64f65920f1c6aa2f75403e Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Fri, 19 Dec 2014 08:16:30 +0100 Subject: Follow changes from #6018 --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 29 +++++++++++++++--- haddock-api/src/Haddock/Convert.hs | 42 +++++++++++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 34 +++++++++++++++++---- 3 files changed, 84 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b2b6f904..56b64120 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -230,7 +230,8 @@ ppTyName = ppName Prefix ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = (case info of OpenTypeFamily @@ -245,11 +246,24 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ppFamDeclBinderWithVars summary d <+> - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + (case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + ) <+> + + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) + +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) + + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html @@ -817,6 +831,13 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar name ) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ce30e1dd..43cd0ea2 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,7 +28,7 @@ import DataCon import FamInstEnv import Haddock.Types import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) @@ -39,6 +39,7 @@ import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) +import Util ( filterByList ) import Var @@ -165,7 +166,8 @@ synifyTyCon coax tc | isTypeFamilyTyCon tc = case famTyConFlav_maybe tc of Just rhs -> - let info = case rhs of + let resultVar = famTcResVar tc + info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) @@ -177,21 +179,25 @@ synifyTyCon coax tc AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily Nothing in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) + return (FamDecl (FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + })) Nothing -> Left "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' + FamDecl (FamilyDecl DataFamily (synifyName tc) + (synifyTyVars (tyConTyVars tc)) + (noLoc NoSig) -- always kind '*' + Nothing) -- no injectivity _ -> Left "synifyTyCon: impossible open data type?" | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc @@ -242,6 +248,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLoc . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2b50ce9a..b8fac887 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -176,6 +176,25 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) + = do { lhs' <- renameL lhs + ; rhs' <- mapM renameL rhs + ; return (L loc (InjectivityAnn lhs' rhs')) } + +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -335,13 +354,16 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily -- cgit v1.2.3 From fea4277692ba68cccc6c9642655289037e4b8979 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Mon, 21 Sep 2015 12:00:47 -0400 Subject: React to refactoring CoAxiom branch lists. --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 43cd0ea2..3fd783aa 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -172,7 +172,7 @@ synifyTyCon coax tc ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) -> return $ ClosedTypeFamily $ Just $ - brListMap (noLoc . synifyAxBranch tc) branches + map (noLoc . synifyAxBranch tc) (fromBranches branches) Nothing -> return $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily $ Just [] -- cgit v1.2.3 From 5890a2d503b3200e9897ce331ad61d808a67fca3 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 25 Jul 2015 17:44:41 -0700 Subject: Track msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ab79fb8d..28f50c35 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,7 +125,9 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = msHsFilePath ms + , ifaceOrigFilename = case msHsFilePath ms of + Just path -> path + Nothing -> "(none)" , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From acfc97fdff76482e90bdd0e93e8982068017d23d Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 26 Sep 2015 16:23:00 +0200 Subject: Create Process: removed PhaseFailed --- haddock-api/src/Haddock.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 72c544e1..5a62f3db 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -118,11 +118,8 @@ handleGhcExceptions = -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure + print (e :: GhcException) + exitFailure ------------------------------------------------------------------------------- -- cgit v1.2.3 From c7a8a8b32c9075873d666f7d0fc8a99828e17344 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 11 Oct 2015 11:31:11 -0700 Subject: s/PackageKey/UnitId/g and s/packageKey/unitId/g Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock.hs | 8 ++++---- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/InterfaceFile.hs | 12 ++++++------ haddock-api/src/Haddock/ModuleTree.hs | 6 +++--- haddock-api/src/Haddock/Types.hs | 2 +- 8 files changed, 22 insertions(+), 22 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5a62f3db..72ec21c8 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -222,7 +222,7 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] + srcMap = Map.fromList [ (ifUnitId if_, x) | ((_, Just x), if_) <- pkgs ] render dflags flags qual interfaces installedIfaces srcMap @@ -247,8 +247,8 @@ render dflags flags qual ifaces installedIfaces srcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod - pkgStr = Just (packageKeyString pkgKey) + pkgKey = moduleUnitId pkgMod + pkgStr = Just (unitIdString pkgKey) (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -314,7 +314,7 @@ modulePackageInfo dflags flags modu = (fromMaybe (packageName pkg) (optPackageName flags), fromMaybe (packageVersion pkg) (optPackageVersion flags)) where - pkg = getPackageDetails dflags (modulePackageKey modu) + pkg = getPackageDetails dflags (moduleUnitId modu) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 6ef1e863..b2710703 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -305,7 +305,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index b2c60534..f1f109c5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -225,7 +225,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey origMod + origPkg = moduleUnitId origMod -- Name must be documented, otherwise we wouldn't get here Documented n mdl = head names diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 28f50c35..75702b50 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -160,7 +160,7 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageKey $ + (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -168,13 +168,13 @@ mkAliasMap dflags mRenamedSource = -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageKey -> ModuleName -> Module + DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainPackageKey mdlName + [] -> Module.mkModule Module.mainUnitId mdlName ------------------------------------------------------------------------------- @@ -692,8 +692,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageKey expMod - packageKey = modulePackageKey thisMod + m = mkModule unitId expMod + unitId = moduleUnitId thisMod -- Note [1]: diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e8db3cfb..4b66348c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifUnitId, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -52,11 +52,11 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifUnitId :: InterfaceFile -> UnitId +ifUnitId if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> moduleUnitId $ instMod iface binaryInterfaceMagic :: Word32 @@ -310,7 +310,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName) +type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName @@ -340,7 +340,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) + put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2f731214..e6cf8201 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) +import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) @@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 847320a7..5737c77c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -52,7 +52,7 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath +type SrcMap = Map UnitId FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources -- cgit v1.2.3 From 85b7ed6147c18611b5ef6b606f157086a8203e7d Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Fri, 16 Oct 2015 16:26:42 +0100 Subject: Roughly fix up haddock for DuplicateRecordFields changes This compiles, but will probably need more work to produce good documentation when the DuplicateRecordFields extension is used. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 11 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++++---- haddock-api/src/Haddock/Convert.hs | 8 +++++--- haddock-api/src/Haddock/GhcUtils.hs | 3 ++- haddock-api/src/Haddock/Interface/Create.hs | 17 ++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 8 ++++++-- haddock-api/src/Haddock/Types.hs | 4 ++-- haddock-api/src/Haddock/Utils.hs | 5 ++++- 9 files changed, 45 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index fe656a4b..55075e20 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -190,8 +190,8 @@ ppCtor dflags dat subdocs con f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ 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]] + [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b8558f4f..68149b41 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -24,9 +24,10 @@ import qualified Pretty import GHC import OccName import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) +import RdrName ( rdrNameOcc, mkRdrUnqual ) import FastString ( unpackFS, unpackLitString, zString ) import Outputable ( panic) +import PrelNames ( mkUnboundName ) import qualified Data.Map as Map import System.Directory @@ -686,12 +687,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) 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 -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -900,7 +901,9 @@ 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] where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC :: HsType DocName + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 56b64120..f94daabf 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -38,6 +38,8 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc, mkRdrUnqual ) +import PrelNames ( mkUnboundName ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -741,18 +743,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) 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 -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -874,7 +876,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3fd783aa..f0fc108b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -30,6 +30,7 @@ import Haddock.Types import HsSyn import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name +import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) @@ -293,9 +294,10 @@ synifyDataCon use_gadt_syntax dc = bang' -> noLoc $ HsBangTy bang' tySyn) arg_tys (dataConSrcBangs dc) - field_tys = zipWith (\field synTy -> noLoc $ ConDeclField - [synifyName field] synTy Nothing) - (dataConFieldLabels dc) linear_tys + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLoc $ + ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5caefa77..aa9a1c32 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -189,7 +189,8 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) + RecCon fields -> map (selectorFieldOcc . unL) $ + concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 75702b50..8f3b9f9a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -331,15 +331,16 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] + dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) 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) + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , n <- ns ] + , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -501,7 +502,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (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 $ @@ -790,7 +791,7 @@ extractDecl name mdl decl , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) @@ -821,11 +822,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + L l (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 ] + matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + , L l n <- ns, selectorFieldOcc 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/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b8fac887..033246a8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -273,7 +273,7 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) @@ -411,11 +411,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do - names' <- mapM renameL names + names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') +renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc (L l (FieldOcc lbl sel)) = do + sel' <- rename sel + return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5737c77c..33ab9592 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -281,7 +281,6 @@ data DocName -- documentation, as far as Haddock knows. deriving Eq - instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -562,8 +561,9 @@ instance Monad ErrMsgGhc where 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 PostRn DocName Name = DocName type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..c2e1b09a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,6 +63,7 @@ import Haddock.GhcUtils import GHC import Name +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns + field_avail :: LConDeclField Name -> Bool + field_avail (L _ (ConDeclField fs _ _)) + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3 From a394ee884befd8cc8ba31a6071afaec7cca14e7c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 26 Oct 2015 12:52:36 +0000 Subject: Track wip/spj-wildcard-refactor on main repo --- haddock-api/src/Haddock/Backends/Hoogle.hs | 33 ++++++---------- haddock-api/src/Haddock/Convert.hs | 33 +++++++++------- haddock-api/src/Haddock/GhcUtils.hs | 12 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 61 ++++++++++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 2 +- 5 files changed, 80 insertions(+), 61 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..8664db27 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (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) @@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -120,22 +113,19 @@ 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 d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x + typ = unL (hsSigType sig) ppSig _ _ = [] @@ -144,12 +134,13 @@ 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) nwcs) = TypeSig name (L l $ f sig) nwcs + addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" - 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) + f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) + f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty + f ty = HsQualTy (reL [context]) ty context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) @@ -194,10 +185,10 @@ ppCtor dflags dat subdocs con [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) name = out dflags $ map unL $ con_names con resType = case con_res con of diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f0fc108b..d74d528e 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -96,7 +96,7 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ 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 @@ -118,10 +118,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name - , tfe_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs - , hswb_wcs = [] } + , tfe_pats = HsIB { hsib_body = typats + , hsib_kvs = map tyVarName kvs + , hsib_tvs = map tyVarName tvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -310,8 +309,14 @@ synifyDataCon use_gadt_syntax dc = else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care - qvars ctx hat hs_res_ty Nothing + \hat -> return $ noLoc $ + ConDecl { con_names = [name] + , con_explicit = False -- we don't know nor care + , con_qvars = qvars + , con_cxt = ctx + , con_details = hat + , con_res = hs_res_ty + , con_doc = Nothing } -- we don't want any "deprecated GADT syntax" warnings! False @@ -327,7 +332,7 @@ synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars :: [TyVar] -> LHsQTyVars Name synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where @@ -393,15 +398,13 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - mkHsForAllTy forallPlicitness = - noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) + , hst_body = noLoc (synify WithinType tau) } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> mkHsForAllTy Explicit - ImplicitizeForAll -> mkHsForAllTy Implicit + WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + , hst_body = noLoc sPhi } + ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index aa9a1c32..49d6a420 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -69,7 +69,7 @@ getMainDeclBinder _ = [] -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances @@ -92,10 +92,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty nwcs) = +filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty nwcs) + filtered -> Just (TypeSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -106,8 +106,8 @@ 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 (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 @@ -199,7 +199,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/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 033246a8..318a88c0 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLSigType = renameWc renameLType + +renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLWcSigType = renameImplicit renameLSigType + renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl extra tyvars lcontext ltype -> do + HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- renameLTyVarBndrs tyvars + ltype' <- renameLType ltype + return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + + HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl extra tyvars' lcontext' ltype') + return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype @@ -252,7 +262,7 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } @@ -423,16 +433,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = 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' PlaceHolder) + ltype' <- renameLWcSigType ltype + return (TypeSig lnames' ltype') PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - lty' <- renameLType lty + lty' <- renameLSigType lty return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames @@ -445,11 +455,11 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -484,33 +494,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + = do { tc' <- renameL tc + ; tvs' <- renameLTyVarBndrs tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing) + -> HsImplicitBndrs Name in_thing + -> RnM (HsImplicitBndrs DocName out_thing) +renameImplicit rn_thing (HsIB { hsib_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsIB { hsib_body = thing' + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + +renameWc :: (in_thing -> RnM out_thing) + -> HsWildcardBndrs Name in_thing + -> RnM (HsWildcardBndrs DocName out_thing) +renameWc rn_thing (HsWC { hswc_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsWC { hswc_body = thing' + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index c2e1b09a..3964c86a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name +emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -- cgit v1.2.3 From 18de4f2f992d3ed41eb83cb073e63304f0271dca Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 14:24:56 +0000 Subject: Track change to PatSyn.patSynSig --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f0fc108b..6f0684dc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -99,7 +99,7 @@ tyThingToLHsDecl t = case t of (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps qtvs = univ_tvs ++ ex_tvs ty = mkFunTys arg_tys res_ty in allOK . SigD $ PatSynSig (synifyName ps) -- cgit v1.2.3 From ec20bd15e724d580a01d9fad98791bb53db5e57c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 17:34:18 +0000 Subject: Follow changes to HsTYpe Not yet complete (but on a wip/ branch) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 31 +++++++----------- haddock-api/src/Haddock/Convert.hs | 46 ++++++++++++++------------ haddock-api/src/Haddock/Interface/Create.hs | 48 ++++++++------------------- haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++--------------- haddock-api/src/Haddock/Utils.hs | 29 ++++++++++++++++ 5 files changed, 103 insertions(+), 102 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8664db27..b7dfad64 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -113,38 +113,29 @@ 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 _ _)) = pp_sig dflags [name] (hsSigType typ) + f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = unL (hsSigType sig) +ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig) ppSig _ _ = [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String] +pp_sig dflags names (L _ typ) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) - where - addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - - f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) - f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty - f ty = HsQualTy (reL [context]) ty - - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) - + concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x) + where + add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = [dropComment $ out dflags x] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d74d528e..952650c1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -96,17 +96,10 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon 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 allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -316,16 +309,16 @@ synifyDataCon use_gadt_syntax dc = , con_cxt = ctx , con_details = hat , con_res = hs_res_ty - , con_doc = Nothing } + , con_doc = Nothing -- we don't want any "deprecated GADT syntax" warnings! - False + , con_old_rec = False } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] +synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name @@ -337,12 +330,14 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv + +synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -360,6 +355,15 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +-- The empty binders is a bit suspicious; +-- what if the type has free variables? +synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) + +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +-- Ditto (see synifySigType) +synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) + synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) @@ -398,11 +402,11 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) - , hst_body = noLoc (synify WithinType tau) } + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8f3b9f9a..d53e7351 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -347,15 +347,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - 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 - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) + SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) + ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) + go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) + go n (HsQualTy { hst_body = 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 @@ -728,8 +727,8 @@ 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 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 (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) @@ -773,17 +772,17 @@ extractDecl name mdl decl case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity + isTypeLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 + [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) + in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } + , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> @@ -797,24 +796,6 @@ extractDecl name mdl decl [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -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 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 -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name @@ -823,7 +804,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] @@ -833,7 +814,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) = | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 318a88c0..f95e527e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,11 +170,11 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType -renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLSigType = renameWc renameLType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType = renameImplicit renameLType -renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLWcSigType = renameImplicit renameLSigType +renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType = renameImplicit (renameWc renameLType) renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -205,11 +205,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) - HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do + HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) @@ -262,10 +262,10 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -330,13 +330,13 @@ renameTyClD d = case d of SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) @@ -344,7 +344,7 @@ renameTyClD d = case d of , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats @@ -368,7 +368,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' @@ -397,7 +397,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype @@ -435,15 +435,12 @@ renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLWcSigType ltype + ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') - PatSynSig lname (flag, qtvs) lreq lprov lty -> do + PatSynSig lname sig_ty -> do lname' <- renameL lname - qtvs' <- renameLTyVarBndrs qtvs - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - lty' <- renameLSigType lty - return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + sig_ty' <- renameLSigType sig_ty + return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) @@ -478,7 +475,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode @@ -505,7 +502,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' @@ -526,15 +523,15 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildcardBndrs Name in_thing - -> RnM (HsWildcardBndrs DocName out_thing) + -> HsWildCardBndrs Name in_thing + -> RnM (HsWildCardBndrs DocName out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3964c86a..6a499f64 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -16,6 +16,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, + mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) + +addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +-- Add the class context to a class-op signature +addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) + = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar (hsLTyVarName tv)) + | tv <- hsQTvBndrs tvs ] + -------------------------------------------------------------------------------- -- * Making abstract declarations -------------------------------------------------------------------------------- -- cgit v1.2.3 From 174f23631a0a8de7dc0f3cd67c393a5ca88c4a2b Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 23 Sep 2015 18:43:18 +0200 Subject: Account for Typeable changes The treatment of type families changed. --- haddock-api/src/Haddock/Convert.hs | 69 ++++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6f0684dc..4cb42597 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -141,7 +141,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon coax tc +synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc @@ -164,42 +164,37 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc - = case famTyConFlav_maybe tc of - Just rhs -> - let resultVar = famTcResVar tc - info = case rhs of - OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon mb -> case mb of - Just (CoAxiom { co_ax_branches = branches }) - -> return $ ClosedTypeFamily $ Just $ - map (noLoc . synifyAxBranch tc) (fromBranches branches) - Nothing -> return $ ClosedTypeFamily $ Just [] - BuiltInSynFamTyCon {} - -> return $ ClosedTypeFamily $ Just [] - AbstractClosedSynFamilyTyCon {} - -> return $ ClosedTypeFamily Nothing - in info >>= \i -> - return (FamDecl (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) - , fdInjectivityAnn = - synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) - })) - Nothing -> Left "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) - (synifyTyVars (tyConTyVars tc)) - (noLoc NoSig) -- always kind '*' - Nothing) -- no injectivity - _ -> Left "synifyTyCon: impossible open data type?" +synifyTyCon _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = famTcResVar tc + mkFamDecl i = return $ FamDecl $ + FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + } + +synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) -- cgit v1.2.3 From 8358cd222cc5a2d9f971691fe62e7e2c352d7c9b Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 30 Oct 2015 13:03:51 +0000 Subject: Work on updating Haddock to wip/spj-wildard-recactor Still incomplete --- haddock-api/src/Haddock/Backends/LaTeX.hs | 143 ++++++++++--------------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 17 ++- haddock-api/src/Haddock/Utils.hs | 2 +- 3 files changed, 63 insertions(+), 99 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 68149b41..dfeb1428 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -213,9 +213,9 @@ 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 t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -250,8 +250,8 @@ 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 (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -293,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | 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 (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) + (hsSigWcType t) unicode + SigD (PatSynSig lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -311,8 +312,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -329,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -340,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -352,29 +355,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - 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 - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -394,22 +385,14 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - 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 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 - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args _n leader (HsForAllTy tvs ltype) + = decltt leader + <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + do_args n leader (HsQualTy lctxt ltype) + = decltt leader + <-> ppLContextNoArrow lctxt unicode <+> nl $$ + do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r @@ -424,12 +407,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -478,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -521,8 +504,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -613,21 +596,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -661,13 +643,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -675,7 +657,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + | otherwise = ty + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + -- 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 = case con_names con of @@ -791,9 +778,6 @@ 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 @@ -879,34 +863,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -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} - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX 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 extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where - anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt + sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty pREC_TOP ty unicode ] +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + sep [ ppLContext ctxt unicode + , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f94daabf..7f1d7d07 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -50,8 +50,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 qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + SigD (PatSynSig lname ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname 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,23 +74,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = pp_typ = ppType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppBinder summary occname + , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode (hsSigType ty) ] cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 6a499f64..f7a32dd3 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -132,7 +132,7 @@ mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name -- Add the class context to a class-op signature -addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) +addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where -- cgit v1.2.3 From 987b5062482e20a032fb6358e655265b0b7a3cd2 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 31 Oct 2015 11:01:45 +0100 Subject: Relax upper bound on `base` to allow base-4.9 --- haddock-api/haddock-api.cabal | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b2199c68..dc3e8c69 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -36,7 +36,7 @@ library Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , filepath , directory diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b0f886cd..d21b851e 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,7 +21,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , transformers , deepseq diff --git a/haddock.cabal b/haddock.cabal index 3b6002f1..56e62e60 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -45,7 +45,7 @@ executable haddock ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE -- cgit v1.2.3 From b2d4b230c2446d241fd8730cd158e4fe6b7305df Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Sat, 31 Oct 2015 19:08:13 +0000 Subject: More adaption to wildcard-refactor --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 162 +++++++++++++------------ 3 files changed, 85 insertions(+), 81 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index dfeb1428..3514f74e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -384,7 +384,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index b2710703..31757eeb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -584,7 +584,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 _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7f1d7d07..c523d610 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -45,13 +45,14 @@ 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 - SigD (PatSynSig lname ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty 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 + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + 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" @@ -61,20 +62,20 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> LHsSigType DocName + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual @@ -83,18 +84,11 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unico +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppDocBinder name + , ppBinder summary occname , dcolon unicode - , ppLType unicode (hsSigType ty) + , ppLType unicode qual (hsSigType typ) ] - 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 - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -128,22 +122,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + do_args n leader (HsForAllTy tvs ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAll tvs unicode qual + + do_args n leader (HsQualTy lctxt ltype) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -171,20 +172,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs - -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -199,7 +199,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvBndrs ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -285,7 +286,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) @@ -358,10 +359,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode 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 cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -392,7 +389,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -425,8 +422,9 @@ 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 + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -470,8 +468,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) 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 + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -484,12 +483,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 @@ -660,23 +659,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L loc con) + = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of @@ -706,12 +705,19 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + <+> ppLType unicode qual (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) <+> fixity + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + | otherwise = ty + fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual occ = map (nameOccName . getName . unLoc) $ con_names con @@ -844,38 +850,36 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAllCon :: Bool -> LHsQTyVars DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html ppForAllCon expl tvs 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 +ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html +ppLTyVarBndrs show_forall tvs unicode _qual + | show_forall + , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode + | otherwise = noHtml where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + tv_bndrs = hsQTvBndrs tvs +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html 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 extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ -- cgit v1.2.3 From 7f4519f0bb2a490fd9c1b42d37ae4f14390551b4 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 27 Oct 2015 16:12:50 +0200 Subject: Matching change GHC #11017 BooleanFormula located --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 9 +++++---- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +++- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f94daabf..8996fc87 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -486,9 +486,9 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of + minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] -> noHtml @@ -504,9 +504,10 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances instances nm unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4cb42597..9cc9e115 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -78,7 +78,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8f3b9f9a..6a9c8cd4 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -557,7 +557,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -749,7 +749,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 033246a8..131082cd 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -437,7 +437,9 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig src s -> MinimalSig src <$> traverse renameL s + MinimalSig src (L l s) -> do + s' <- traverse renameL s + return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3 From 52c963e0b19783c4ca59cd0e8cfe1366dbfa1624 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Sun, 1 Nov 2015 12:08:58 +0000 Subject: Change for IEThingWith --- haddock-api/src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6a9c8cd4..5b9532e6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -502,7 +502,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _) = declWith t + lookupExport (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 $ -- cgit v1.2.3 From 83a9e9d2c7f0debec9d56e8b3b7cc8a8eb73361e Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 11 Nov 2015 11:35:51 +0100 Subject: Eliminate support for deprecated GADT syntax Follows from GHC D1460. --- haddock-api/src/Haddock/Convert.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 9cc9e115..a61e3696 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -307,8 +307,6 @@ synifyDataCon use_gadt_syntax dc = in hs_arg_tys >>= \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care qvars ctx hat hs_res_ty Nothing - -- we don't want any "deprecated GADT syntax" warnings! - False synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -- cgit v1.2.3 From e763c004c8eb067ed0ef510fda9cb4ab102ea6ae Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Fri, 13 Nov 2015 21:56:18 -0800 Subject: Undo msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5b9532e6..9b8bbe50 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,9 +125,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = case msHsFilePath ms of - Just path -> path - Nothing -> "(none)" + , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From c122a762c7839704644221a251cbe5ad3254f836 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 18 Nov 2015 11:32:54 +0000 Subject: Wibbles to Haddock --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index dca16408..b0a4f503 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -482,8 +482,8 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | L _ (MinimalSig _ (L _ 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] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method -- cgit v1.2.3 From fcd1bb7177a800f6f56a623c2468fc46a59c527b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 21 Nov 2015 21:16:12 +0200 Subject: Update to match GHC wip/T11019 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 6 +++--- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 10 +++++----- haddock-api/src/Haddock/Types.hs | 13 +++++++------ 7 files changed, 27 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..68896d72 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -152,7 +152,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + (map (reL . HsTyVar . reL . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) ppInstance :: DynFlags -> ClsInst -> [String] @@ -201,7 +201,7 @@ ppCtor dflags dat subdocs con name = out dflags $ map unL $ con_names con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ + ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT _ x -> x diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 68149b41..c4468c9c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -902,14 +902,14 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] where anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -947,7 +947,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8996fc87..328684f3 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -835,7 +835,7 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html -ppHsTyVarBndr _ qual (UserTyVar name ) = +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> @@ -877,19 +877,19 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ +ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -928,7 +928,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a61e3696..ff34d271 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -326,7 +326,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs where (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv @@ -349,7 +349,7 @@ data SynifyTypeState synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -374,7 +374,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) + (noLoc $ HsTyVar $ noLoc (getName tc)) (map (synifyType WithinType) tys) synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9b8bbe50..349356d6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -800,7 +800,7 @@ extractDecl name mdl decl toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc +toTypeNoLoc = noLoc . HsTyVar extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name @@ -829,7 +829,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 131082cd..f9edb574 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -204,7 +204,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsForAllTy expl extra tyvars' lcontext' ltype') - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -259,9 +259,9 @@ renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -273,8 +273,8 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name -renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 33ab9592..43671de3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -558,12 +558,13 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = DocName +type instance PostRn DocName (Located Name) = Located DocName +type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder -- cgit v1.2.3 From 42b2cfc595f1ee62d1c1b8513c5df1d92709c06a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 23 Nov 2015 17:17:18 +0000 Subject: Wibble --- haddock-api/src/Haddock/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index f7a32dd3..658007ba 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -150,7 +150,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (hsLTyVarName tv)) + = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) | tv <- hsQTvBndrs tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3 From a6deefad581cbeb62048826bc1d626c41a0dd56c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 5 Dec 2015 00:29:55 +0100 Subject: Canonicalise Monad instances --- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Types.hs | 10 +++++----- .../attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs | 6 +++--- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index eda5f1bf..f2f93966 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -91,13 +91,13 @@ newtype RnM a = instance Monad RnM where (>>=) = thenRn - return = returnRn + return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where - pure = return + pure = returnRn (<*>) = ap returnRn :: a -> RnM a diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 43671de3..f667b52c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -492,11 +492,11 @@ instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where - pure = return - (<*>) = ap + pure a = Writer (a, []) + (<*>) = ap instance Monad ErrMsgM where - return a = Writer (a, []) + return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a) @@ -545,11 +545,11 @@ instance Functor ErrMsgGhc where fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where - pure = return + pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) + return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs index 6719e09a..9c7994e9 100644 --- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs @@ -126,7 +126,7 @@ instance Monad (Parser i) where where msg = "Failed reading: " ++ err {-# INLINE fail #-} - return v = Parser $ \t pos more _lose succ -> succ t pos more v + return = pure {-# INLINE return #-} m >>= k = Parser $ \t !pos more lose succ -> @@ -158,7 +158,7 @@ apP d e = do {-# INLINE apP #-} instance Applicative (Parser i) where - pure = return + pure v = Parser $ \t pos more _lose succ -> succ t pos more v {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} @@ -166,7 +166,7 @@ instance Applicative (Parser i) where -- These definitions are equal to the defaults, but this -- way the optimizer doesn't have to work so hard to figure -- that out. - (*>) = (>>) + m *> k = m >>= \_ -> k {-# INLINE (*>) #-} x <* y = x >>= \a -> y >> return a {-# INLINE (<*) #-} -- cgit v1.2.3 From 222954753de7a8a3708baff1d75a4b7c3a675f4b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 17:33:52 +0200 Subject: Matching changes for #11028 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 71 ++++++++++++++- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 ++++++++----------------- haddock-api/src/Haddock/Convert.hs | 24 ++--- haddock-api/src/Haddock/GhcUtils.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 13 +-- haddock-api/src/Haddock/Interface/Rename.hs | 28 +++--- haddock-api/src/Haddock/Utils.hs | 20 ++++- 8 files changed, 176 insertions(+), 121 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index bc5588af..54dfb193 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -166,8 +166,9 @@ 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 - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] @@ -180,12 +181,18 @@ ppCtor dflags dat subdocs con apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) - name = out dflags $ map unL $ con_names con + name = out dflags $ map unL $ getConNames con - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ + resType = apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] + + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4aec7917..223006f3 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -575,14 +575,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -607,6 +607,71 @@ ppConstrHdr forall tvs ctxt unicode False -> empty +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = + leader <-> + case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppOcc) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon (L _ fields) -> + (decltt (header_ unicode <+> ppOcc) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppOcc, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + + + header_ = ppConstrHdr False tyVars context + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt 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 = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst + +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = + leader <-> + doGADTCon (hsib_body $ con_type con) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + + -- 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 = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst +{- old + ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX ppSideBySideConstr subdocs unicode leader (L loc con) = @@ -670,7 +735,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1aa4d954..d49d0949 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -539,11 +539,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -557,7 +557,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -573,7 +575,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -582,15 +586,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] instancesBit = ppInstances instances docname unicode qual @@ -606,8 +608,8 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +ppShortConstrParts summary dataInst con unicode qual = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) @@ -620,28 +622,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -651,12 +640,11 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax @@ -675,11 +663,11 @@ ppConstrHdr forall_ tvs ctxt unicode qual ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L loc con) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -693,35 +681,25 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> ppLType unicode qual (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + <+> ppLType unicode qual ty <+> fixity - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) - | otherwise = ty - fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -731,15 +709,13 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) [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 + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + forall_ = False -- 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 $ head $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification @@ -848,24 +824,6 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAllCon :: Bool -> LHsQTyVars DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html -ppLTyVarBndrs show_forall tvs unicode _qual - | show_forall - , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode - | otherwise = noHtml - where - tv_bndrs = hsQTvBndrs tvs - ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot @@ -898,7 +856,9 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur + -- un ConDeclGADT, but is + -- output elsewhere ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 49c471a4..8983cc77 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -292,19 +292,21 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT noSrcSpan (synifyType WithinType res_ty) - else ResTyH98 + gadt_ty = HsIB [] [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return $ noLoc $ - ConDecl { con_names = [name] - , con_explicit = False -- we don't know nor care - , con_qvars = qvars - , con_cxt = ctx - , con_details = hat - , con_res = hs_res_ty - , con_doc = Nothing } + \hat -> + if use_gadt_syntax + then return $ noLoc $ + ConDeclGADT { con_names = [name] + , con_type = gadt_ty + , con_doc = Nothing } + else return $ noLoc $ + ConDeclH98 { con_name = name + , con_qvars = Just qvars + , con_cxt = Just ctx + , con_details = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 49d6a420..ab4d6c78 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -188,14 +188,14 @@ class Parent a where instance Parent (ConDecl Name) where children con = - case con_details con of + case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d - | isDataDecl d = map unL $ concatMap (con_names . unL) + | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ @@ -209,7 +209,7 @@ family = getName &&& children familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) +familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index da59c5fa..30b32963 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -334,9 +335,9 @@ subordinates instMap decl = case decl of where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] + | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] @@ -785,7 +786,8 @@ extractDecl name mdl decl SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -800,7 +802,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of + case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest @@ -809,7 +811,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) = matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty + -- | ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = hsib_body $ con_type con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f2f93966..0b975687 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -393,17 +393,16 @@ 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_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -415,9 +414,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 658007ba..45deca9c 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -180,18 +180,32 @@ 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 | any (\n -> n `elem` names) (map unLoc $ con_names d) = - case con_details d of + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where + h98d = h98ConDecl d + h98ConDecl c@ConDeclH98{} = c + h98ConDecl c@ConDeclGADT{} = c' + where + (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) + c' :: ConDecl Name + c' = ConDeclH98 + { con_name = head (con_names c) + , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_cxt = Just cxt + , con_details = details + , con_doc = con_doc c + } + field_avail :: LConDeclField Name -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs -- cgit v1.2.3 From f4ef2548954bedf26674adc7a06574e718898d19 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 19:45:33 +0200 Subject: Placeholder for record style GADT declaration A GADT Declaration is now presented as CmmCondBranch :: {..} -> CmmNode O C cml_pred :: CmmExpr cml_true, cml_false :: !Label cml_likely :: Maybe Bool for CmmCondBranch :: { -- conditional branch cml_pred :: CmmExpr, cml_true, cml_false :: ULabel, cml_likely :: Maybe Bool -- likely result of the conditional, -- if known } -> CmmNode O C --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d49d0949..4983aadd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -694,6 +694,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT <+> ppLType unicode qual ty <+> fixity @@ -856,9 +857,10 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur - -- un ConDeclGADT, but is - -- output elsewhere +ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" + -- Can now legally occur in ConDeclGADT, the output here is to provide a + -- placeholder in the signature, which is followed by the field + -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -- cgit v1.2.3 From 0fc8cfd532f5dfd12b5504f44a2b3c9fb659cd87 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 8 Dec 2015 23:54:34 -0500 Subject: Update for type=kinds --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 ++-- haddock-api/src/Haddock/Convert.hs | 43 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 24 ++++++++---- haddock-api/src/Haddock/Interface/Rename.hs | 12 +++--- haddock-api/src/Haddock/Utils.hs | 8 ++-- 7 files changed, 60 insertions(+), 46 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 54dfb193..e73192ed 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -184,7 +184,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} name = out dflags $ map unL $ getConNames con resType = apps $ map (reL . HsTyVar . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 223006f3..e9cc3f83 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -412,7 +412,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName) tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -723,7 +723,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) | otherwise = ty mk_phi ty | null context = ty | otherwise = L loc (HsQualTy (con_cxt con) ty) @@ -955,7 +955,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -965,7 +964,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -985,6 +984,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4983aadd..0b5a3356 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html] ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvBndrs ltyvars)) + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -864,7 +864,7 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ @@ -874,7 +874,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 8983cc77..2e28b0dd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,19 +28,19 @@ import DataCon import FamInstEnv import Haddock.Types import HsSyn -import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) -import Util ( filterByList ) +import Util ( filterByList, filterOut ) import Var @@ -109,11 +109,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats - , hsib_kvs = map tyVarName kvs - , hsib_tvs = map tyVarName tvs } + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -141,8 +139,8 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -180,11 +178,12 @@ synifyTyCon _coax tc , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) + synifyFamilyResultSig resultVar tyConResKind , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) (familyTyConInjectivityInfo tc) } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc @@ -292,7 +291,7 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] [] (synifyType WithinType res_ty) + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> @@ -321,10 +320,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } - where - (kvs, tvs) = partition isKindVar ktvs +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv @@ -379,19 +376,21 @@ synifyType _ (TyConApp tc tys) , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) (noLoc $ HsTyVar $ noLoc (getName tc)) - (map (synifyType WithinType) tys) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 @@ -406,6 +405,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -421,7 +422,7 @@ synifyInstHead (_, preds, cls, types) = , map (unLoc . synifyType WithinType) ts , ClassInst $ map (unLoc . synifyType WithinType) preds ) - where (ks,ts) = break (not . isKind) types + where (ks,ts) = partitionInvisibles (classTyCon cls) id types -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) @@ -434,4 +435,4 @@ synifyFamInst fi opaque = synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, map (unLoc . synifyType WithinType) ts , f') - where (ks,ts) = break (not . isKind) $ fi_tys fi + where (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 080de6ff..86a9957c 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -41,7 +42,7 @@ import PrelNames import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -146,18 +147,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -207,9 +216,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0b975687..845cb909 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -234,11 +234,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -254,18 +254,18 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -529,7 +529,7 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } + , hsib_vars = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 45deca9c..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) - | tv <- hsQTvBndrs tvs ] + | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- * Making abstract declarations @@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] c' :: ConDecl Name c' = ConDeclH98 { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } , con_cxt = Just cxt , con_details = details , con_doc = con_doc c @@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3 From d4657f07912416a1b14ddb517696f8ef3ffb85a7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 12 Dec 2015 17:20:15 +0100 Subject: Update for D1200 --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Interface/LexParseRn.hs | 5 +++-- haddock-api/src/Haddock/Types.hs | 5 +++-- haddock.cabal | 1 + 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index dc3e8c69..292965bf 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -45,6 +45,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 + , ghc-boot , ghc == 7.9.* , ghc-paths diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index ac823da3..9c46c700 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,8 @@ import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) +import DynFlags (languageExtensions) +import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader @@ -65,7 +66,7 @@ processModuleHeader dflags gre safety mayStr = do doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag] + let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index f667b52c..6305dba1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -31,7 +31,8 @@ import qualified Data.Map as Map import Documentation.Haddock.Types import BasicTypes (Fixity(..)) import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) +import DynFlags (Language) +import qualified GHC.LanguageExtensions as LangExt import OccName import Outputable import NameSet (NameSet) @@ -400,7 +401,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] + , hmi_extensions :: [LangExt.Extension] } diff --git a/haddock.cabal b/haddock.cabal index 56e62e60..dc331b2f 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -57,6 +57,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, + ghc-boot, ghc >= 7.11 && < 7.13, bytestring, transformers -- cgit v1.2.3 From 91217a9642962476a736f6179d0803ddb787c2b9 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 05:40:17 -0500 Subject: Types: Add Outputable[Bndr] DocName instances --- haddock-api/src/Haddock/Types.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6305dba1..6f9b64dd 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -286,6 +286,14 @@ instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging +instance Outputable DocName where + ppr = ppr . getName + +instance OutputableBndr DocName where + pprBndr _ = ppr . getName + pprPrefixOcc = pprPrefixOcc . getName + pprInfixOcc = pprInfixOcc . getName ----------------------------------------------------------------------------- -- * Instances -- cgit v1.2.3 From 66cf3d2714ef1cf851782fbe4378f8c2b1af3335 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 06:05:25 -0500 Subject: Fix fallout from wildcards refactoring The wildcard refactoring was introduced a new type of signature, `ClassOpSig`, which is carried by typeclasses. The original patch adapting Haddock for this change missed a few places where this constructor needed to be handled, resulting in no class methods in documentation produced by Haddock. Additionally, this moves and renames the `isVanillaLSig` helper from GHC's HsBinds module into GhcUtils, since it is only used by Haddock. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/GhcUtils.hs | 18 ++++++++++++++---- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++++ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0b5a3356..d54f4e16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -412,7 +412,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -451,7 +451,7 @@ ppClassDecl summary links instances fixities loc d subdocs +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index ab4d6c78..2fbc5f82 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -96,6 +96,10 @@ filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -106,13 +110,19 @@ 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 (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ 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 _ = [] +-- | Was this signature given by the user? +isUserLSig :: LSig name -> Bool +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 30b32963..7da965ac 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -396,7 +396,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -428,7 +428,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -441,7 +441,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 845cb909..091d9bff 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -441,6 +441,10 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') PatSynSig lname sig_ty -> do lname' <- renameL lname sig_ty' <- renameLSigType sig_ty -- cgit v1.2.3